diff options
| author | Yann Herklotz <git@yannherklotz.com> | 2021-09-17 18:28:55 +0100 |
|---|---|---|
| committer | Yann Herklotz <git@yannherklotz.com> | 2021-09-17 18:28:55 +0100 |
| commit | a1c401a4eba5fc9fcf42933f70005ecb679a4c1c (patch) | |
| tree | 26637fca5d1da9b3d049234721d593a60b03a6d3 | |
| parent | c49caca4b5f0239b43610fbfe012d6ba0211b364 (diff) | |
| parent | 1daf96cdca4d828c333cea5c9a314ef861342984 (diff) | |
| download | compcert-dev/michalis.tar.gz compcert-dev/michalis.zip | |
Merge branch 'master' into dev/michalisdev/michalis
337 files changed, 12887 insertions, 8490 deletions
@@ -1,3 +1,69 @@ +Release 3.9, 2021-05-10 +======================= + +New features: +- New port: AArch64 (ARM 64 bits, "Apple silicon") under macOS. +- Support bitfields of types other than `int`, provided they are no larger + than 32 bits (#387) +- Support `__builtin_unreachable` and `__builtin_expect` (#394) + (but these builtins are not used for optimization yet) + +Optimizations: +- Improved branch tunneling: optimized conditional branches can + introduce further opportunities for tunneling, which are now taken + into account. + +Usability: +- Pragmas within functions are now ignored (with a warning) instead of + being lifted just before the function like in earlier versions. +- configure script: add `-mandir` option (#382) + +Compiler internals: +- Finer control of variable initialization in sections. Now we can + put variables initialized with symbol addresses that need relocation + in specific sections (e.g. `const_data` on macOS). +- Support re-normalization of function parameters at function entry, + as required by the AArch64/ELF ABI. +- PowerPC 64 bits: remove `Pfcfi`, `Pfcfiu`, `Pfctiu` pseudo-instructions, + expanding the corresponding int<->FP conversions during the + selection pass instead. + +Bug fixing: +- PowerPC 64 bits: incorrect `ld` and `std` instructions were generated + and rejected by the assembler. +- PowerPC: some variadic functions had the wrong position for their + first variadic parameter. +- RISC-V: fix calling convention in the case of floating-point + arguments that are passed in integer registers. +- AArch64: the default function alignment was incorrect, causing a + warning from the LLVM assembler. +- Pick the correct archiver to build `.a` library archives (#380). +- x86 32 bits: make sure functions returning structs and unions + return the correct pointer in register EAX (#377). +- PowerPC, ARM, AArch64: updated the registers destroyed by asm + pseudo-instructions and built-in functions. +- Remove spurious error on initialization of a local struct + containing a flexible array member. +- Fixed bug in emulation of assignment to a volatile bit-field (#395). + +The clightgen tool: +- Move the `$` notation for Clight identifiers to scope `clight_scope` + and submodule `ClightNotations`, to avoid clashes with Ltac2's use of `$` + (#392). + +Coq development: +- Compatibility with Coq 8.12.2, 8.13.0, 8.13.1, 8.13.2. +- Compatibility with Menhir 20210419 and up. +- Oldest Coq version supported is now 8.9.0. +- Use the `lia` tactic instead of `omega`. +- Updated the Flocq library to version 3.4.0. + +Licensing and distribution: +- Dual-licensed source files are now distributed under the LGPL version 2.1 + (plus the Inria non-commercial license) instead of the GPL version 2 + (plus the Inria non-commercial license). + + Release 3.8, 2020-11-16 ======================= @@ -19,8 +19,8 @@ AbsInt Angewandte Informatik GmbH. The following files in this distribution are dual-licensed both under the INRIA Non-Commercial License Agreement and under the Free Software -Foundation GNU General Public License, either version 2 or (at your -option) any later version: +Foundation GNU Lesser General Public License, either version 2.1 or +(at your option) any later version: all files in the lib/ directory @@ -56,17 +56,17 @@ option) any later version: Makefile.extr Makefile.menhir -A copy of the GNU General Public License version 2 is included below. -The choice between the two licenses for the files listed above is left -to the user. If you opt for the GNU General Public License, these -files are free software and can be used both in commercial and -non-commercial contexts, subject to the terms of the GNU General -Public License. +A copy of the GNU Lesser General Public License version 2.1 is +included below. The choice between the two licenses for the files +listed above is left to the user. If you opt for the GNU Lesser +General Public License, these files are free software and can be used +both in commercial and non-commercial contexts, subject to the terms +of the GNU Lesser General Public License. The files contained in the flocq/ directory and its subdirectories are taken from the Flocq project, http://flocq.gforge.inria.fr/. The files contained in the MenhirLib directory are taken from the Menhir -project, http://gallium.inria.fr/~fpottier/menhir/. The files from the +project, https://gitlab.inria.fr/fpottier/menhir. The files from the Flocq project and the files in the MenhirLib directory are Copyright 2010-2019 INRIA and distributed under the terms of the GNU Lesser General Public Licence, either version 3 of the licence, or (at your @@ -170,224 +170,400 @@ INRIA Non-Commercial License Agreement for the CompCert verified compiler ---------------------------------------------------------------------- - GNU GENERAL PUBLIC LICENSE - Version 2, June 1991 + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 - Copyright (C) 1989, 1991 Free Software Foundation, Inc., - 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. - Preamble +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public -License is intended to guarantee your freedom to share and change free -software--to make sure the software is free for all its users. This -General Public License applies to most of the Free Software -Foundation's software and to any other program whose authors commit to -using it. (Some other Free Software Foundation software is covered by -the GNU Lesser General Public License instead.) You can apply it to -your programs, too. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -this service if you wish), that you receive source code or can get it -if you want it, that you can change the software or use pieces of it -in new free programs; and that you know you can do these things. +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. To protect your rights, we need to make restrictions that forbid -anyone to deny you these rights or to ask you to surrender the rights. -These restrictions translate to certain responsibilities for you if you -distribute copies of the software, or if you modify it. - - For example, if you distribute copies of such a program, whether -gratis or for a fee, you must give the recipients all the rights that -you have. You must make sure that they, too, receive or can get the -source code. And you must show them these terms so they know their -rights. - - We protect your rights with two steps: (1) copyright the software, and -(2) offer you this license which gives you legal permission to copy, -distribute and/or modify the software. - - Also, for each author's protection and ours, we want to make certain -that everyone understands that there is no warranty for this free -software. If the software is modified by someone else and passed on, we -want its recipients to know that what they have is not the original, so -that any problems introduced by others will not reflect on the original -authors' reputations. - - Finally, any free program is threatened constantly by software -patents. We wish to avoid the danger that redistributors of a free -program will individually obtain patent licenses, in effect making the -program proprietary. To prevent this, we have made it clear that any -patent must be licensed for everyone's free use or not licensed at all. +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. The precise terms and conditions for copying, distribution and -modification follow. - - GNU GENERAL PUBLIC LICENSE +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - 0. This License applies to any program or other work which contains -a notice placed by the copyright holder saying it may be distributed -under the terms of this General Public License. The "Program", below, -refers to any such program or work, and a "work based on the Program" -means either the Program or any derivative work under copyright law: -that is to say, a work containing the Program or a portion of it, -either verbatim or with modifications and/or translated into another -language. (Hereinafter, translation is included without limitation in -the term "modification".) Each licensee is addressed as "you". - -Activities other than copying, distribution and modification are not + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of -running the Program is not restricted, and the output from the Program -is covered only if its contents constitute a work based on the -Program (independent of having been made by running the Program). -Whether that is true depends on what the Program does. - - 1. You may copy and distribute verbatim copies of the Program's -source code as you receive it, in any medium, provided that you -conspicuously and appropriately publish on each copy an appropriate -copyright notice and disclaimer of warranty; keep intact all the -notices that refer to this License and to the absence of any warranty; -and give any other recipients of the Program a copy of this License -along with the Program. - -You may charge a fee for the physical act of transferring a copy, and -you may at your option offer warranty protection in exchange for a fee. - - 2. You may modify your copy or copies of the Program or any portion -of it, thus forming a work based on the Program, and copy and +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: - a) You must cause the modified files to carry prominent notices + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. - b) You must cause any work that you distribute or publish, that in - whole or in part contains or is derived from the Program or any - part thereof, to be licensed as a whole at no charge to all third - parties under the terms of this License. - - c) If the modified program normally reads commands interactively - when run, you must cause it, when started running for such - interactive use in the most ordinary way, to print or display an - announcement including an appropriate copyright notice and a - notice that there is no warranty (or else, saying that you provide - a warranty) and that users may redistribute the program under - these conditions, and telling the user how to view a copy of this - License. (Exception: if the Program itself is interactive but - does not normally print such an announcement, your work based on - the Program is not required to print an announcement.) + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Program, +identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based -on the Program, the distribution of the whole must be on the terms of +on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the -entire whole, and thus to each and every part regardless of who wrote it. +entire whole, and thus to each and every part regardless of who wrote +it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or -collective works based on the Program. +collective works based on the Library. -In addition, mere aggregation of another work not based on the Program -with the Program (or with a work based on the Program) on a volume of +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. - 3. You may copy and distribute the Program (or a work based on it, -under Section 2) in object code or executable form under the terms of -Sections 1 and 2 above provided that you also do one of the following: - - a) Accompany it with the complete corresponding machine-readable - source code, which must be distributed under the terms of Sections - 1 and 2 above on a medium customarily used for software interchange; or, - - b) Accompany it with a written offer, valid for at least three - years, to give any third party, for a charge no more than your - cost of physically performing source distribution, a complete - machine-readable copy of the corresponding source code, to be - distributed under the terms of Sections 1 and 2 above on a medium - customarily used for software interchange; or, - - c) Accompany it with the information you received as to the offer - to distribute corresponding source code. (This alternative is - allowed only for noncommercial distribution and only if you - received the program in object code or executable form with such - an offer, in accord with Subsection b above.) - -The source code for a work means the preferred form of the work for -making modifications to it. For an executable work, complete source -code means all the source code for all modules it contains, plus any -associated interface definition files, plus the scripts used to -control compilation and installation of the executable. However, as a -special exception, the source code distributed need not include -anything that is normally distributed (in either source or binary -form) with the major components (compiler, kernel, and so on) of the -operating system on which the executable runs, unless that component -itself accompanies the executable. - -If distribution of executable or object code is made by offering -access to copy from a designated place, then offering equivalent -access to copy the source code from the same place counts as -distribution of the source code, even though third parties are not + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not compelled to copy the source along with the object code. - 4. You may not copy, modify, sublicense, or distribute the Program -except as expressly provided under this License. Any attempt -otherwise to copy, modify, sublicense or distribute the Program is -void, and will automatically terminate your rights under this License. -However, parties who have received copies, or rights, from you under -this License will not have their licenses terminated so long as such -parties remain in full compliance. - - 5. You are not required to accept this License, since you have not + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or -distribute the Program or its derivative works. These actions are +distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Program (or any work based on the -Program), you indicate your acceptance of this License to do so, and +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying -the Program or works based on it. +the Library or works based on it. - 6. Each time you redistribute the Program (or any work based on the -Program), the recipient automatically receives a license from the -original licensor to copy, distribute or modify the Program subject to -these terms and conditions. You may not impose any further + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. -You are not responsible for enforcing compliance by third parties to +You are not responsible for enforcing compliance by third parties with this License. - - 7. If, as a consequence of a court judgment or allegation of patent + + 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you -may not distribute the Program at all. For example, if a patent -license would not permit royalty-free redistribution of the Program by +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to -refrain entirely from distribution of the Program. +refrain entirely from distribution of the Library. -If any portion of this section is held invalid or unenforceable under -any particular circumstance, the balance of the section is intended to -apply and the section as a whole is intended to apply in other -circumstances. +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the -integrity of the free software distribution system, which is +integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that @@ -398,117 +574,104 @@ impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. - 8. If the distribution and/or use of the Program is restricted in + 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Program under this License -may add an explicit geographical distribution limitation excluding -those countries, so that distribution is permitted only in or among -countries not thus excluded. In such case, this License incorporates -the limitation as if written in the body of this License. - - 9. The Free Software Foundation may publish revised and/or new versions -of the General Public License from time to time. Such new versions will -be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - -Each version is given a distinguishing version number. If the Program -specifies a version number of this License which applies to it and "any -later version", you have the option of following the terms and conditions -either of that version or of any later version published by the Free -Software Foundation. If the Program does not specify a version number of -this License, you may choose any version ever published by the Free Software -Foundation. - - 10. If you wish to incorporate parts of the Program into other free -programs whose distribution conditions are different, write to the author -to ask for permission. For software which is copyrighted by the Free -Software Foundation, write to the Free Software Foundation; we sometimes -make exceptions for this. Our decision will be guided by the two goals -of preserving the free status of all derivatives of our free software and -of promoting the sharing and reuse of software generally. - - NO WARRANTY - - 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY -FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN -OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES -PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED -OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS -TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE -PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, -REPAIR OR CORRECTION. - - 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR -REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, -INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING -OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED -TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY -YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER -PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE -POSSIBILITY OF SUCH DAMAGES. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -convey the exclusion of warranty; and each file should have at least -the "copyright" line and a pointer to where the full notice is found. - - <one line to give the program's name and a brief idea of what it does.> +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + <one line to give the library's name and a brief idea of what it does.> Copyright (C) <year> <name of author> - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. - This program is distributed in the hope that it will be useful, + This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. - You should have received a copy of the GNU General Public License along - with this program; if not, write to the Free Software Foundation, Inc., - 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. -If the program is interactive, make it output a short notice like this -when it starts in an interactive mode: - - Gnomovision version 69, Copyright (C) year name of author - Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. - This is free software, and you are welcome to redistribute it - under certain conditions; type `show c' for details. - -The hypothetical commands `show w' and `show c' should show the appropriate -parts of the General Public License. Of course, the commands you use may -be called something other than `show w' and `show c'; they could even be -mouse-clicks or menu items--whatever suits your program. - You should also get your employer (if you work as a programmer) or your -school, if any, to sign a "copyright disclaimer" for the program, if +school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: - Yoyodyne, Inc., hereby disclaims all copyright interest in the program - `Gnomovision' (which makes passes at compilers) written by James Hacker. + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. - <signature of Ty Coon>, 1 April 1989 + <signature of Ty Coon>, 1 April 1990 Ty Coon, President of Vice -This General Public License does not permit incorporating your program into -proprietary programs. If your program is a subroutine library, you may -consider it more useful to permit linking proprietary applications with the -library. If this is what you want to do, use the GNU Lesser General -Public License instead of this License. +That's all there is to it! ---------------------------------------------------------------------- @@ -6,10 +6,11 @@ # # # Copyright Institut National de Recherche en Informatique et en # # Automatique. All rights reserved. This file is distributed # -# under the terms of the GNU General Public License as published by # -# the Free Software Foundation, either version 2 of the License, or # -# (at your option) any later version. This file is also distributed # -# under the terms of the INRIA Non-Commercial License Agreement. # +# under the terms of the GNU Lesser General Public License as # +# published by the Free Software Foundation, either version 2.1 of # +# the License, or (at your option) any later version. # +# This file is also distributed under the terms of the # +# INRIA Non-Commercial License Agreement. # # # ####################################################################### @@ -41,7 +42,23 @@ DIRS += MenhirLib COQINCLUDES += -R MenhirLib MenhirLib endif -COQCOPTS ?= -w -undeclared-scope -w -omega-is-deprecated +# Notes on silenced Coq warnings: +# +# undeclared-scope: +# warning introduced in 8.12 +# suggested change (use `Declare Scope`) supported since 8.12 +# unused-pattern-matching-variable: +# warning introduced in 8.13 +# the code rewrite that avoids the warning is not desirable +# deprecated-ident-entry: +# warning introduced in 8.13 +# suggested change (use `name` instead of `ident`) supported since 8.13 + +COQCOPTS ?= \ + -w -undeclared-scope \ + -w -unused-pattern-matching-variable \ + -w -deprecated-ident-entry + COQC="$(COQBIN)coqc" -q $(COQINCLUDES) $(COQCOPTS) COQDEP="$(COQBIN)coqdep" $(COQINCLUDES) COQDOC="$(COQBIN)coqdoc" @@ -57,6 +74,7 @@ GPATH=$(DIRS) ifeq ($(LIBRARY_FLOCQ),local) FLOCQ=\ + SpecFloatCompat.v \ Raux.v Zaux.v Defs.v Digits.v Float_prop.v FIX.v FLT.v FLX.v FTZ.v \ Generic_fmt.v Round_pred.v Round_NE.v Ulp.v Core.v \ Bracket.v Div.v Operations.v Round.v Sqrt.v \ diff --git a/Makefile.extr b/Makefile.extr index 23e01614..fc631d78 100644 --- a/Makefile.extr +++ b/Makefile.extr @@ -6,10 +6,11 @@ # # # Copyright Institut National de Recherche en Informatique et en # # Automatique. All rights reserved. This file is distributed # -# under the terms of the GNU General Public License as published by # -# the Free Software Foundation, either version 2 of the License, or # -# (at your option) any later version. This file is also distributed # -# under the terms of the INRIA Non-Commercial License Agreement. # +# under the terms of the GNU Lesser General Public License as # +# published by the Free Software Foundation, either version 2.1 of # +# the License, or (at your option) any later version. # +# This file is also distributed under the terms of the # +# INRIA Non-Commercial License Agreement. # # # ####################################################################### @@ -50,7 +51,7 @@ INCLUDES=$(patsubst %,-I %, $(DIRS)) # Control of warnings: -WARNINGS=-w +a-4-9-27 +WARNINGS=-w +a-4-9-27-70 extraction/%.cmx: WARNINGS +=-w -20-27-32..34-39-41-44..45-60-67 extraction/%.cmo: WARNINGS +=-w -20-27-32..34-39-41-44..45-60-67 cparser/pre_parser.cmx: WARNINGS += -w -41 diff --git a/Makefile.menhir b/Makefile.menhir index 7909b2f6..7687d3ed 100644 --- a/Makefile.menhir +++ b/Makefile.menhir @@ -6,10 +6,11 @@ # # # Copyright Institut National de Recherche en Informatique et en # # Automatique. All rights reserved. This file is distributed # -# under the terms of the GNU General Public License as published by # -# the Free Software Foundation, either version 2 of the License, or # -# (at your option) any later version. This file is also distributed # -# under the terms of the INRIA Non-Commercial License Agreement. # +# under the terms of the GNU Lesser General Public License as # +# published by the Free Software Foundation, either version 2.1 of # +# the License, or (at your option) any later version. # +# This file is also distributed under the terms of the # +# INRIA Non-Commercial License Agreement. # # # ####################################################################### diff --git a/MenhirLib/Validator_classes.v b/MenhirLib/Validator_classes.v index d8063123..781a6aa6 100644 --- a/MenhirLib/Validator_classes.v +++ b/MenhirLib/Validator_classes.v @@ -17,7 +17,7 @@ Require Import Alphabet. Class IsValidator (P : Prop) (b : bool) := is_validator : b = true -> P. -Hint Mode IsValidator + - : typeclass_instances. +Global Hint Mode IsValidator + - : typeclass_instances. Instance is_validator_true : IsValidator True true. Proof. done. Qed. @@ -55,12 +55,12 @@ Qed. (* We do not use an instance directly here, because we need somehow to force Coq to instantiate b with a lambda. *) -Hint Extern 2 (IsValidator (forall x : ?A, _) _) => +Global Hint Extern 2 (IsValidator (forall x : ?A, _) _) => eapply (is_validator_forall_finite _ _ (fun (x:A) => _)) : typeclass_instances. (* Hint for synthetizing pattern-matching. *) -Hint Extern 2 (IsValidator (match ?u with _ => _ end) ?b0) => +Global Hint Extern 2 (IsValidator (match ?u with _ => _ end) ?b0) => let b := fresh "b" in unshelve notypeclasses refine (let b : bool := _ in _); [destruct u; intros; shelve|]; (* Synthetize `match .. with` in the validator. *) @@ -71,5 +71,5 @@ Hint Extern 2 (IsValidator (match ?u with _ => _ end) ?b0) => (* Hint for unfolding definitions. This is necessary because many hints for IsValidator use [Hint Extern], which do not automatically unfold identifiers. *) -Hint Extern 100 (IsValidator ?X _) => unfold X +Global Hint Extern 100 (IsValidator ?X _) => unfold X : typeclass_instances. diff --git a/MenhirLib/Validator_complete.v b/MenhirLib/Validator_complete.v index 9ba3e53c..ac4dd0c4 100644 --- a/MenhirLib/Validator_complete.v +++ b/MenhirLib/Validator_complete.v @@ -140,7 +140,7 @@ Qed. (* We do not declare this lemma as an instance, and use [Hint Extern] instead, because the typeclass mechanism has trouble instantiating some evars if we do not explicitely call [eassumption]. *) -Hint Extern 2 (IsValidator (state_has_future _ _ _ _) _) => +Global Hint Extern 2 (IsValidator (state_has_future _ _ _ _) _) => eapply is_validator_state_has_future_subset; [eassumption|eassumption || reflexivity|] : typeclass_instances. @@ -171,7 +171,7 @@ Proof. - destruct (b lookahead). by destruct b'. exfalso. by induction l; destruct b'. - eauto. Qed. -Hint Extern 100 (IsValidator _ _) => +Global Hint Extern 100 (IsValidator _ _) => match goal with | H : TerminalSet.In ?lookahead ?lset |- _ => eapply (is_validator_iterate_lset _ (fun lookahead => _) _ _ H); clear H @@ -238,7 +238,7 @@ Proof. revert EQ. unfold future_of_prod=>-> //. Qed. (* We need a hint for expplicitely instantiating b1 and b2 with lambdas. *) -Hint Extern 0 (IsValidator +Global Hint Extern 0 (IsValidator (forall st prod fut lookahead, state_has_future st prod fut lookahead -> _) _) => @@ -1,4 +1,4 @@ -version=3.8 +version=3.9 buildnr= tag= branch= diff --git a/aarch64/Archi.v b/aarch64/Archi.v index 42500e70..4911db73 100644 --- a/aarch64/Archi.v +++ b/aarch64/Archi.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -85,6 +86,10 @@ Global Opaque ptr64 big_endian splitlong fma_order fma_invalid_mul_is_nan float_of_single_preserves_sNaN. -(** Whether to generate position-independent code or not *) +(** Which ABI to implement *) -Parameter pic_code: unit -> bool. +Inductive abi_kind: Type := + | AAPCS64 (**r ARM's standard as used in Linux and other ELF platforms *) + | Apple. (**r the variant used in macOS and iOS *) + +Parameter abi: abi_kind. diff --git a/aarch64/Asm.v b/aarch64/Asm.v index 5ac577b1..b5f4c838 100644 --- a/aarch64/Asm.v +++ b/aarch64/Asm.v @@ -970,9 +970,9 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pfmov rd r1 => Next (nextinstr (rs#rd <- (rs#r1))) m | Pfmovimms rd f => - Next (nextinstr (rs#rd <- (Vsingle f))) m + Next (nextinstr (rs#X16 <- Vundef #rd <- (Vsingle f))) m | Pfmovimmd rd f => - Next (nextinstr (rs#rd <- (Vfloat f))) m + Next (nextinstr (rs#X16 <- Vundef #rd <- (Vfloat f))) m | Pfmovi S rd r1 => Next (nextinstr (rs#rd <- (float32_of_bits rs##r1))) m | Pfmovi D rd r1 => @@ -1097,7 +1097,7 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Vint n => match list_nth_z tbl (Int.unsigned n) with | None => Stuck - | Some lbl => goto_label f lbl (rs#X16 <- Vundef #X17 <- Vundef) m + | Some lbl => goto_label f lbl (rs#X16 <- Vundef) m end | _ => Stuck end @@ -1212,7 +1212,7 @@ Inductive step: state -> trace -> state -> Prop := external_call ef ge vargs m t vres m' -> rs' = nextinstr (set_res res vres - (undef_regs (map preg_of (destroyed_by_builtin ef)) rs)) -> + (undef_regs (IR X16 :: IR X30 :: map preg_of (destroyed_by_builtin ef)) rs)) -> step (State rs m) t (State rs' m') | exec_step_external: forall b ef args res rs m t rs' m', @@ -1293,7 +1293,7 @@ Ltac Equalities := split. auto. intros. destruct B; auto. subst. auto. - (* trace length *) red; intros. inv H; simpl. - omega. + lia. eapply external_call_trace_length; eauto. eapply external_call_trace_length; eauto. - (* initial states *) diff --git a/aarch64/Asmexpand.ml b/aarch64/Asmexpand.ml index 1ba754dd..d24a9ef6 100644 --- a/aarch64/Asmexpand.ml +++ b/aarch64/Asmexpand.ml @@ -47,17 +47,28 @@ let expand_storeptr (src: ireg) (base: iregsp) ofs = (* Determine the number of int registers, FP registers, and stack locations used to pass the fixed parameters. *) +let align n a = (n + a - 1) land (-a) + +let typesize = function + | Tint | Tany32 | Tsingle -> 4 + | Tlong | Tany64 | Tfloat -> 8 + +let reserve_stack stk ty = + match Archi.abi with + | Archi.AAPCS64 -> stk + 8 + | Archi.Apple -> align stk (typesize ty) + typesize ty + let rec next_arg_locations ir fr stk = function | [] -> (ir, fr, stk) - | (Tint | Tlong | Tany32 | Tany64) :: l -> + | (Tint | Tlong | Tany32 | Tany64 as ty) :: l -> if ir < 8 then next_arg_locations (ir + 1) fr stk l - else next_arg_locations ir fr (stk + 8) l - | (Tfloat | Tsingle) :: l -> + else next_arg_locations ir fr (reserve_stack stk ty) l + | (Tfloat | Tsingle as ty) :: l -> if fr < 8 then next_arg_locations ir (fr + 1) stk l - else next_arg_locations ir fr (stk + 8) l + else next_arg_locations ir fr (reserve_stack stk ty) l (* Allocate memory on the stack and use it to save the registers used for parameter passing. As an optimization, do not save @@ -86,6 +97,8 @@ let save_parameter_registers ir fr = emit (Pstrd(float_param_regs.(i), ADimm(XSP, Z.of_uint pos))) done +let current_function_stacksize = ref 0L + (* Initialize a va_list as per va_start. Register r points to the following struct: @@ -98,11 +111,7 @@ let save_parameter_registers ir fr = } *) -let current_function_stacksize = ref 0L - -let expand_builtin_va_start r = - if not (is_current_function_variadic ()) then - invalid_arg "Fatal error: va_start used in non-vararg function"; +let expand_builtin_va_start_aapcs64 r = let (ir, fr, stk) = next_arg_locations 0 0 0 (get_current_function_args ()) in let stack_ofs = Int64.(add !current_function_stacksize (of_int stk)) @@ -127,6 +136,25 @@ let expand_builtin_va_start r = expand_loadimm32 X16 (coqint_of_camlint (Int32.of_int vr_offs)); emit (Pstrw(X16, ADimm(RR1 r, coqint_of_camlint64 28L))) +(* In macOS, va_list is just a pointer (char * ) and all variadic arguments + are passed on the stack. *) + +let expand_builtin_va_start_apple r = + let (ir, fr, stk) = + next_arg_locations 0 0 0 (get_current_function_args ()) in + let stk = align stk 8 in + let stack_ofs = Int64.(add !current_function_stacksize (of_int stk)) in + (* *va = sp + stack_ofs *) + expand_addimm64 (RR1 X16) XSP (coqint_of_camlint64 stack_ofs); + emit (Pstrx(X16, ADimm(RR1 r, coqint_of_camlint64 0L))) + +let expand_builtin_va_start r = + if not (is_current_function_variadic ()) then + invalid_arg "Fatal error: va_start used in non-vararg function"; + match Archi.abi with + | Archi.AAPCS64 -> expand_builtin_va_start_aapcs64 r + | Archi.Apple -> expand_builtin_va_start_apple r + (* Handling of annotations *) let expand_annot_val kind txt targ args res = @@ -327,8 +355,12 @@ let expand_builtin_inline name args res = (* Synchronization *) | "__builtin_membar", [], _ -> () + (* No operation *) | "__builtin_nop", [], _ -> emit Pnop + (* Optimization hint *) + | "__builtin_unreachable", [], _ -> + () (* Byte swap *) | ("__builtin_bswap" | "__builtin_bswap32"), [BA(IR a1)], BR(IR res) -> emit (Prev(W, res, a1)) @@ -380,7 +412,7 @@ let expand_instruction instr = match instr with | Pallocframe (sz, ofs) -> emit (Pmov (RR1 X29, XSP)); - if is_current_function_variadic() then begin + if is_current_function_variadic() && Archi.abi = Archi.AAPCS64 then begin let (ir, fr, _) = next_arg_locations 0 0 0 (get_current_function_args ()) in save_parameter_registers ir fr; diff --git a/aarch64/Asmgen.v b/aarch64/Asmgen.v index 875f3fd1..baaab6c4 100644 --- a/aarch64/Asmgen.v +++ b/aarch64/Asmgen.v @@ -15,6 +15,7 @@ Require Import Recdef Coqlib Zwf Zbits. Require Import Errors AST Integers Floats Op. Require Import Locations Mach Asm. +Require SelectOp. Local Open Scope string_scope. Local Open Scope list_scope. @@ -284,7 +285,7 @@ Definition shrx64 (rd r1: ireg) (n: int) (k: code) : code := (** Load the address [id + ofs] in [rd] *) Definition loadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (k: code) : code := - if Archi.pic_code tt then + if SelectOp.symbol_is_relocatable id then if Ptrofs.eq ofs Ptrofs.zero then Ploadsymbol rd id :: k else @@ -946,7 +947,7 @@ Definition transl_addressing (sz: Z) (addr: Op.addressing) (args: list mreg) OK (arith_extended Paddext (Padd X) X16 r1 r2 x a (insn (ADimm X16 Int64.zero) :: k)) | Aglobal id ofs, nil => - assertion (negb (Archi.pic_code tt)); + assertion (negb (SelectOp.symbol_is_relocatable id)); if Ptrofs.eq (Ptrofs.modu ofs (Ptrofs.repr sz)) Ptrofs.zero && symbol_is_aligned id sz then OK (Padrp X16 id ofs :: insn (ADadr X16 id ofs) :: k) else OK (loadsymbol X16 id ofs (insn (ADimm X16 Int64.zero) :: k)) diff --git a/aarch64/Asmgenproof.v b/aarch64/Asmgenproof.v index eeff1956..dc0bc509 100644 --- a/aarch64/Asmgenproof.v +++ b/aarch64/Asmgenproof.v @@ -67,7 +67,7 @@ Lemma transf_function_no_overflow: transf_function f = OK tf -> list_length_z tf.(fn_code) <= Ptrofs.max_unsigned. Proof. intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. - omega. + lia. Qed. Lemma exec_straight_exec: @@ -208,7 +208,7 @@ Qed. Remark loadsymbol_label: forall r id ofs k, tail_nolabel k (loadsymbol r id ofs k). Proof. intros; unfold loadsymbol. - destruct (Archi.pic_code tt); TailNoLabel. destruct Ptrofs.eq; TailNoLabel. + destruct (SelectOp.symbol_is_relocatable id); TailNoLabel. destruct Ptrofs.eq; TailNoLabel. Qed. Hint Resolve loadsymbol_label: labels. @@ -424,8 +424,8 @@ Proof. split. unfold goto_label. rewrite P. rewrite H1. auto. split. rewrite Pregmap.gss. constructor; auto. rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. - auto. omega. - generalize (transf_function_no_overflow _ _ H0). omega. + auto. lia. + generalize (transf_function_no_overflow _ _ H0). lia. intros. apply Pregmap.gso; auto. Qed. @@ -831,13 +831,16 @@ Local Transparent destroyed_by_op. econstructor; eauto. instantiate (2 := tf); instantiate (1 := x). unfold nextinstr. rewrite Pregmap.gss. - rewrite set_res_other. rewrite undef_regs_other_2. + rewrite set_res_other. rewrite undef_regs_other. rewrite <- H1. simpl. econstructor; eauto. eapply code_tail_next_int; eauto. - rewrite preg_notin_charact. intros. auto with asmgen. + simpl; intros. destruct H4. congruence. destruct H4. congruence. + exploit list_in_map_inv; eauto. intros (mr & U & V). subst. + auto with asmgen. auto with asmgen. apply agree_nextinstr. eapply agree_set_res; auto. - eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto. + eapply agree_undef_regs; eauto. intros. + simpl. rewrite undef_regs_other_2; auto. Simpl. congruence. - (* Mgoto *) @@ -879,7 +882,7 @@ Local Transparent destroyed_by_op. exploit functions_transl; eauto. intro FN. generalize (transf_function_no_overflow _ _ H5); intro NOOV. exploit find_label_goto_label. eauto. eauto. - instantiate (2 := rs0#X16 <- Vundef #X17 <- Vundef). + instantiate (2 := rs0#X16 <- Vundef). Simpl. eauto. eauto. intros [tc' [rs' [A [B C]]]]. @@ -946,10 +949,10 @@ Local Transparent destroyed_by_op. rewrite <- (sp_val _ _ _ AG). rewrite F. reflexivity. reflexivity. eexact U. } - exploit exec_straight_steps_2; eauto using functions_transl. omega. constructor. + exploit exec_straight_steps_2; eauto using functions_transl. lia. constructor. intros (ofs' & X & Y). left; exists (State rs3 m3'); split. - eapply exec_straight_steps_1; eauto. omega. constructor. + eapply exec_straight_steps_1; eauto. lia. constructor. econstructor; eauto. rewrite X; econstructor; eauto. apply agree_exten with rs2; eauto with asmgen. @@ -978,7 +981,7 @@ Local Transparent destroyed_at_function_entry. simpl. - (* return *) inv STACKS. simpl in *. - right. split. omega. split. auto. + right. split. lia. split. auto. rewrite <- ATPC in H5. econstructor; eauto. congruence. Qed. diff --git a/aarch64/Asmgenproof1.v b/aarch64/Asmgenproof1.v index 6d44bcc8..93c1f1ed 100644 --- a/aarch64/Asmgenproof1.v +++ b/aarch64/Asmgenproof1.v @@ -26,7 +26,7 @@ Lemma preg_of_iregsp_not_PC: forall r, preg_of_iregsp r <> PC. Proof. destruct r; simpl; congruence. Qed. -Hint Resolve preg_of_iregsp_not_PC: asmgen. +Global Hint Resolve preg_of_iregsp_not_PC: asmgen. Lemma preg_of_not_X16: forall r, preg_of r <> X16. Proof. @@ -44,7 +44,7 @@ Proof. intros. apply ireg_of_not_X16 in H. congruence. Qed. -Hint Resolve preg_of_not_X16 ireg_of_not_X16 ireg_of_not_X16': asmgen. +Global Hint Resolve preg_of_not_X16 ireg_of_not_X16 ireg_of_not_X16': asmgen. (** Useful simplification tactic *) @@ -81,8 +81,8 @@ Local Opaque Zzero_ext. induction N as [ | N]; simpl; intros. - constructor. - set (frag := Zzero_ext 16 (Z.shiftr n p)) in *. destruct (Z.eqb frag 0). -+ apply IHN. omega. -+ econstructor. reflexivity. omega. apply IHN; omega. ++ apply IHN. lia. ++ econstructor. reflexivity. lia. apply IHN; lia. Qed. Fixpoint recompose_int (accu: Z) (l: list (Z * Z)) : Z := @@ -100,43 +100,43 @@ Lemma decompose_int_correct: if zlt i p then Z.testbit accu i else Z.testbit n i). Proof. induction N as [ | N]; intros until accu; intros PPOS ABOVE i RANGE. -- simpl. rewrite zlt_true; auto. xomega. +- simpl. rewrite zlt_true; auto. extlia. - rewrite inj_S in RANGE. simpl. set (frag := Zzero_ext 16 (Z.shiftr n p)). assert (FRAG: forall i, p <= i < p + 16 -> Z.testbit n i = Z.testbit frag (i - p)). - { unfold frag; intros. rewrite Zzero_ext_spec by omega. rewrite zlt_true by omega. - rewrite Z.shiftr_spec by omega. f_equal; omega. } + { unfold frag; intros. rewrite Zzero_ext_spec by lia. rewrite zlt_true by lia. + rewrite Z.shiftr_spec by lia. f_equal; lia. } destruct (Z.eqb_spec frag 0). + rewrite IHN. -* destruct (zlt i p). rewrite zlt_true by omega. auto. +* destruct (zlt i p). rewrite zlt_true by lia. auto. destruct (zlt i (p + 16)); auto. - rewrite ABOVE by omega. rewrite FRAG by omega. rewrite e, Z.testbit_0_l. auto. -* omega. -* intros; apply ABOVE; omega. -* xomega. + rewrite ABOVE by lia. rewrite FRAG by lia. rewrite e, Z.testbit_0_l. auto. +* lia. +* intros; apply ABOVE; lia. +* extlia. + simpl. rewrite IHN. * destruct (zlt i (p + 16)). -** rewrite Zinsert_spec by omega. unfold proj_sumbool. - rewrite zlt_true by omega. +** rewrite Zinsert_spec by lia. unfold proj_sumbool. + rewrite zlt_true by lia. destruct (zlt i p). - rewrite zle_false by omega. auto. - rewrite zle_true by omega. simpl. symmetry; apply FRAG; omega. -** rewrite Z.ldiff_spec, Z.shiftl_spec by omega. - change 65535 with (two_p 16 - 1). rewrite Ztestbit_two_p_m1 by omega. - rewrite zlt_false by omega. rewrite zlt_false by omega. apply andb_true_r. -* omega. -* intros. rewrite Zinsert_spec by omega. unfold proj_sumbool. - rewrite zle_true by omega. rewrite zlt_false by omega. simpl. - apply ABOVE. omega. -* xomega. + rewrite zle_false by lia. auto. + rewrite zle_true by lia. simpl. symmetry; apply FRAG; lia. +** rewrite Z.ldiff_spec, Z.shiftl_spec by lia. + change 65535 with (two_p 16 - 1). rewrite Ztestbit_two_p_m1 by lia. + rewrite zlt_false by lia. rewrite zlt_false by lia. apply andb_true_r. +* lia. +* intros. rewrite Zinsert_spec by lia. unfold proj_sumbool. + rewrite zle_true by lia. rewrite zlt_false by lia. simpl. + apply ABOVE. lia. +* extlia. Qed. Corollary decompose_int_eqmod: forall N n, eqmod (two_power_nat (N * 16)%nat) (recompose_int 0 (decompose_int N n 0)) n. Proof. intros; apply eqmod_same_bits; intros. - rewrite decompose_int_correct. apply zlt_false; omega. - omega. intros; apply Z.testbit_0_l. xomega. + rewrite decompose_int_correct. apply zlt_false; lia. + lia. intros; apply Z.testbit_0_l. extlia. Qed. Corollary decompose_notint_eqmod: forall N n, @@ -145,8 +145,8 @@ Corollary decompose_notint_eqmod: forall N n, Proof. intros; apply eqmod_same_bits; intros. rewrite Z.lnot_spec, decompose_int_correct. - rewrite zlt_false by omega. rewrite Z.lnot_spec by omega. apply negb_involutive. - omega. intros; apply Z.testbit_0_l. xomega. omega. + rewrite zlt_false by lia. rewrite Z.lnot_spec by lia. apply negb_involutive. + lia. intros; apply Z.testbit_0_l. extlia. lia. Qed. Lemma negate_decomposition_wf: @@ -156,7 +156,7 @@ Proof. instantiate (1 := (Z.lnot m)). apply equal_same_bits; intros. rewrite H. change 65535 with (two_p 16 - 1). - rewrite Z.lxor_spec, !Zzero_ext_spec, Z.lnot_spec, Ztestbit_two_p_m1 by omega. + rewrite Z.lxor_spec, !Zzero_ext_spec, Z.lnot_spec, Ztestbit_two_p_m1 by lia. destruct (zlt i 16). apply xorb_true_r. auto. @@ -167,7 +167,7 @@ Lemma Zinsert_eqmod: eqmod (two_power_nat n) x1 x2 -> eqmod (two_power_nat n) (Zinsert x1 y p l) (Zinsert x2 y p l). Proof. - intros. apply eqmod_same_bits; intros. rewrite ! Zinsert_spec by omega. + intros. apply eqmod_same_bits; intros. rewrite ! Zinsert_spec by lia. destruct (zle p i && zlt i (p + l)); auto. apply same_bits_eqmod with n; auto. Qed. @@ -178,12 +178,12 @@ Lemma Zinsert_0_l: Z.shiftl (Zzero_ext l y) p = Zinsert 0 (Zzero_ext l y) p l. Proof. intros. apply equal_same_bits; intros. - rewrite Zinsert_spec by omega. unfold proj_sumbool. - destruct (zlt i p); [rewrite zle_false by omega|rewrite zle_true by omega]; simpl. + rewrite Zinsert_spec by lia. unfold proj_sumbool. + destruct (zlt i p); [rewrite zle_false by lia|rewrite zle_true by lia]; simpl. - rewrite Z.testbit_0_l, Z.shiftl_spec_low by auto. auto. -- rewrite Z.shiftl_spec by omega. +- rewrite Z.shiftl_spec by lia. destruct (zlt i (p + l)); auto. - rewrite Zzero_ext_spec, zlt_false, Z.testbit_0_l by omega. auto. + rewrite Zzero_ext_spec, zlt_false, Z.testbit_0_l by lia. auto. Qed. Lemma recompose_int_negated: @@ -193,12 +193,12 @@ Proof. induction 1; intros accu; simpl. - auto. - rewrite <- IHwf_decomposition. f_equal. apply equal_same_bits; intros. - rewrite Z.lnot_spec, ! Zinsert_spec, Z.lxor_spec, Z.lnot_spec by omega. + rewrite Z.lnot_spec, ! Zinsert_spec, Z.lxor_spec, Z.lnot_spec by lia. unfold proj_sumbool. destruct (zle p i); simpl; auto. destruct (zlt i (p + 16)); simpl; auto. change 65535 with (two_p 16 - 1). - rewrite Ztestbit_two_p_m1 by omega. rewrite zlt_true by omega. + rewrite Ztestbit_two_p_m1 by lia. rewrite zlt_true by lia. apply xorb_true_r. Qed. @@ -219,7 +219,7 @@ Proof. (Zinsert accu n p 16)) as (rs' & P & Q & R). Simpl. rewrite ACCU. simpl. f_equal. apply Int.eqm_samerepr. - apply Zinsert_eqmod. auto. omega. apply Int.eqm_sym; apply Int.eqm_unsigned_repr. + apply Zinsert_eqmod. auto. lia. apply Int.eqm_sym; apply Int.eqm_unsigned_repr. exists rs'; split. eapply exec_straight_opt_step_opt. simpl; eauto. auto. exact P. split. exact Q. intros; Simpl. rewrite R by auto. Simpl. @@ -244,7 +244,7 @@ Proof. unfold rs1; Simpl. exists rs2; split. eapply exec_straight_opt_step; eauto. - simpl. unfold rs1. do 5 f_equal. unfold accu0. rewrite H. apply Zinsert_0_l; omega. + simpl. unfold rs1. do 5 f_equal. unfold accu0. rewrite H. apply Zinsert_0_l; lia. reflexivity. split. exact Q. intros. rewrite R by auto. unfold rs1; Simpl. @@ -272,7 +272,7 @@ Proof. exists rs2; split. eapply exec_straight_opt_step; eauto. simpl. unfold rs1. do 5 f_equal. - unfold accu0. f_equal. rewrite H. apply Zinsert_0_l; omega. + unfold accu0. f_equal. rewrite H. apply Zinsert_0_l; lia. reflexivity. split. unfold accu0 in Q; rewrite recompose_int_negated in Q by auto. exact Q. intros. rewrite R by auto. unfold rs1; Simpl. @@ -302,8 +302,8 @@ Proof. apply Int.eqm_samerepr. apply decompose_notint_eqmod. apply Int.repr_unsigned. } destruct Nat.leb. -+ rewrite <- A. apply exec_loadimm_z_w. apply decompose_int_wf; omega. -+ rewrite <- B. apply exec_loadimm_n_w. apply decompose_int_wf; omega. ++ rewrite <- A. apply exec_loadimm_z_w. apply decompose_int_wf; lia. ++ rewrite <- B. apply exec_loadimm_n_w. apply decompose_int_wf; lia. Qed. Lemma exec_loadimm_k_x: @@ -323,7 +323,7 @@ Proof. (Zinsert accu n p 16)) as (rs' & P & Q & R). Simpl. rewrite ACCU. simpl. f_equal. apply Int64.eqm_samerepr. - apply Zinsert_eqmod. auto. omega. apply Int64.eqm_sym; apply Int64.eqm_unsigned_repr. + apply Zinsert_eqmod. auto. lia. apply Int64.eqm_sym; apply Int64.eqm_unsigned_repr. exists rs'; split. eapply exec_straight_opt_step_opt. simpl; eauto. auto. exact P. split. exact Q. intros; Simpl. rewrite R by auto. Simpl. @@ -348,7 +348,7 @@ Proof. unfold rs1; Simpl. exists rs2; split. eapply exec_straight_opt_step; eauto. - simpl. unfold rs1. do 5 f_equal. unfold accu0. rewrite H. apply Zinsert_0_l; omega. + simpl. unfold rs1. do 5 f_equal. unfold accu0. rewrite H. apply Zinsert_0_l; lia. reflexivity. split. exact Q. intros. rewrite R by auto. unfold rs1; Simpl. @@ -376,7 +376,7 @@ Proof. exists rs2; split. eapply exec_straight_opt_step; eauto. simpl. unfold rs1. do 5 f_equal. - unfold accu0. f_equal. rewrite H. apply Zinsert_0_l; omega. + unfold accu0. f_equal. rewrite H. apply Zinsert_0_l; lia. reflexivity. split. unfold accu0 in Q; rewrite recompose_int_negated in Q by auto. exact Q. intros. rewrite R by auto. unfold rs1; Simpl. @@ -406,8 +406,8 @@ Proof. apply Int64.eqm_samerepr. apply decompose_notint_eqmod. apply Int64.repr_unsigned. } destruct Nat.leb. -+ rewrite <- A. apply exec_loadimm_z_x. apply decompose_int_wf; omega. -+ rewrite <- B. apply exec_loadimm_n_x. apply decompose_int_wf; omega. ++ rewrite <- A. apply exec_loadimm_z_x. apply decompose_int_wf; lia. ++ rewrite <- B. apply exec_loadimm_n_x. apply decompose_int_wf; lia. Qed. (** Add immediate *) @@ -426,14 +426,14 @@ Lemma exec_addimm_aux_32: Proof. intros insn sem SEM ASSOC; intros. unfold addimm_aux. set (nlo := Zzero_ext 12 (Int.unsigned n)). set (nhi := Int.unsigned n - nlo). - assert (E: Int.unsigned n = nhi + nlo) by (unfold nhi; omega). + assert (E: Int.unsigned n = nhi + nlo) by (unfold nhi; lia). rewrite <- (Int.repr_unsigned n). destruct (Z.eqb_spec nhi 0); [|destruct (Z.eqb_spec nlo 0)]. - econstructor; split. apply exec_straight_one. apply SEM. Simpl. - split. Simpl. do 3 f_equal; omega. + split. Simpl. do 3 f_equal; lia. intros; Simpl. - econstructor; split. apply exec_straight_one. apply SEM. Simpl. - split. Simpl. do 3 f_equal; omega. + split. Simpl. do 3 f_equal; lia. intros; Simpl. - econstructor; split. eapply exec_straight_two. apply SEM. apply SEM. Simpl. Simpl. @@ -484,14 +484,14 @@ Lemma exec_addimm_aux_64: Proof. intros insn sem SEM ASSOC; intros. unfold addimm_aux. set (nlo := Zzero_ext 12 (Int64.unsigned n)). set (nhi := Int64.unsigned n - nlo). - assert (E: Int64.unsigned n = nhi + nlo) by (unfold nhi; omega). + assert (E: Int64.unsigned n = nhi + nlo) by (unfold nhi; lia). rewrite <- (Int64.repr_unsigned n). destruct (Z.eqb_spec nhi 0); [|destruct (Z.eqb_spec nlo 0)]. - econstructor; split. apply exec_straight_one. apply SEM. Simpl. - split. Simpl. do 3 f_equal; omega. + split. Simpl. do 3 f_equal; lia. intros; Simpl. - econstructor; split. apply exec_straight_one. apply SEM. Simpl. - split. Simpl. do 3 f_equal; omega. + split. Simpl. do 3 f_equal; lia. intros; Simpl. - econstructor; split. eapply exec_straight_two. apply SEM. apply SEM. Simpl. Simpl. @@ -594,13 +594,13 @@ Qed. (** Load address of symbol *) Lemma exec_loadsymbol: forall rd s ofs k rs m, - rd <> X16 \/ Archi.pic_code tt = false -> + rd <> X16 \/ SelectOp.symbol_is_relocatable s = false -> exists rs', exec_straight ge fn (loadsymbol rd s ofs k) rs m k rs' m /\ rs'#rd = Genv.symbol_address ge s ofs /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. Proof. - unfold loadsymbol; intros. destruct (Archi.pic_code tt). + unfold loadsymbol; intros. destruct (SelectOp.symbol_is_relocatable s). - predSpec Ptrofs.eq Ptrofs.eq_spec ofs Ptrofs.zero. + subst ofs. econstructor; split. apply exec_straight_one; [simpl; eauto | reflexivity]. @@ -1833,4 +1833,4 @@ Proof. intros. Simpl. Qed. -End CONSTRUCTORS.
\ No newline at end of file +End CONSTRUCTORS. diff --git a/aarch64/Builtins1.v b/aarch64/Builtins1.v index 53c83d7e..cd6f8cc4 100644 --- a/aarch64/Builtins1.v +++ b/aarch64/Builtins1.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/aarch64/CBuiltins.ml b/aarch64/CBuiltins.ml index e2a9c87a..80d66310 100644 --- a/aarch64/CBuiltins.ml +++ b/aarch64/CBuiltins.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -17,16 +18,28 @@ open C -(* va_list is a struct of size 32 and alignment 8, passed by reference *) +(* AAPCS64: + va_list is a struct of size 32 and alignment 8, passed by reference + Apple: + va_list is a pointer (size 8, alignment 8), passed by reference *) -let va_list_type = TArray(TInt(IULong, []), Some 4L, []) -let size_va_list = 32 -let va_list_scalar = false +let (va_list_type, size_va_list, va_list_scalar) = + match Archi.abi with + | Archi.AAPCS64 -> (TArray(TInt(IULong, []), Some 4L, []), 32, false) + | Archi.Apple -> (TPtr(TVoid [], []), 8, true) + +(* Some macOS headers use the GCC built-in types "__int128_t" and + "__uint128_t" unconditionally. Provide a dummy definition. *) + +let int128_type = TArray(TInt(IULong, []), Some 2L, []) let builtins = { - builtin_typedefs = [ - "__builtin_va_list", va_list_type - ]; + builtin_typedefs = + [ "__builtin_va_list", va_list_type ] @ + (if Configuration.system = "macos" then + [ "__int128_t", int128_type; + "__uint128_t", int128_type ] + else []); builtin_functions = [ (* Synchronization *) "__builtin_fence", diff --git a/aarch64/ConstpropOp.vp b/aarch64/ConstpropOp.vp index c0a2c6bf..f2d17a51 100644 --- a/aarch64/ConstpropOp.vp +++ b/aarch64/ConstpropOp.vp @@ -13,11 +13,11 @@ (** Strength reduction for operators and conditions. This is the machine-dependent part of [Constprop]. *) -Require Archi. Require Import Coqlib Compopts. Require Import AST Integers Floats. Require Import Op Registers. Require Import ValueDomain ValueAOp. +Require SelectOp. (** * Converting known values to constants *) @@ -375,7 +375,7 @@ Nondetfunction op_strength_reduction Nondetfunction addr_strength_reduction (addr: addressing) (args: list reg) (vl: list aval) := match addr, args, vl with - | Aindexed n, r1 :: nil, Ptr(Gl symb n1) :: nil => + | Aindexed n, r1 :: nil, Ptr(Gl symb n1) :: nil ?? negb (SelectOp.symbol_is_relocatable symb) => (Aglobal symb (Ptrofs.add n1 (Ptrofs.of_int64 n)), nil) | Aindexed n, r1 :: nil, Ptr(Stk n1) :: nil => (Ainstack (Ptrofs.add n1 (Ptrofs.of_int64 n)), nil) diff --git a/aarch64/ConstpropOpproof.v b/aarch64/ConstpropOpproof.v index deab7cd4..7f5f1e06 100644 --- a/aarch64/ConstpropOpproof.v +++ b/aarch64/ConstpropOpproof.v @@ -391,7 +391,7 @@ Proof. Int.bit_solve. destruct (zlt i0 n0). replace (Int.testbit n i0) with (negb (Int.testbit Int.zero i0)). rewrite Int.bits_zero. simpl. rewrite andb_true_r. auto. - rewrite <- EQ. rewrite Int.bits_zero_ext by omega. rewrite zlt_true by auto. + rewrite <- EQ. rewrite Int.bits_zero_ext by lia. rewrite zlt_true by auto. rewrite Int.bits_not by auto. apply negb_involutive. rewrite H6 by auto. auto. econstructor; split; eauto. auto. diff --git a/aarch64/Conventions1.v b/aarch64/Conventions1.v index efda835d..f401458c 100644 --- a/aarch64/Conventions1.v +++ b/aarch64/Conventions1.v @@ -24,7 +24,12 @@ Require Archi. - Caller-save registers that can be modified during a function call. We follow the Procedure Call Standard for the ARM 64-bit Architecture - (AArch64) document: R19-R28 and F8-F15 are callee-save. *) + (AArch64) document: R19-R28 and F8-F15 are callee-save. + + X16 is reserved as a temporary for asm generation. + X18 is reserved as the platform register. + X29 is reserved as the frame pointer register. + X30 is reserved as the return address register. *) Definition is_callee_save (r: mreg): bool := match r with @@ -154,9 +159,23 @@ Qed. (** - The first 8 integer arguments are passed in registers [R0...R7]. - The first 8 FP arguments are passed in registers [F0...F7]. -- Extra arguments are passed on the stack, in [Outgoing] slots of size - 64 bits (2 words), consecutively assigned, starting at word offset 0. -**) +- Extra arguments are passed on the stack, in [Outgoing] slots, + consecutively assigned, starting at word offset 0. + +In the standard AAPCS64, all stack slots are 8-byte wide (2 words). + +In the Apple variant, a stack slot has the size of the type of the +corresponding argument, and is aligned accordingly. We use 8-byte +slots (2 words) for C types [long] and [double], and 4-byte slots +(1 word) for C types [int] and [float]. For full conformance, we should +use 1-byte slots for [char] types and 2-byte slots for [short] types, +but this cannot be expressed in CompCert's type algebra, so we +incorrectly use 4-byte slots. + +Concerning variable arguments to vararg functions: +- In the AAPCS64 standard, they are passed like regular, fixed arguments. +- In the Apple variant, they are always passed on stack, in 8-byte slots. +*) Definition int_param_regs := R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 :: nil. @@ -164,31 +183,70 @@ Definition int_param_regs := Definition float_param_regs := F0 :: F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: nil. +Definition stack_arg (ty: typ) (ir fr ofs: Z) + (rec: Z -> Z -> Z -> list (rpair loc)) := + match Archi.abi with + | Archi.AAPCS64 => + let ofs := align ofs 2 in + One (S Outgoing ofs ty) :: rec ir fr (ofs + 2) + | Archi.Apple => + let ofs := align ofs (typesize ty) in + One (S Outgoing ofs ty) :: rec ir fr (ofs + typesize ty) + end. + +Definition int_arg (ty: typ) (ir fr ofs: Z) + (rec: Z -> Z -> Z -> list (rpair loc)) := + match list_nth_z int_param_regs ir with + | None => + stack_arg ty ir fr ofs rec + | Some ireg => + One (R ireg) :: rec (ir + 1) fr ofs + end. + +Definition float_arg (ty: typ) (ir fr ofs: Z) + (rec: Z -> Z -> Z -> list (rpair loc)) := + match list_nth_z float_param_regs fr with + | None => + stack_arg ty ir fr ofs rec + | Some freg => + One (R freg) :: rec ir (fr + 1) ofs + end. + +Fixpoint loc_arguments_stack (tyl: list typ) (ofs: Z) {struct tyl} : list (rpair loc) := + match tyl with + | nil => nil + | ty :: tys => One (S Outgoing ofs Tany64) :: loc_arguments_stack tys (ofs + 2) + end. + Fixpoint loc_arguments_rec - (tyl: list typ) (ir fr ofs: Z) {struct tyl} : list (rpair loc) := + (tyl: list typ) (fixed ir fr ofs: Z) {struct tyl} : list (rpair loc) := match tyl with | nil => nil - | (Tint | Tlong | Tany32 | Tany64) as ty :: tys => - match list_nth_z int_param_regs ir with - | None => - One (S Outgoing ofs ty) :: loc_arguments_rec tys ir fr (ofs + 2) - | Some ireg => - One (R ireg) :: loc_arguments_rec tys (ir + 1) fr ofs - end - | (Tfloat | Tsingle) as ty :: tys => - match list_nth_z float_param_regs fr with - | None => - One (S Outgoing ofs ty) :: loc_arguments_rec tys ir fr (ofs + 2) - | Some freg => - One (R freg) :: loc_arguments_rec tys ir (fr + 1) ofs + | ty :: tys => + if zle fixed 0 then loc_arguments_stack tyl (align ofs 2) else + match ty with + | Tint | Tlong | Tany32 | Tany64 => + int_arg ty ir fr ofs (loc_arguments_rec tys (fixed - 1)) + | Tfloat | Tsingle => + float_arg ty ir fr ofs (loc_arguments_rec tys (fixed - 1)) end end. +(** Number of fixed arguments for a function with signature [s]. + For AAPCS64, all arguments are treated as fixed, even for a vararg + function. *) + +Definition fixed_arguments (s: signature) : Z := + match Archi.abi, s.(sig_cc).(cc_vararg) with + | Archi.Apple, Some n => n + | _, _ => list_length_z s.(sig_args) + end. + (** [loc_arguments s] returns the list of locations where to store arguments when calling a function with signature [s]. *) Definition loc_arguments (s: signature) : list (rpair loc) := - loc_arguments_rec s.(sig_args) 0 0 0. + loc_arguments_rec s.(sig_args) (fixed_arguments s) 0 0 0. (** Argument locations are either caller-save registers or [Outgoing] stack slots at nonnegative offsets. *) @@ -200,49 +258,73 @@ Definition loc_argument_acceptable (l: loc) : Prop := | _ => False end. -Definition loc_argument_charact (ofs: Z) (l: loc) : Prop := - match l with - | R r => In r int_param_regs \/ In r float_param_regs - | S Outgoing ofs' ty => ofs' >= ofs /\ (2 | ofs') - | _ => False - end. - -Remark loc_arguments_rec_charact: - forall tyl ir fr ofs p, - In p (loc_arguments_rec tyl ir fr ofs) -> (2 | ofs) -> forall_rpair (loc_argument_charact ofs) p. +Lemma loc_arguments_rec_charact: + forall tyl fixed ri rf ofs p, + ofs >= 0 -> + In p (loc_arguments_rec tyl fixed ri rf ofs) -> forall_rpair loc_argument_acceptable p. Proof. - assert (X: forall ofs1 ofs2 l, loc_argument_charact ofs2 l -> ofs1 <= ofs2 -> loc_argument_charact ofs1 l). - { destruct l; simpl; intros; auto. destruct sl; auto. intuition omega. } - assert (Y: forall ofs1 ofs2 p, forall_rpair (loc_argument_charact ofs2) p -> ofs1 <= ofs2 -> forall_rpair (loc_argument_charact ofs1) p). - { destruct p; simpl; intuition eauto. } - assert (Z: forall ofs, (2 | ofs) -> (2 | ofs + 2)). - { intros. apply Z.divide_add_r; auto. apply Z.divide_refl. } -Opaque list_nth_z. - induction tyl; simpl loc_arguments_rec; intros. -- contradiction. -- assert (A: forall ty, In p - match list_nth_z int_param_regs ir with - | Some ireg => One (R ireg) :: loc_arguments_rec tyl (ir + 1) fr ofs - | None => One (S Outgoing ofs ty) :: loc_arguments_rec tyl ir fr (ofs + 2) - end -> - forall_rpair (loc_argument_charact ofs) p). - { intros. destruct (list_nth_z int_param_regs ir) as [r|] eqn:E; destruct H1. - subst. left. eapply list_nth_z_in; eauto. - eapply IHtyl; eauto. - subst. split. omega. assumption. - eapply Y; eauto. omega. } - assert (B: forall ty, In p - match list_nth_z float_param_regs fr with - | Some ireg => One (R ireg) :: loc_arguments_rec tyl ir (fr + 1) ofs - | None => One (S Outgoing ofs ty) :: loc_arguments_rec tyl ir fr (ofs + 2) - end -> - forall_rpair (loc_argument_charact ofs) p). - { intros. destruct (list_nth_z float_param_regs fr) as [r|] eqn:E; destruct H1. - subst. right. eapply list_nth_z_in; eauto. - eapply IHtyl; eauto. - subst. split. omega. assumption. - eapply Y; eauto. omega. } - destruct a; eauto. + set (OK := fun (l: list (rpair loc)) => + forall p, In p l -> forall_rpair loc_argument_acceptable p). + set (OKF := fun (f: Z -> Z -> Z -> list (rpair loc)) => + forall ri rf ofs, ofs >= 0 -> OK (f ri rf ofs)). + assert (CSI: forall r, In r int_param_regs -> is_callee_save r = false). + { decide_goal. } + assert (CSF: forall r, In r float_param_regs -> is_callee_save r = false). + { decide_goal. } + assert (ALP: forall ofs ty, ofs >= 0 -> align ofs (typesize ty) >= 0). + { intros. + assert (ofs <= align ofs (typesize ty)) by (apply align_le; apply typesize_pos). + lia. } + assert (ALD: forall ofs ty, ofs >= 0 -> (typealign ty | align ofs (typesize ty))). + { intros. apply Z.divide_trans with (typesize ty). apply typealign_typesize. apply align_divides. apply typesize_pos. } + assert (ALP2: forall ofs, ofs >= 0 -> align ofs 2 >= 0). + { intros. + assert (ofs <= align ofs 2) by (apply align_le; lia). + lia. } + assert (ALD2: forall ofs ty, ofs >= 0 -> (typealign ty | align ofs 2)). + { intros. eapply Z.divide_trans with 2. + exists (2 / typealign ty). destruct ty; reflexivity. + apply align_divides. lia. } + assert (STK: forall tyl ofs, + ofs >= 0 -> OK (loc_arguments_stack tyl ofs)). + { induction tyl as [ | ty tyl]; intros ofs OO; red; simpl; intros. + - contradiction. + - destruct H. + + subst p. split. auto. simpl. apply Z.divide_1_l. + + apply IHtyl with (ofs := ofs + 2). lia. auto. + } + assert (A: forall ty ri rf ofs f, + OKF f -> ofs >= 0 -> OK (stack_arg ty ri rf ofs f)). + { intros until f; intros OF OO; red; unfold stack_arg; intros. + destruct Archi.abi; destruct H. + - subst p; simpl; auto. + - eapply OF; [|eauto]. apply ALP2 in OO. lia. + - subst p; simpl; auto. + - eapply OF; [|eauto]. apply (ALP ofs ty) in OO. generalize (typesize_pos ty). lia. + } + assert (B: forall ty ri rf ofs f, + OKF f -> ofs >= 0 -> OK (int_arg ty ri rf ofs f)). + { intros until f; intros OF OO; red; unfold int_arg; intros. + destruct (list_nth_z int_param_regs ri) as [r|] eqn:NTH; [destruct H|]. + - subst p; simpl. apply CSI. eapply list_nth_z_in; eauto. + - eapply OF; eauto. + - eapply A; eauto. + } + assert (C: forall ty ri rf ofs f, + OKF f -> ofs >= 0 -> OK (float_arg ty ri rf ofs f)). + { intros until f; intros OF OO; red; unfold float_arg; intros. + destruct (list_nth_z float_param_regs rf) as [r|] eqn:NTH; [destruct H|]. + - subst p; simpl. apply CSF. eapply list_nth_z_in; eauto. + - eapply OF; eauto. + - eapply A; eauto. + } + cut (forall tyl fixed ri rf ofs, ofs >= 0 -> OK (loc_arguments_rec tyl fixed ri rf ofs)). + unfold OK. eauto. + induction tyl as [ | ty1 tyl]; intros until ofs; intros OO; simpl. +- red; simpl; tauto. +- destruct (zle fixed 0). + + apply (STK (ty1 :: tyl)); auto. + + unfold OKF in *; destruct ty1; eauto. Qed. Lemma loc_arguments_acceptable: @@ -250,19 +332,10 @@ Lemma loc_arguments_acceptable: In p (loc_arguments s) -> forall_rpair loc_argument_acceptable p. Proof. unfold loc_arguments; intros. - assert (A: forall r, In r int_param_regs -> is_callee_save r = false) by decide_goal. - assert (B: forall r, In r float_param_regs -> is_callee_save r = false) by decide_goal. - assert (X: forall l, loc_argument_charact 0 l -> loc_argument_acceptable l). - { unfold loc_argument_charact, loc_argument_acceptable. - destruct l as [r | [] ofs ty]; auto. intros [C|C]; auto. - intros [C D]. split; auto. apply Z.divide_trans with 2; auto. - exists (2 / typealign ty); destruct ty; reflexivity. - } - exploit loc_arguments_rec_charact; eauto using Z.divide_0_r. - unfold forall_rpair; destruct p; intuition auto. + eapply loc_arguments_rec_charact; eauto. lia. Qed. -Hint Resolve loc_arguments_acceptable: locs. +Global Hint Resolve loc_arguments_acceptable: locs. Lemma loc_arguments_main: loc_arguments signature_main = nil. @@ -270,16 +343,29 @@ Proof. unfold loc_arguments; reflexivity. Qed. -(** ** Normalization of function results *) +(** ** Normalization of function results and parameters *) (** According to the AAPCS64 ABI specification, "padding bits" in the return - value of a function have unpredictable values and must be ignored. - Consequently, we force normalization of return values of small integer - types (8- and 16-bit integers), so that the top bits (the "padding bits") - are proper sign- or zero-extensions of the small integer value. *) + value of a function or in a function parameter have unpredictable + values and must be ignored. Consequently, we force normalization + of return values and of function parameters when they have small + integer types (8- and 16-bit integers), so that the top bits (the + "padding bits") are proper sign- or zero-extensions of the small + integer value. + + The Apple variant of the AAPCS64 requires the callee to return a normalized + value, and the caller to pass normalized parameters, hence no + normalization is needed. + *) Definition return_value_needs_normalization (t: rettype) : bool := - match t with - | Tint8signed | Tint8unsigned | Tint16signed | Tint16unsigned => true - | _ => false + match Archi.abi with + | Archi.Apple => false + | Archi.AAPCS64 => + match t with + | Tint8signed | Tint8unsigned | Tint16signed | Tint16unsigned => true + | _ => false + end end. + +Definition parameter_needs_normalization := return_value_needs_normalization. diff --git a/aarch64/Op.v b/aarch64/Op.v index a7483d56..f8d2510e 100644 --- a/aarch64/Op.v +++ b/aarch64/Op.v @@ -957,25 +957,25 @@ End SHIFT_AMOUNT. Program Definition mk_amount32 (n: int): amount32 := {| a32_amount := Int.zero_ext 5 n |}. Next Obligation. - apply mk_amount_range. omega. reflexivity. + apply mk_amount_range. lia. reflexivity. Qed. Lemma mk_amount32_eq: forall n, Int.ltu n Int.iwordsize = true -> a32_amount (mk_amount32 n) = n. Proof. - intros. eapply mk_amount_eq; eauto. omega. reflexivity. + intros. eapply mk_amount_eq; eauto. lia. reflexivity. Qed. Program Definition mk_amount64 (n: int): amount64 := {| a64_amount := Int.zero_ext 6 n |}. Next Obligation. - apply mk_amount_range. omega. reflexivity. + apply mk_amount_range. lia. reflexivity. Qed. Lemma mk_amount64_eq: forall n, Int.ltu n Int64.iwordsize' = true -> a64_amount (mk_amount64 n) = n. Proof. - intros. eapply mk_amount_eq; eauto. omega. reflexivity. + intros. eapply mk_amount_eq; eauto. lia. reflexivity. Qed. (** Recognition of move operations. *) diff --git a/aarch64/SelectLongproof.v b/aarch64/SelectLongproof.v index b051369c..aee09b12 100644 --- a/aarch64/SelectLongproof.v +++ b/aarch64/SelectLongproof.v @@ -225,8 +225,8 @@ Proof. intros. unfold Int.ltu; apply zlt_true. apply Int.ltu_inv in H. apply Int.ltu_inv in H0. change (Int.unsigned Int64.iwordsize') with Int64.zwordsize in *. - unfold Int.sub; rewrite Int.unsigned_repr. omega. - assert (Int64.zwordsize < Int.max_unsigned) by reflexivity. omega. + unfold Int.sub; rewrite Int.unsigned_repr. lia. + assert (Int64.zwordsize < Int.max_unsigned) by reflexivity. lia. Qed. Theorem eval_shrluimm: @@ -242,13 +242,13 @@ Local Opaque Int64.zwordsize. + destruct (Int.ltu n a) eqn:L2. * assert (L3: Int.ltu (Int.sub a n) Int64.iwordsize' = true). { apply sub_shift_amount; auto using a64_range. - apply Int.ltu_inv in L2. omega. } + apply Int.ltu_inv in L2. lia. } econstructor; split. EvalOp. destruct v1; simpl; auto. rewrite mk_amount64_eq, L3, a64_range by auto. simpl. rewrite L. rewrite Int64.shru'_shl', L2 by auto using a64_range. auto. * assert (L3: Int.ltu (Int.sub n a) Int64.iwordsize' = true). { apply sub_shift_amount; auto using a64_range. - unfold Int.ltu in L2. destruct zlt in L2; discriminate || omega. } + unfold Int.ltu in L2. destruct zlt in L2; discriminate || lia. } econstructor; split. EvalOp. destruct v1; simpl; auto. rewrite mk_amount64_eq, L3, a64_range by auto. simpl. rewrite L. rewrite Int64.shru'_shl', L2 by auto using a64_range. auto. @@ -261,11 +261,11 @@ Local Opaque Int64.zwordsize. * econstructor; split. EvalOp. rewrite mk_amount64_eq by auto. destruct v1; simpl; auto. rewrite ! L; simpl. set (s' := s - Int.unsigned n). - replace s with (s' + Int.unsigned n) by (unfold s'; omega). - rewrite Int64.shru'_zero_ext. auto. unfold s'; omega. + replace s with (s' + Int.unsigned n) by (unfold s'; lia). + rewrite Int64.shru'_zero_ext. auto. unfold s'; lia. * econstructor; split. EvalOp. destruct v1; simpl; auto. rewrite ! L; simpl. - rewrite Int64.shru'_zero_ext_0 by omega. auto. + rewrite Int64.shru'_zero_ext_0 by lia. auto. + econstructor; eauto using eval_shrluimm_base. - intros; TrivialExists. Qed. @@ -290,13 +290,13 @@ Proof. + destruct (Int.ltu n a) eqn:L2. * assert (L3: Int.ltu (Int.sub a n) Int64.iwordsize' = true). { apply sub_shift_amount; auto using a64_range. - apply Int.ltu_inv in L2. omega. } + apply Int.ltu_inv in L2. lia. } econstructor; split. EvalOp. destruct v1; simpl; auto. rewrite mk_amount64_eq, L3, a64_range by auto. simpl. rewrite L. rewrite Int64.shr'_shl', L2 by auto using a64_range. auto. * assert (L3: Int.ltu (Int.sub n a) Int64.iwordsize' = true). { apply sub_shift_amount; auto using a64_range. - unfold Int.ltu in L2. destruct zlt in L2; discriminate || omega. } + unfold Int.ltu in L2. destruct zlt in L2; discriminate || lia. } econstructor; split. EvalOp. destruct v1; simpl; auto. rewrite mk_amount64_eq, L3, a64_range by auto. simpl. rewrite L. rewrite Int64.shr'_shl', L2 by auto using a64_range. auto. @@ -309,8 +309,8 @@ Proof. * InvBooleans. econstructor; split. EvalOp. rewrite mk_amount64_eq by auto. destruct v1; simpl; auto. rewrite ! L; simpl. set (s' := s - Int.unsigned n). - replace s with (s' + Int.unsigned n) by (unfold s'; omega). - rewrite Int64.shr'_sign_ext. auto. unfold s'; omega. unfold s'; omega. + replace s with (s' + Int.unsigned n) by (unfold s'; lia). + rewrite Int64.shr'_sign_ext. auto. unfold s'; lia. unfold s'; lia. * econstructor; split; [|eauto]. apply eval_shrlimm_base; auto. EvalOp. + econstructor; eauto using eval_shrlimm_base. - intros; TrivialExists. @@ -392,7 +392,7 @@ Proof. - TrivialExists. - destruct (zlt (Int.unsigned a0) sz). + econstructor; split. EvalOp. destruct v1; simpl; auto. rewrite a64_range; simpl. - apply Val.lessdef_same. f_equal. rewrite Int64.shl'_zero_ext by omega. f_equal. omega. + apply Val.lessdef_same. f_equal. rewrite Int64.shl'_zero_ext by lia. f_equal. lia. + TrivialExists. - TrivialExists. Qed. diff --git a/aarch64/SelectOp.vp b/aarch64/SelectOp.vp index 5bd96987..b5a03989 100644 --- a/aarch64/SelectOp.vp +++ b/aarch64/SelectOp.vp @@ -536,10 +536,18 @@ Definition select (ty: typ) (cond: condition) (args: exprlist) (e1 e2: expr) := (** ** Recognition of addressing modes for load and store operations *) +(** Some symbols are relocatable (e.g. external symbols in macOS) + and cannot be used with [Aglobal] addressing mode. *) + +Parameter symbol_is_relocatable: ident -> bool. + Nondetfunction addressing (chunk: memory_chunk) (e: expr) := match e with | Eop (Oaddrstack n) Enil => (Ainstack n, Enil) - | Eop (Oaddrsymbol id ofs) Enil => (Aglobal id ofs, Enil) + | Eop (Oaddrsymbol id ofs) Enil => + if symbol_is_relocatable id + then (Aindexed (Ptrofs.to_int64 ofs), Eop (Oaddrsymbol id Ptrofs.zero) Enil ::: Enil) + else (Aglobal id ofs, Enil) | Eop (Oaddlimm n) (e1:::Enil) => (Aindexed n, e1:::Enil) | Eop (Oaddlshift Slsl a) (e1:::e2:::Enil) => (Aindexed2shift a, e1:::e2:::Enil) | Eop (Oaddlext x a) (e1:::e2:::Enil) => (Aindexed2ext x a, e1:::e2:::Enil) diff --git a/aarch64/SelectOpproof.v b/aarch64/SelectOpproof.v index b78a5ed8..ccc4c0f1 100644 --- a/aarch64/SelectOpproof.v +++ b/aarch64/SelectOpproof.v @@ -243,8 +243,8 @@ Remark sub_shift_amount: Proof. intros. unfold Int.ltu; apply zlt_true. rewrite Int.unsigned_repr_wordsize. apply Int.ltu_iwordsize_inv in H. apply Int.ltu_iwordsize_inv in H0. - unfold Int.sub; rewrite Int.unsigned_repr. omega. - generalize Int.wordsize_max_unsigned; omega. + unfold Int.sub; rewrite Int.unsigned_repr. lia. + generalize Int.wordsize_max_unsigned; lia. Qed. Theorem eval_shruimm: @@ -260,13 +260,13 @@ Local Opaque Int.zwordsize. + destruct (Int.ltu n a) eqn:L2. * assert (L3: Int.ltu (Int.sub a n) Int.iwordsize = true). { apply sub_shift_amount; auto using a32_range. - apply Int.ltu_inv in L2. omega. } + apply Int.ltu_inv in L2. lia. } econstructor; split. EvalOp. destruct v1; simpl; auto. rewrite mk_amount32_eq, L3, a32_range by auto. simpl. rewrite L. rewrite Int.shru_shl, L2 by auto using a32_range. auto. * assert (L3: Int.ltu (Int.sub n a) Int.iwordsize = true). { apply sub_shift_amount; auto using a32_range. - unfold Int.ltu in L2. destruct zlt in L2; discriminate || omega. } + unfold Int.ltu in L2. destruct zlt in L2; discriminate || lia. } econstructor; split. EvalOp. destruct v1; simpl; auto. rewrite mk_amount32_eq, L3, a32_range by auto. simpl. rewrite L. rewrite Int.shru_shl, L2 by auto using a32_range. auto. @@ -279,11 +279,11 @@ Local Opaque Int.zwordsize. * econstructor; split. EvalOp. rewrite mk_amount32_eq by auto. destruct v1; simpl; auto. rewrite ! L; simpl. set (s' := s - Int.unsigned n). - replace s with (s' + Int.unsigned n) by (unfold s'; omega). - rewrite Int.shru_zero_ext. auto. unfold s'; omega. + replace s with (s' + Int.unsigned n) by (unfold s'; lia). + rewrite Int.shru_zero_ext. auto. unfold s'; lia. * econstructor; split. EvalOp. destruct v1; simpl; auto. rewrite ! L; simpl. - rewrite Int.shru_zero_ext_0 by omega. auto. + rewrite Int.shru_zero_ext_0 by lia. auto. + econstructor; eauto using eval_shruimm_base. - intros; TrivialExists. Qed. @@ -308,13 +308,13 @@ Proof. + destruct (Int.ltu n a) eqn:L2. * assert (L3: Int.ltu (Int.sub a n) Int.iwordsize = true). { apply sub_shift_amount; auto using a32_range. - apply Int.ltu_inv in L2. omega. } + apply Int.ltu_inv in L2. lia. } econstructor; split. EvalOp. destruct v1; simpl; auto. rewrite mk_amount32_eq, L3, a32_range by auto. simpl. rewrite L. rewrite Int.shr_shl, L2 by auto using a32_range. auto. * assert (L3: Int.ltu (Int.sub n a) Int.iwordsize = true). { apply sub_shift_amount; auto using a32_range. - unfold Int.ltu in L2. destruct zlt in L2; discriminate || omega. } + unfold Int.ltu in L2. destruct zlt in L2; discriminate || lia. } econstructor; split. EvalOp. destruct v1; simpl; auto. rewrite mk_amount32_eq, L3, a32_range by auto. simpl. rewrite L. rewrite Int.shr_shl, L2 by auto using a32_range. auto. @@ -327,8 +327,8 @@ Proof. * InvBooleans. econstructor; split. EvalOp. rewrite mk_amount32_eq by auto. destruct v1; simpl; auto. rewrite ! L; simpl. set (s' := s - Int.unsigned n). - replace s with (s' + Int.unsigned n) by (unfold s'; omega). - rewrite Int.shr_sign_ext. auto. unfold s'; omega. unfold s'; omega. + replace s with (s' + Int.unsigned n) by (unfold s'; lia). + rewrite Int.shr_sign_ext. auto. unfold s'; lia. unfold s'; lia. * econstructor; split; [|eauto]. apply eval_shrimm_base; auto. EvalOp. + econstructor; eauto using eval_shrimm_base. - intros; TrivialExists. @@ -399,20 +399,20 @@ Proof. change (Int.ltu (Int.repr 32) Int64.iwordsize') with true; simpl. apply Val.lessdef_same. f_equal. transitivity (Int.repr (Z.shiftr (Int.signed i * Int.signed i0) 32)). - unfold Int.mulhs; f_equal. rewrite Zshiftr_div_two_p by omega. reflexivity. + unfold Int.mulhs; f_equal. rewrite Zshiftr_div_two_p by lia. reflexivity. apply Int.same_bits_eq; intros n N. change Int.zwordsize with 32 in *. - assert (N1: 0 <= n < 64) by omega. + assert (N1: 0 <= n < 64) by lia. rewrite Int64.bits_loword by auto. rewrite Int64.bits_shr' by auto. change (Int.unsigned (Int.repr 32)) with 32. change Int64.zwordsize with 64. - rewrite zlt_true by omega. + rewrite zlt_true by lia. rewrite Int.testbit_repr by auto. - unfold Int64.mul. rewrite Int64.testbit_repr by (change Int64.zwordsize with 64; omega). + unfold Int64.mul. rewrite Int64.testbit_repr by (change Int64.zwordsize with 64; lia). transitivity (Z.testbit (Int.signed i * Int.signed i0) (n + 32)). - rewrite Z.shiftr_spec by omega. auto. + rewrite Z.shiftr_spec by lia. auto. apply Int64.same_bits_eqm. apply Int64.eqm_mult; apply Int64.eqm_unsigned_repr. - change Int64.zwordsize with 64; omega. + change Int64.zwordsize with 64; lia. Qed. Theorem eval_mulhu: binary_constructor_sound mulhu Val.mulhu. @@ -425,20 +425,20 @@ Proof. change (Int.ltu (Int.repr 32) Int64.iwordsize') with true; simpl. apply Val.lessdef_same. f_equal. transitivity (Int.repr (Z.shiftr (Int.unsigned i * Int.unsigned i0) 32)). - unfold Int.mulhu; f_equal. rewrite Zshiftr_div_two_p by omega. reflexivity. + unfold Int.mulhu; f_equal. rewrite Zshiftr_div_two_p by lia. reflexivity. apply Int.same_bits_eq; intros n N. change Int.zwordsize with 32 in *. - assert (N1: 0 <= n < 64) by omega. + assert (N1: 0 <= n < 64) by lia. rewrite Int64.bits_loword by auto. rewrite Int64.bits_shru' by auto. change (Int.unsigned (Int.repr 32)) with 32. change Int64.zwordsize with 64. - rewrite zlt_true by omega. + rewrite zlt_true by lia. rewrite Int.testbit_repr by auto. - unfold Int64.mul. rewrite Int64.testbit_repr by (change Int64.zwordsize with 64; omega). + unfold Int64.mul. rewrite Int64.testbit_repr by (change Int64.zwordsize with 64; lia). transitivity (Z.testbit (Int.unsigned i * Int.unsigned i0) (n + 32)). - rewrite Z.shiftr_spec by omega. auto. + rewrite Z.shiftr_spec by lia. auto. apply Int64.same_bits_eqm. apply Int64.eqm_mult; apply Int64.eqm_unsigned_repr. - change Int64.zwordsize with 64; omega. + change Int64.zwordsize with 64; lia. Qed. (** Integer conversions *) @@ -451,7 +451,7 @@ Proof. - TrivialExists. - destruct (zlt (Int.unsigned a0) sz). + econstructor; split. EvalOp. destruct v1; simpl; auto. rewrite a32_range; simpl. - apply Val.lessdef_same. f_equal. rewrite Int.shl_zero_ext by omega. f_equal. omega. + apply Val.lessdef_same. f_equal. rewrite Int.shl_zero_ext by lia. f_equal. lia. + TrivialExists. - TrivialExists. Qed. @@ -464,29 +464,29 @@ Proof. - TrivialExists. - destruct (zlt (Int.unsigned a0) sz). + econstructor; split. EvalOp. destruct v1; simpl; auto. rewrite a32_range; simpl. - apply Val.lessdef_same. f_equal. rewrite Int.shl_sign_ext by omega. f_equal. omega. + apply Val.lessdef_same. f_equal. rewrite Int.shl_sign_ext by lia. f_equal. lia. + TrivialExists. - TrivialExists. Qed. Theorem eval_cast8signed: unary_constructor_sound cast8signed (Val.sign_ext 8). Proof. - apply eval_sign_ext; omega. + apply eval_sign_ext; lia. Qed. Theorem eval_cast8unsigned: unary_constructor_sound cast8unsigned (Val.zero_ext 8). Proof. - apply eval_zero_ext; omega. + apply eval_zero_ext; lia. Qed. Theorem eval_cast16signed: unary_constructor_sound cast16signed (Val.sign_ext 16). Proof. - apply eval_sign_ext; omega. + apply eval_sign_ext; lia. Qed. Theorem eval_cast16unsigned: unary_constructor_sound cast16unsigned (Val.zero_ext 16). Proof. - apply eval_zero_ext; omega. + apply eval_zero_ext; lia. Qed. (** Bitwise not, and, or, xor *) @@ -1029,7 +1029,13 @@ Theorem eval_addressing: Proof. intros until v. unfold addressing; case (addressing_match a); intros; InvEval. - econstructor; split. EvalOp. simpl; auto. -- econstructor; split. EvalOp. simpl; auto. +- destruct (symbol_is_relocatable id). + + exists (Genv.symbol_address ge id Ptrofs.zero :: nil); split. + constructor. EvalOp. constructor. + simpl. rewrite <- Genv.shift_symbol_address_64 by auto. + rewrite Ptrofs.of_int64_to_int64, Ptrofs.add_zero_l by auto. + auto. + + econstructor; split. EvalOp. simpl; auto. - econstructor; split. EvalOp. simpl. destruct v1; try discriminate. rewrite <- H; auto. - econstructor; split. EvalOp. simpl. congruence. diff --git a/aarch64/Stacklayout.v b/aarch64/Stacklayout.v index 86ba9f45..cdbc64d5 100644 --- a/aarch64/Stacklayout.v +++ b/aarch64/Stacklayout.v @@ -67,13 +67,13 @@ Local Opaque Z.add Z.mul sepconj range. set (ostkdata := align (ol + 4 * b.(bound_local)) 8). change (size_chunk Mptr) with 8. generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros. - assert (0 <= 4 * b.(bound_outgoing)) by omega. - assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; omega). - assert (olink + 8 <= oretaddr) by (unfold oretaddr; omega). - assert (oretaddr + 8 <= ocs) by (unfold ocs; omega). + assert (0 <= 4 * b.(bound_outgoing)) by lia. + assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; lia). + assert (olink + 8 <= oretaddr) by (unfold oretaddr; lia). + assert (oretaddr + 8 <= ocs) by (unfold ocs; lia). assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr). - assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega). - assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega). + assert (size_callee_save_area b ocs <= ol) by (apply align_le; lia). + assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; lia). (* Reorder as: outgoing back link @@ -86,11 +86,11 @@ Local Opaque Z.add Z.mul sepconj range. rewrite sep_swap45. (* Apply range_split and range_split2 repeatedly *) unfold fe_ofs_arg. - apply range_split_2. fold olink; omega. omega. - apply range_split. omega. - apply range_split. omega. - apply range_split_2. fold ol. omega. omega. - apply range_drop_right with ostkdata. omega. + apply range_split_2. fold olink; lia. lia. + apply range_split. lia. + apply range_split. lia. + apply range_split_2. fold ol. lia. lia. + apply range_drop_right with ostkdata. lia. eapply sep_drop2. eexact H. Qed. @@ -106,14 +106,14 @@ Proof. set (ol := align (size_callee_save_area b ocs) 8). set (ostkdata := align (ol + 4 * b.(bound_local)) 8). generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros. - assert (0 <= 4 * b.(bound_outgoing)) by omega. - assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; omega). - assert (olink + 8 <= oretaddr) by (unfold oretaddr; omega). - assert (oretaddr + 8 <= ocs) by (unfold ocs; omega). + assert (0 <= 4 * b.(bound_outgoing)) by lia. + assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; lia). + assert (olink + 8 <= oretaddr) by (unfold oretaddr; lia). + assert (oretaddr + 8 <= ocs) by (unfold ocs; lia). assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr). - assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega). - assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega). - split. omega. apply align_le. omega. + assert (size_callee_save_area b ocs <= ol) by (apply align_le; lia). + assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; lia). + split. lia. apply align_le. lia. Qed. Lemma frame_env_aligned: @@ -133,8 +133,8 @@ Proof. set (ostkdata := align (ol + 4 * b.(bound_local)) 8). change (align_chunk Mptr) with 8. split. apply Z.divide_0_r. - split. apply align_divides; omega. - split. apply align_divides; omega. - split. apply align_divides; omega. - apply Z.divide_add_r. apply align_divides; omega. apply Z.divide_refl. + split. apply align_divides; lia. + split. apply align_divides; lia. + split. apply align_divides; lia. + apply Z.divide_add_r. apply align_divides; lia. apply Z.divide_refl. Qed. diff --git a/aarch64/TargetPrinter.ml b/aarch64/TargetPrinter.ml index 78b9eb2a..a9d47bdd 100644 --- a/aarch64/TargetPrinter.ml +++ b/aarch64/TargetPrinter.ml @@ -36,107 +36,135 @@ let is_immediate_float32 bits = let mant = Int32.logand bits 0x7F_FFFFl in exp >= -3 && exp <= 4 && Int32.logand mant 0x78_0000l = mant -(* Module containing the printing functions *) +(* Naming and printing registers *) + +let intsz oc (sz, n) = + match sz with X -> coqint64 oc n | W -> coqint oc n + +let xreg_name = function + | X0 -> "x0" | X1 -> "x1" | X2 -> "x2" | X3 -> "x3" + | X4 -> "x4" | X5 -> "x5" | X6 -> "x6" | X7 -> "x7" + | X8 -> "x8" | X9 -> "x9" | X10 -> "x10" | X11 -> "x11" + | X12 -> "x12" | X13 -> "x13" | X14 -> "x14" | X15 -> "x15" + | X16 -> "x16" | X17 -> "x17" | X18 -> "x18" | X19 -> "x19" + | X20 -> "x20" | X21 -> "x21" | X22 -> "x22" | X23 -> "x23" + | X24 -> "x24" | X25 -> "x25" | X26 -> "x26" | X27 -> "x27" + | X28 -> "x28" | X29 -> "x29" | X30 -> "x30" + +let wreg_name = function + | X0 -> "w0" | X1 -> "w1" | X2 -> "w2" | X3 -> "w3" + | X4 -> "w4" | X5 -> "w5" | X6 -> "w6" | X7 -> "w7" + | X8 -> "w8" | X9 -> "w9" | X10 -> "w10" | X11 -> "w11" + | X12 -> "w12" | X13 -> "w13" | X14 -> "w14" | X15 -> "w15" + | X16 -> "w16" | X17 -> "w17" | X18 -> "w18" | X19 -> "w19" + | X20 -> "w20" | X21 -> "w21" | X22 -> "w22" | X23 -> "w23" + | X24 -> "w24" | X25 -> "w25" | X26 -> "w26" | X27 -> "w27" + | X28 -> "w28" | X29 -> "w29" | X30 -> "w30" + +let xreg0_name = function RR0 r -> xreg_name r | XZR -> "xzr" +let wreg0_name = function RR0 r -> wreg_name r | XZR -> "wzr" + +let xregsp_name = function RR1 r -> xreg_name r | XSP -> "sp" +let wregsp_name = function RR1 r -> wreg_name r | XSP -> "wsp" + +let dreg_name = function +| D0 -> "d0" | D1 -> "d1" | D2 -> "d2" | D3 -> "d3" +| D4 -> "d4" | D5 -> "d5" | D6 -> "d6" | D7 -> "d7" +| D8 -> "d8" | D9 -> "d9" | D10 -> "d10" | D11 -> "d11" +| D12 -> "d12" | D13 -> "d13" | D14 -> "d14" | D15 -> "d15" +| D16 -> "d16" | D17 -> "d17" | D18 -> "d18" | D19 -> "d19" +| D20 -> "d20" | D21 -> "d21" | D22 -> "d22" | D23 -> "d23" +| D24 -> "d24" | D25 -> "d25" | D26 -> "d26" | D27 -> "d27" +| D28 -> "d28" | D29 -> "d29" | D30 -> "d30" | D31 -> "d31" + +let sreg_name = function +| D0 -> "s0" | D1 -> "s1" | D2 -> "s2" | D3 -> "s3" +| D4 -> "s4" | D5 -> "s5" | D6 -> "s6" | D7 -> "s7" +| D8 -> "s8" | D9 -> "s9" | D10 -> "s10" | D11 -> "s11" +| D12 -> "s12" | D13 -> "s13" | D14 -> "s14" | D15 -> "s15" +| D16 -> "s16" | D17 -> "s17" | D18 -> "s18" | D19 -> "s19" +| D20 -> "s20" | D21 -> "s21" | D22 -> "s22" | D23 -> "s23" +| D24 -> "s24" | D25 -> "s25" | D26 -> "s26" | D27 -> "s27" +| D28 -> "s28" | D29 -> "s29" | D30 -> "s30" | D31 -> "s31" + +let xreg oc r = output_string oc (xreg_name r) +let wreg oc r = output_string oc (wreg_name r) +let ireg oc (sz, r) = + output_string oc (match sz with X -> xreg_name r | W -> wreg_name r) + +let xreg0 oc r = output_string oc (xreg0_name r) +let wreg0 oc r = output_string oc (wreg0_name r) +let ireg0 oc (sz, r) = + output_string oc (match sz with X -> xreg0_name r | W -> wreg0_name r) + +let xregsp oc r = output_string oc (xregsp_name r) +let iregsp oc (sz, r) = + output_string oc (match sz with X -> xregsp_name r | W -> wregsp_name r) + +let dreg oc r = output_string oc (dreg_name r) +let sreg oc r = output_string oc (sreg_name r) +let freg oc (sz, r) = + output_string oc (match sz with D -> dreg_name r | S -> sreg_name r) + +let preg_asm oc ty = function + | IR r -> if ty = Tint then wreg oc r else xreg oc r + | FR r -> if ty = Tsingle then sreg oc r else dreg oc r + | _ -> assert false + +let preg_annot = function + | IR r -> xreg_name r + | FR r -> dreg_name r + | _ -> assert false + +(* Base-2 log of a Caml integer *) +let rec log2 n = + assert (n > 0); + if n = 1 then 0 else 1 + log2 (n lsr 1) + +(* System dependent printer functions *) + +module type SYSTEM = + sig + val comment: string + val raw_symbol: out_channel -> string -> unit + val symbol: out_channel -> P.t -> unit + val symbol_offset_high: out_channel -> P.t * Z.t -> unit + val symbol_offset_low: out_channel -> P.t * Z.t -> unit + val label: out_channel -> int -> unit + val label_high: out_channel -> int -> unit + val label_low: out_channel -> int -> unit + val load_symbol_address: out_channel -> ireg -> P.t -> unit + val name_of_section: section_name -> string + val print_fun_info: out_channel -> P.t -> unit + val print_var_info: out_channel -> P.t -> unit + val print_comm_decl: out_channel -> P.t -> Z.t -> int -> unit + val print_lcomm_decl: out_channel -> P.t -> Z.t -> int -> unit + end -module Target : TARGET = +module ELF_System : SYSTEM = struct - -(* Basic printing functions *) - let comment = "//" + let raw_symbol = output_string + let symbol = elf_symbol + let symbol_offset_high = elf_symbol_offset + let symbol_offset_low oc id_ofs = + fprintf oc "#:lo12:%a" elf_symbol_offset id_ofs - let symbol = elf_symbol - let symbol_offset = elf_symbol_offset - let label = elf_label + let label = elf_label + let label_high = elf_label + let label_low oc lbl = + fprintf oc "#:lo12:%a" elf_label lbl - let print_label oc lbl = label oc (transl_label lbl) - - let intsz oc (sz, n) = - match sz with X -> coqint64 oc n | W -> coqint oc n - - let xreg_name = function - | X0 -> "x0" | X1 -> "x1" | X2 -> "x2" | X3 -> "x3" - | X4 -> "x4" | X5 -> "x5" | X6 -> "x6" | X7 -> "x7" - | X8 -> "x8" | X9 -> "x9" | X10 -> "x10" | X11 -> "x11" - | X12 -> "x12" | X13 -> "x13" | X14 -> "x14" | X15 -> "x15" - | X16 -> "x16" | X17 -> "x17" | X18 -> "x18" | X19 -> "x19" - | X20 -> "x20" | X21 -> "x21" | X22 -> "x22" | X23 -> "x23" - | X24 -> "x24" | X25 -> "x25" | X26 -> "x26" | X27 -> "x27" - | X28 -> "x28" | X29 -> "x29" | X30 -> "x30" - - let wreg_name = function - | X0 -> "w0" | X1 -> "w1" | X2 -> "w2" | X3 -> "w3" - | X4 -> "w4" | X5 -> "w5" | X6 -> "w6" | X7 -> "w7" - | X8 -> "w8" | X9 -> "w9" | X10 -> "w10" | X11 -> "w11" - | X12 -> "w12" | X13 -> "w13" | X14 -> "w14" | X15 -> "w15" - | X16 -> "w16" | X17 -> "w17" | X18 -> "w18" | X19 -> "w19" - | X20 -> "w20" | X21 -> "w21" | X22 -> "w22" | X23 -> "w23" - | X24 -> "w24" | X25 -> "w25" | X26 -> "w26" | X27 -> "w27" - | X28 -> "w28" | X29 -> "w29" | X30 -> "w30" - - let xreg0_name = function RR0 r -> xreg_name r | XZR -> "xzr" - let wreg0_name = function RR0 r -> wreg_name r | XZR -> "wzr" - - let xregsp_name = function RR1 r -> xreg_name r | XSP -> "sp" - let wregsp_name = function RR1 r -> wreg_name r | XSP -> "wsp" - - let dreg_name = function - | D0 -> "d0" | D1 -> "d1" | D2 -> "d2" | D3 -> "d3" - | D4 -> "d4" | D5 -> "d5" | D6 -> "d6" | D7 -> "d7" - | D8 -> "d8" | D9 -> "d9" | D10 -> "d10" | D11 -> "d11" - | D12 -> "d12" | D13 -> "d13" | D14 -> "d14" | D15 -> "d15" - | D16 -> "d16" | D17 -> "d17" | D18 -> "d18" | D19 -> "d19" - | D20 -> "d20" | D21 -> "d21" | D22 -> "d22" | D23 -> "d23" - | D24 -> "d24" | D25 -> "d25" | D26 -> "d26" | D27 -> "d27" - | D28 -> "d28" | D29 -> "d29" | D30 -> "d30" | D31 -> "d31" - - let sreg_name = function - | D0 -> "s0" | D1 -> "s1" | D2 -> "s2" | D3 -> "s3" - | D4 -> "s4" | D5 -> "s5" | D6 -> "s6" | D7 -> "s7" - | D8 -> "s8" | D9 -> "s9" | D10 -> "s10" | D11 -> "s11" - | D12 -> "s12" | D13 -> "s13" | D14 -> "s14" | D15 -> "s15" - | D16 -> "s16" | D17 -> "s17" | D18 -> "s18" | D19 -> "s19" - | D20 -> "s20" | D21 -> "s21" | D22 -> "s22" | D23 -> "s23" - | D24 -> "s24" | D25 -> "s25" | D26 -> "s26" | D27 -> "s27" - | D28 -> "s28" | D29 -> "s29" | D30 -> "s30" | D31 -> "s31" - - let xreg oc r = output_string oc (xreg_name r) - let wreg oc r = output_string oc (wreg_name r) - let ireg oc (sz, r) = - output_string oc (match sz with X -> xreg_name r | W -> wreg_name r) - - let xreg0 oc r = output_string oc (xreg0_name r) - let wreg0 oc r = output_string oc (wreg0_name r) - let ireg0 oc (sz, r) = - output_string oc (match sz with X -> xreg0_name r | W -> wreg0_name r) - - let xregsp oc r = output_string oc (xregsp_name r) - let iregsp oc (sz, r) = - output_string oc (match sz with X -> xregsp_name r | W -> wregsp_name r) - - let dreg oc r = output_string oc (dreg_name r) - let sreg oc r = output_string oc (sreg_name r) - let freg oc (sz, r) = - output_string oc (match sz with D -> dreg_name r | S -> sreg_name r) - - let preg_asm oc ty = function - | IR r -> if ty = Tint then wreg oc r else xreg oc r - | FR r -> if ty = Tsingle then sreg oc r else dreg oc r - | _ -> assert false - - let preg_annot = function - | IR r -> xreg_name r - | FR r -> dreg_name r - | _ -> assert false - -(* Names of sections *) + let load_symbol_address oc rd id = + fprintf oc " adrp %a, :got:%a\n" xreg rd symbol id; + fprintf oc " ldr %a, [%a, #:got_lo12:%a]\n" xreg rd xreg rd symbol id let name_of_section = function | Section_text -> ".text" | Section_data i | Section_small_data i -> - if i then ".data" else common_section () + variable_section ~sec:".data" ~bss:".bss" i | Section_const i | Section_small_const i -> - if i || (not !Clflags.option_fcommon) then ".section .rodata" else "COMM" + variable_section ~sec:".section .rodata" i | Section_string -> ".section .rodata" | Section_literal -> ".section .rodata" | Section_jumptable -> ".section .rodata" @@ -151,6 +179,94 @@ module Target : TARGET = s (if wr then "w" else "") (if ex then "x" else "") | Section_ais_annotation -> sprintf ".section \"__compcert_ais_annotations\",\"\",@note" + let print_fun_info = elf_print_fun_info + let print_var_info = elf_print_var_info + + let print_comm_decl oc name sz al = + fprintf oc " .comm %a, %s, %d\n" symbol name (Z.to_string sz) al + + let print_lcomm_decl oc name sz al = + fprintf oc " .local %a\n" symbol name; + print_comm_decl oc name sz al + + end + +module MacOS_System : SYSTEM = + struct + let comment = ";" + + let raw_symbol oc s = + fprintf oc "_%s" s + + let symbol oc symb = + raw_symbol oc (extern_atom symb) + + let symbol_offset_gen kind oc (id, ofs) = + fprintf oc "%a@%s" symbol id kind; + let ofs = camlint64_of_ptrofs ofs in + if ofs <> 0L then fprintf oc " + %Ld" ofs + + let symbol_offset_high = symbol_offset_gen "PAGE" + let symbol_offset_low = symbol_offset_gen "PAGEOFF" + + let label oc lbl = + fprintf oc "L%d" lbl + + let label_high oc lbl = + fprintf oc "%a@PAGE" label lbl + let label_low oc lbl = + fprintf oc "%a@PAGEOFF" label lbl + + let load_symbol_address oc rd id = + fprintf oc " adrp %a, %a@GOTPAGE\n" xreg rd symbol id; + fprintf oc " ldr %a, [%a, %a@GOTPAGEOFF]\n" xreg rd xreg rd symbol id + + let name_of_section = function + | Section_text -> ".text" + | Section_data i | Section_small_data i -> + variable_section ~sec:".data" i + | Section_const i | Section_small_const i -> + variable_section ~sec:".const" ~reloc:".const_data" i + | Section_string -> ".const" + | Section_literal -> ".const" + | Section_jumptable -> ".text" + | Section_user(s, wr, ex) -> + sprintf ".section \"%s\", %s, %s" + (if wr then "__DATA" else "__TEXT") s + (if ex then "regular, pure_instructions" else "regular") + | Section_debug_info _ -> ".section __DWARF,__debug_info,regular,debug" + | Section_debug_loc -> ".section __DWARF,__debug_loc,regular,debug" + | Section_debug_line _ -> ".section __DWARF,__debug_line,regular,debug" + | Section_debug_str -> ".section __DWARF,__debug_str,regular,debug" + | Section_debug_ranges -> ".section __DWARF,__debug_ranges,regular,debug" + | Section_debug_abbrev -> ".section __DWARF,__debug_abbrev,regular,debug" + | Section_ais_annotation -> assert false (* Not supported under MacOS *) + + let print_fun_info _ _ = () + let print_var_info _ _ = () + + let print_comm_decl oc name sz al = + fprintf oc " .comm %a, %s, %d\n" + symbol name (Z.to_string sz) (log2 al) + + let print_lcomm_decl oc name sz al = + fprintf oc " .lcomm %a, %s, %d\n" + symbol name (Z.to_string sz) (log2 al) + + end + +(* Module containing the printing functions *) + +module Target(System: SYSTEM): TARGET = + struct + include System + +(* Basic printing functions *) + + let print_label oc lbl = label oc (transl_label lbl) + +(* Names of sections *) + let section oc sec = fprintf oc " %s\n" (name_of_section sec) @@ -206,7 +322,7 @@ module Target : TARGET = | ADlsl(base, r, n) -> fprintf oc "[%a, %a, lsl #%a]" xregsp base xreg r coqint n | ADsxt(base, r, n) -> fprintf oc "[%a, %a, sxtw #%a]" xregsp base wreg r coqint n | ADuxt(base, r, n) -> fprintf oc "[%a, %a, uxtw #%a]" xregsp base wreg r coqint n - | ADadr(base, id, ofs) -> fprintf oc "[%a, #:lo12:%a]" xregsp base symbol_offset (id, ofs) + | ADadr(base, id, ofs) -> fprintf oc "[%a, %a]" xregsp base symbol_offset_low (id, ofs) | ADpostincr(base, n) -> fprintf oc "[%a], #%a" xregsp base coqint64 n (* Print a shifted operand *) @@ -217,15 +333,15 @@ module Target : TARGET = | SOasr n -> fprintf oc ", asr #%a" coqint n | SOror n -> fprintf oc ", ror #%a" coqint n -(* Print a sign- or zero-extended operand *) - let extendop oc = function - | EOsxtb n -> fprintf oc ", sxtb #%a" coqint n - | EOsxth n -> fprintf oc ", sxth #%a" coqint n - | EOsxtw n -> fprintf oc ", sxtw #%a" coqint n - | EOuxtb n -> fprintf oc ", uxtb #%a" coqint n - | EOuxth n -> fprintf oc ", uxth #%a" coqint n - | EOuxtw n -> fprintf oc ", uxtw #%a" coqint n - | EOuxtx n -> fprintf oc ", uxtx #%a" coqint n +(* Print a sign- or zero-extended register operand *) + let regextend oc = function + | (r, EOsxtb n) -> fprintf oc "%a, sxtb #%a" wreg r coqint n + | (r, EOsxth n) -> fprintf oc "%a, sxth #%a" wreg r coqint n + | (r, EOsxtw n) -> fprintf oc "%a, sxtw #%a" wreg r coqint n + | (r, EOuxtb n) -> fprintf oc "%a, uxtb #%a" wreg r coqint n + | (r, EOuxth n) -> fprintf oc "%a, uxth #%a" wreg r coqint n + | (r, EOuxtw n) -> fprintf oc "%a, uxtw #%a" wreg r coqint n + | (r, EOuxtx n) -> fprintf oc "%a, uxtx #%a" xreg r coqint n (* Printing of instructions *) let print_instruction oc = function @@ -312,9 +428,9 @@ module Target : TARGET = fprintf oc " movk %a, #%d, lsl #%d\n" ireg (sz, rd) (Z.to_int n) (Z.to_int pos) (* PC-relative addressing *) | Padrp(rd, id, ofs) -> - fprintf oc " adrp %a, %a\n" xreg rd symbol_offset (id, ofs) + fprintf oc " adrp %a, %a\n" xreg rd symbol_offset_high (id, ofs) | Paddadr(rd, r1, id, ofs) -> - fprintf oc " add %a, %a, #:lo12:%a\n" xreg rd xreg r1 symbol_offset (id, ofs) + fprintf oc " add %a, %a, %a\n" xreg rd xreg r1 symbol_offset_low (id, ofs) (* Bit-field operations *) | Psbfiz(sz, rd, r1, r, s) -> fprintf oc " sbfiz %a, %a, %a, %d\n" ireg (sz, rd) ireg (sz, r1) coqint r (Z.to_int s) @@ -335,13 +451,13 @@ module Target : TARGET = fprintf oc " cmn %a, %a%a\n" ireg0 (sz, r1) ireg (sz, r2) shiftop s (* Integer arithmetic, extending register *) | Paddext(rd, r1, r2, x) -> - fprintf oc " add %a, %a, %a%a\n" xregsp rd xregsp r1 wreg r2 extendop x + fprintf oc " add %a, %a, %a\n" xregsp rd xregsp r1 regextend (r2, x) | Psubext(rd, r1, r2, x) -> - fprintf oc " sub %a, %a, %a%a\n" xregsp rd xregsp r1 wreg r2 extendop x + fprintf oc " sub %a, %a, %a\n" xregsp rd xregsp r1 regextend (r2, x) | Pcmpext(r1, r2, x) -> - fprintf oc " cmp %a, %a%a\n" xreg r1 wreg r2 extendop x + fprintf oc " cmp %a, %a\n" xreg r1 regextend (r2, x) | Pcmnext(r1, r2, x) -> - fprintf oc " cmn %a, %a%a\n" xreg r1 wreg r2 extendop x + fprintf oc " cmn %a, %a\n" xreg r1 regextend (r2, x) (* Logical, shifted register *) | Pand(sz, rd, r1, r2, s) -> fprintf oc " and %a, %a, %a%a\n" ireg (sz, rd) ireg0 (sz, r1) ireg (sz, r2) shiftop s @@ -413,8 +529,8 @@ module Target : TARGET = fprintf oc " fmov %a, #%.7f\n" dreg rd (Int64.float_of_bits d) else begin let lbl = label_literal64 d in - fprintf oc " adrp x16, %a\n" label lbl; - fprintf oc " ldr %a, [x16, #:lo12:%a] %s %.18g\n" dreg rd label lbl comment (Int64.float_of_bits d) + fprintf oc " adrp x16, %a\n" label_high lbl; + fprintf oc " ldr %a, [x16, %a] %s %.18g\n" dreg rd label_low lbl comment (Int64.float_of_bits d) end | Pfmovimms(rd, f) -> let d = camlint_of_coqint (Floats.Float32.to_bits f) in @@ -422,8 +538,8 @@ module Target : TARGET = fprintf oc " fmov %a, #%.7f\n" sreg rd (Int32.float_of_bits d) else begin let lbl = label_literal32 d in - fprintf oc " adrp x16, %a\n" label lbl; - fprintf oc " ldr %a, [x16, #:lo12:%a] %s %.18g\n" sreg rd label lbl comment (Int32.float_of_bits d) + fprintf oc " adrp x16, %a\n" label_high lbl; + fprintf oc " ldr %a, [x16, %a] %s %.18g\n" sreg rd label_low lbl comment (Int32.float_of_bits d) end | Pfmovi(D, rd, r1) -> fprintf oc " fmov %a, %a\n" dreg rd xreg0 r1 @@ -490,8 +606,7 @@ module Target : TARGET = | Plabel lbl -> fprintf oc "%a:\n" print_label lbl | Ploadsymbol(rd, id) -> - fprintf oc " adrp %a, :got:%a\n" xreg rd symbol id; - fprintf oc " ldr %a, [%a, #:got_lo12:%a]\n" xreg rd xreg rd symbol id + load_symbol_address oc rd id | Pcvtsw2x(rd, r1) -> fprintf oc " sxtw %a, %a\n" xreg rd wreg r1 | Pcvtuw2x(rd, r1) -> @@ -554,19 +669,12 @@ module Target : TARGET = jumptables := [] end - let print_fun_info = elf_print_fun_info - let print_optional_fun_info _ = () - let print_var_info = elf_print_var_info - let print_comm_symb oc sz name align = - if C2C.atom_is_static name then - fprintf oc " .local %a\n" symbol name; - fprintf oc " .comm %a, %s, %d\n" - symbol name - (Z.to_string sz) - align + if C2C.atom_is_static name + then print_lcomm_decl oc name sz align + else print_comm_decl oc name sz align let print_instructions oc fn = current_function_sig := fn.fn_sig; @@ -587,7 +695,7 @@ module Target : TARGET = section oc Section_text; end - let default_falignment = 2 + let default_falignment = 4 let cfi_startproc oc = () let cfi_endproc oc = () @@ -595,4 +703,10 @@ module Target : TARGET = end let sel_target () = - (module Target:TARGET) + let module S = + (val (match Configuration.system with + | "linux" -> (module ELF_System : SYSTEM) + | "macos" -> (module MacOS_System : SYSTEM) + | _ -> invalid_arg ("System " ^ Configuration.system ^ " not supported")) + : SYSTEM) in + (module Target(S) : TARGET) diff --git a/aarch64/extractionMachdep.v b/aarch64/extractionMachdep.v index 5f26dc28..ae0006bc 100644 --- a/aarch64/extractionMachdep.v +++ b/aarch64/extractionMachdep.v @@ -6,22 +6,37 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) (* Additional extraction directives specific to the AArch64 port *) -Require Archi Asm. +Require Archi Asm Asmgen SelectOp. (* Archi *) -Extract Constant Archi.pic_code => "fun () -> false". (* for the time being *) +Extract Constant Archi.abi => + "match Configuration.abi with + | ""apple"" -> Apple + | _ -> AAPCS64". + +(* SelectOp *) + +Extract Constant SelectOp.symbol_is_relocatable => + "match Configuration.system with + | ""macos"" -> C2C.atom_is_extern + | _ -> (fun _ -> false)". (* Asm *) + Extract Constant Asm.symbol_low => "fun _ _ _ -> assert false". Extract Constant Asm.symbol_high => "fun _ _ _ -> assert false". + +(* Asmgen *) + Extract Constant Asmgen.symbol_is_aligned => "C2C.atom_is_aligned". diff --git a/arm/Archi.v b/arm/Archi.v index 2ca79710..c4cb5496 100644 --- a/arm/Archi.v +++ b/arm/Archi.v @@ -7,10 +7,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -696,7 +696,7 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pfsubd r1 r2 r3 => Next (nextinstr (rs#r1 <- (Val.subf rs#r2 rs#r3))) m | Pflid r1 f => - Next (nextinstr (rs#r1 <- (Vfloat f))) m + Next (nextinstr (rs#IR14 <- Vundef #r1 <- (Vfloat f))) m | Pfcmpd r1 r2 => Next (nextinstr (compare_float rs rs#r1 rs#r2)) m | Pfcmpzd r1 => @@ -923,7 +923,7 @@ Inductive step: state -> trace -> state -> Prop := external_call ef ge vargs m t vres m' -> rs' = nextinstr (set_res res vres - (undef_regs (map preg_of (destroyed_by_builtin ef)) rs)) -> + (undef_regs (IR IR14 :: map preg_of (destroyed_by_builtin ef)) rs)) -> step (State rs m) t (State rs' m') | exec_step_external: forall b ef args res rs m t rs' m', @@ -1004,7 +1004,7 @@ Ltac Equalities := split. auto. intros. destruct B; auto. subst. auto. (* trace length *) red; intros; inv H; simpl. - omega. + lia. inv H3; eapply external_call_trace_length; eauto. eapply external_call_trace_length; eauto. (* initial states *) diff --git a/arm/Asmexpand.ml b/arm/Asmexpand.ml index f4e79a37..01b18c37 100644 --- a/arm/Asmexpand.ml +++ b/arm/Asmexpand.ml @@ -407,8 +407,12 @@ let expand_builtin_inline name args res = (* Vararg stuff *) | "__builtin_va_start", [BA(IR a)], _ -> expand_builtin_va_start a + (* No operation *) | "__builtin_nop", [], _ -> emit Pnop + (* Optimization hint *) + | "__builtin_unreachable", [], _ -> + () (* Catch-all *) | _ -> raise (Error ("unrecognized builtin " ^ name)) @@ -545,7 +549,7 @@ module FixupHF = struct end let fixup_arguments dir sg = - if sg.sig_cc.cc_vararg then + if sg.sig_cc.cc_vararg <> None then FixupEABI.fixup_arguments dir sg else begin let act = fixup_actions (Array.make 16 false) 0 sg.sig_args in @@ -555,7 +559,7 @@ module FixupHF = struct end let fixup_result dir sg = - if sg.sig_cc.cc_vararg then + if sg.sig_cc.cc_vararg <> None then FixupEABI.fixup_result dir sg end diff --git a/arm/Asmgenproof.v b/arm/Asmgenproof.v index a592e12a..93e0c6c2 100644 --- a/arm/Asmgenproof.v +++ b/arm/Asmgenproof.v @@ -68,7 +68,7 @@ Lemma transf_function_no_overflow: forall f tf, transf_function f = OK tf -> list_length_z (fn_code tf) <= Ptrofs.max_unsigned. Proof. - intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z (fn_code x))); inv EQ0. omega. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z (fn_code x))); inv EQ0. lia. Qed. Lemma exec_straight_exec: @@ -122,13 +122,13 @@ Proof. case (is_label lbl a). intro EQ; injection EQ; intro; subst c'. exists (pos + 1). split. auto. split. - replace (pos + 1 - pos) with (0 + 1) by omega. constructor. constructor. - rewrite list_length_z_cons. generalize (list_length_z_pos c). omega. + replace (pos + 1 - pos) with (0 + 1) by lia. constructor. constructor. + rewrite list_length_z_cons. generalize (list_length_z_pos c). lia. intros. generalize (IHc (pos + 1) c' H). intros [pos' [A [B C]]]. exists pos'. split. auto. split. - replace (pos' - pos) with ((pos' - (pos + 1)) + 1) by omega. + replace (pos' - pos) with ((pos' - (pos + 1)) + 1) by lia. constructor. auto. - rewrite list_length_z_cons. omega. + rewrite list_length_z_cons. lia. Qed. (** The following lemmas show that the translation from Mach to ARM @@ -378,8 +378,8 @@ Proof. split. unfold goto_label. rewrite P. rewrite H1. auto. split. rewrite Pregmap.gss. constructor; auto. rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. - auto. omega. - generalize (transf_function_no_overflow _ _ H0). omega. + auto. lia. + generalize (transf_function_no_overflow _ _ H0). lia. intros. apply Pregmap.gso; auto. Qed. @@ -754,13 +754,15 @@ Opaque loadind. econstructor; eauto. instantiate (2 := tf); instantiate (1 := x). unfold nextinstr. rewrite Pregmap.gss. - rewrite set_res_other. rewrite undef_regs_other_2. + rewrite set_res_other. simpl. rewrite undef_regs_other_2. + rewrite Pregmap.gso by auto with asmgen. rewrite <- H1. simpl. econstructor; eauto. eapply code_tail_next_int; eauto. rewrite preg_notin_charact. intros. auto with asmgen. auto with asmgen. apply agree_nextinstr. eapply agree_set_res; auto. - eapply agree_undef_regs; eauto. intros; apply undef_regs_other_2; auto. + eapply agree_undef_regs; eauto. + intros. simpl. rewrite undef_regs_other_2; auto. apply Pregmap.gso. auto with asmgen. congruence. - (* Mgoto *) @@ -901,11 +903,11 @@ Opaque loadind. simpl; reflexivity. reflexivity. } (* After the function prologue is the code for the function body *) - exploit exec_straight_steps_2; eauto using functions_transl. omega. constructor. + exploit exec_straight_steps_2; eauto using functions_transl. lia. constructor. intros (ofsbody & U & V). (* Conclusions *) left; exists (State rs4 m3'); split. - eapply exec_straight_steps_1; eauto. omega. constructor. + eapply exec_straight_steps_1; eauto. lia. constructor. econstructor; eauto. rewrite U. econstructor; eauto. apply agree_nextinstr. apply agree_undef_regs2 with rs2. @@ -932,7 +934,7 @@ Opaque loadind. - (* return *) inv STACKS. simpl in *. - right. split. omega. split. auto. + right. split. lia. split. auto. rewrite <- ATPC in H5. econstructor; eauto. congruence. Qed. diff --git a/arm/Asmgenproof1.v b/arm/Asmgenproof1.v index 807e069d..6f0482dc 100644 --- a/arm/Asmgenproof1.v +++ b/arm/Asmgenproof1.v @@ -40,14 +40,14 @@ Lemma ireg_of_not_R14: Proof. intros. erewrite <- ireg_of_eq; eauto with asmgen. Qed. -Hint Resolve ireg_of_not_R14: asmgen. +Global Hint Resolve ireg_of_not_R14: asmgen. Lemma ireg_of_not_R14': forall m r, ireg_of m = OK r -> r <> IR14. Proof. intros. generalize (ireg_of_not_R14 _ _ H). congruence. Qed. -Hint Resolve ireg_of_not_R14': asmgen. +Global Hint Resolve ireg_of_not_R14': asmgen. (** [undef_flags] and [nextinstr_nf] *) @@ -75,7 +75,7 @@ Proof. intros; red; intros; subst; discriminate. Qed. -Hint Resolve data_if_preg if_preg_not_PC: asmgen. +Global Hint Resolve data_if_preg if_preg_not_PC: asmgen. Lemma nextinstr_nf_inv: forall r rs, if_preg r = true -> (nextinstr_nf rs)#r = rs#r. @@ -352,15 +352,15 @@ Proof. apply exec_straight_one. simpl; eauto. auto. split; intros; Simpl. econstructor; split. eapply exec_straight_two. simpl; reflexivity. simpl; reflexivity. auto. auto. - split; intros; Simpl. simpl. f_equal. rewrite Int.zero_ext_and by omega. + split; intros; Simpl. simpl. f_equal. rewrite Int.zero_ext_and by lia. rewrite Int.and_assoc. change 65535 with (two_p 16 - 1). rewrite Int.and_idem. apply Int.same_bits_eq; intros. rewrite Int.bits_or, Int.bits_and, Int.bits_shl, Int.testbit_repr by auto. - rewrite Ztestbit_two_p_m1 by omega. change (Int.unsigned (Int.repr 16)) with 16. + rewrite Ztestbit_two_p_m1 by lia. change (Int.unsigned (Int.repr 16)) with 16. destruct (zlt i 16). rewrite andb_true_r, orb_false_r; auto. - rewrite andb_false_r; simpl. rewrite Int.bits_shru by omega. - change (Int.unsigned (Int.repr 16)) with 16. rewrite zlt_true by omega. f_equal; omega. + rewrite andb_false_r; simpl. rewrite Int.bits_shru by lia. + change (Int.unsigned (Int.repr 16)) with 16. rewrite zlt_true by lia. f_equal; lia. } destruct (Nat.leb l1 l2). { (* mov - orr* *) @@ -696,10 +696,10 @@ Lemma int_not_lt: Proof. intros. unfold Int.lt. rewrite int_signed_eq. unfold proj_sumbool. destruct (zlt (Int.signed y) (Int.signed x)). - rewrite zlt_false. rewrite zeq_false. auto. omega. omega. + rewrite zlt_false. rewrite zeq_false. auto. lia. lia. destruct (zeq (Int.signed x) (Int.signed y)). - rewrite zlt_false. auto. omega. - rewrite zlt_true. auto. omega. + rewrite zlt_false. auto. lia. + rewrite zlt_true. auto. lia. Qed. Lemma int_lt_not: @@ -713,10 +713,10 @@ Lemma int_not_ltu: Proof. intros. unfold Int.ltu, Int.eq. destruct (zlt (Int.unsigned y) (Int.unsigned x)). - rewrite zlt_false. rewrite zeq_false. auto. omega. omega. + rewrite zlt_false. rewrite zeq_false. auto. lia. lia. destruct (zeq (Int.unsigned x) (Int.unsigned y)). - rewrite zlt_false. auto. omega. - rewrite zlt_true. auto. omega. + rewrite zlt_false. auto. lia. + rewrite zlt_true. auto. lia. Qed. Lemma int_ltu_not: @@ -1218,7 +1218,7 @@ Proof. split. unfold rs2; Simpl. unfold rs1; Simpl. unfold Val.shr, Val.shl; destruct (rs x0); auto. change (Int.ltu (Int.repr 24) Int.iwordsize) with true; simpl. - f_equal. symmetry. apply (Int.sign_ext_shr_shl 8). compute; auto. + f_equal. symmetry. apply (Int.sign_ext_shr_shl 8). compute; intuition congruence. intros. unfold rs2, rs1; Simpl. (* Ocast16signed *) destruct Archi.thumb2_support. @@ -1231,7 +1231,7 @@ Proof. split. unfold rs2; Simpl. unfold rs1; Simpl. unfold Val.shr, Val.shl; destruct (rs x0); auto. change (Int.ltu (Int.repr 16) Int.iwordsize) with true; simpl. - f_equal. symmetry. apply (Int.sign_ext_shr_shl 16). compute; auto. + f_equal. symmetry. apply (Int.sign_ext_shr_shl 16). compute; intuition congruence. intros. unfold rs2, rs1; Simpl. (* Oaddimm *) generalize (addimm_correct x x0 i k rs m). @@ -1279,16 +1279,16 @@ Local Transparent destroyed_by_op. rewrite Int.unsigned_repr. apply zlt_true. assert (Int.unsigned i <> 0). { red; intros; elim H. rewrite <- (Int.repr_unsigned i). rewrite H1; reflexivity. } - omega. + lia. change (Int.unsigned (Int.repr 31)) with (Int.zwordsize - 1) in H0. - generalize Int.wordsize_max_unsigned; omega. + generalize Int.wordsize_max_unsigned; lia. } assert (LTU'': Int.ltu i Int.iwordsize = true). { generalize (Int.ltu_inv _ _ LTU). intros. unfold Int.ltu. rewrite Int.unsigned_repr_wordsize. apply zlt_true. change (Int.unsigned (Int.repr 31)) with (Int.zwordsize - 1) in H0. - omega. + lia. } set (j := Int.sub Int.iwordsize i) in *. set (rs1 := nextinstr_nf (rs#IR14 <- (Val.shr (Vint i0) (Vint (Int.repr 31))))). diff --git a/arm/Builtins1.v b/arm/Builtins1.v index 53c83d7e..cd6f8cc4 100644 --- a/arm/Builtins1.v +++ b/arm/Builtins1.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/arm/CBuiltins.ml b/arm/CBuiltins.ml index 6462a8c5..ed21b78f 100644 --- a/arm/CBuiltins.ml +++ b/arm/CBuiltins.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/arm/ConstpropOpproof.v b/arm/ConstpropOpproof.v index a4f5c29c..cd0afb7a 100644 --- a/arm/ConstpropOpproof.v +++ b/arm/ConstpropOpproof.v @@ -451,7 +451,7 @@ Proof. Int.bit_solve. destruct (zlt i0 n0). replace (Int.testbit n i0) with (negb (Int.testbit Int.zero i0)). rewrite Int.bits_zero. simpl. rewrite andb_true_r. auto. - rewrite <- EQ. rewrite Int.bits_zero_ext by omega. rewrite zlt_true by auto. + rewrite <- EQ. rewrite Int.bits_zero_ext by lia. rewrite zlt_true by auto. rewrite Int.bits_not by auto. apply negb_involutive. rewrite H6 by auto. auto. econstructor; split; eauto. auto. diff --git a/arm/Conventions1.v b/arm/Conventions1.v index fe49a781..0ddd882f 100644 --- a/arm/Conventions1.v +++ b/arm/Conventions1.v @@ -309,7 +309,7 @@ Remark loc_arguments_hf_charact: In p (loc_arguments_hf tyl ir fr ofs) -> forall_rpair (loc_argument_charact ofs) p. Proof. assert (X: forall ofs1 ofs2 l, loc_argument_charact ofs2 l -> ofs1 <= ofs2 -> loc_argument_charact ofs1 l). - { destruct l; simpl; intros; auto. destruct sl; auto. intuition omega. } + { destruct l; simpl; intros; auto. destruct sl; auto. intuition lia. } assert (Y: forall ofs1 ofs2 p, forall_rpair (loc_argument_charact ofs2) p -> ofs1 <= ofs2 -> forall_rpair (loc_argument_charact ofs1) p). { destruct p; simpl; intuition eauto. } induction tyl; simpl loc_arguments_hf; intros. @@ -319,40 +319,40 @@ Proof. destruct (zlt ir 4); destruct H. subst. apply ireg_param_caller_save. eapply IHtyl; eauto. - subst. split; [omega | auto]. - eapply Y; eauto. omega. + subst. split; [lia | auto]. + eapply Y; eauto. lia. - (* float *) destruct (zlt fr 8); destruct H. subst. apply freg_param_caller_save. eapply IHtyl; eauto. - subst. split. apply Z.le_ge. apply align_le. omega. auto. - eapply Y; eauto. apply Z.le_trans with (align ofs 2). apply align_le; omega. omega. + subst. split. apply Z.le_ge. apply align_le. lia. auto. + eapply Y; eauto. apply Z.le_trans with (align ofs 2). apply align_le; lia. lia. - (* long *) set (ir' := align ir 2) in *. - assert (ofs <= align ofs 2) by (apply align_le; omega). + assert (ofs <= align ofs 2) by (apply align_le; lia). destruct (zlt ir' 4). destruct H. subst p. split; apply ireg_param_caller_save. eapply IHtyl; eauto. - destruct H. subst p. split; destruct Archi.big_endian; (split; [ omega | auto ]). - eapply Y. eapply IHtyl; eauto. omega. + destruct H. subst p. split; destruct Archi.big_endian; (split; [ lia | auto ]). + eapply Y. eapply IHtyl; eauto. lia. - (* single *) destruct (zlt fr 8); destruct H. subst. apply freg_param_caller_save. eapply IHtyl; eauto. - subst. split; [omega|auto]. - eapply Y; eauto. omega. + subst. split; [lia|auto]. + eapply Y; eauto. lia. - (* any32 *) destruct (zlt ir 4); destruct H. subst. apply ireg_param_caller_save. eapply IHtyl; eauto. - subst. split; [omega | auto]. - eapply Y; eauto. omega. + subst. split; [lia | auto]. + eapply Y; eauto. lia. - (* any64 *) destruct (zlt fr 8); destruct H. subst. apply freg_param_caller_save. eapply IHtyl; eauto. - subst. split. apply Z.le_ge. apply align_le. omega. auto. - eapply Y; eauto. apply Z.le_trans with (align ofs 2). apply align_le; omega. omega. + subst. split. apply Z.le_ge. apply align_le. lia. auto. + eapply Y; eauto. apply Z.le_trans with (align ofs 2). apply align_le; lia. lia. Qed. Remark loc_arguments_sf_charact: @@ -360,7 +360,7 @@ Remark loc_arguments_sf_charact: In p (loc_arguments_sf tyl ofs) -> forall_rpair (loc_argument_charact (Z.max 0 ofs)) p. Proof. assert (X: forall ofs1 ofs2 l, loc_argument_charact (Z.max 0 ofs2) l -> ofs1 <= ofs2 -> loc_argument_charact (Z.max 0 ofs1) l). - { destruct l; simpl; intros; auto. destruct sl; auto. intuition xomega. } + { destruct l; simpl; intros; auto. destruct sl; auto. intuition extlia. } assert (Y: forall ofs1 ofs2 p, forall_rpair (loc_argument_charact (Z.max 0 ofs2)) p -> ofs1 <= ofs2 -> forall_rpair (loc_argument_charact (Z.max 0 ofs1)) p). { destruct p; simpl; intuition eauto. } induction tyl; simpl loc_arguments_sf; intros. @@ -370,44 +370,44 @@ Proof. destruct H. destruct (zlt ofs 0); subst p. apply ireg_param_caller_save. - split; [xomega|auto]. - eapply Y; eauto. omega. + split; [extlia|auto]. + eapply Y; eauto. lia. - (* float *) set (ofs' := align ofs 2) in *. - assert (ofs <= ofs') by (apply align_le; omega). + assert (ofs <= ofs') by (apply align_le; lia). destruct H. destruct (zlt ofs' 0); subst p. apply freg_param_caller_save. - split; [xomega|auto]. - eapply Y. eapply IHtyl; eauto. omega. + split; [extlia|auto]. + eapply Y. eapply IHtyl; eauto. lia. - (* long *) set (ofs' := align ofs 2) in *. - assert (ofs <= ofs') by (apply align_le; omega). + assert (ofs <= ofs') by (apply align_le; lia). destruct H. destruct (zlt ofs' 0); subst p. split; apply ireg_param_caller_save. - split; destruct Archi.big_endian; (split; [xomega|auto]). - eapply Y. eapply IHtyl; eauto. omega. + split; destruct Archi.big_endian; (split; [extlia|auto]). + eapply Y. eapply IHtyl; eauto. lia. - (* single *) destruct H. destruct (zlt ofs 0); subst p. apply freg_param_caller_save. - split; [xomega|auto]. - eapply Y; eauto. omega. + split; [extlia|auto]. + eapply Y; eauto. lia. - (* any32 *) destruct H. destruct (zlt ofs 0); subst p. apply ireg_param_caller_save. - split; [xomega|auto]. - eapply Y; eauto. omega. + split; [extlia|auto]. + eapply Y; eauto. lia. - (* any64 *) set (ofs' := align ofs 2) in *. - assert (ofs <= ofs') by (apply align_le; omega). + assert (ofs <= ofs') by (apply align_le; lia). destruct H. destruct (zlt ofs' 0); subst p. apply freg_param_caller_save. - split; [xomega|auto]. - eapply Y. eapply IHtyl; eauto. omega. + split; [extlia|auto]. + eapply Y. eapply IHtyl; eauto. lia. Qed. Lemma loc_arguments_acceptable: @@ -427,7 +427,7 @@ Proof. destruct Archi.abi; [ | destruct (cc_vararg (sig_cc s)) ]; auto. Qed. -Hint Resolve loc_arguments_acceptable: locs. +Global Hint Resolve loc_arguments_acceptable: locs. Lemma loc_arguments_main: loc_arguments signature_main = nil. @@ -436,8 +436,9 @@ Proof. destruct Archi.abi; reflexivity. Qed. -(** ** Normalization of function results *) +(** ** Normalization of function results and parameters *) (** No normalization needed. *) Definition return_value_needs_normalization (t: rettype) := false. +Definition parameter_needs_normalization (t: rettype) := false. diff --git a/arm/NeedOp.v b/arm/NeedOp.v index c70c7e40..23e8f047 100644 --- a/arm/NeedOp.v +++ b/arm/NeedOp.v @@ -198,8 +198,8 @@ Lemma operation_is_redundant_sound: vagree v arg1' nv. Proof. intros. destruct op; simpl in *; try discriminate; inv H1; FuncInv; subst. -- apply sign_ext_redundant_sound; auto. omega. -- apply sign_ext_redundant_sound; auto. omega. +- apply sign_ext_redundant_sound; auto. lia. +- apply sign_ext_redundant_sound; auto. lia. - apply andimm_redundant_sound; auto. - apply orimm_redundant_sound; auto. Qed. @@ -527,10 +527,10 @@ End SOUNDNESS. Program Definition mk_shift_amount (n: int) : shift_amount := {| s_amount := Int.modu n Int.iwordsize; s_range := _ |}. Next Obligation. - assert (0 <= Z.modulo (Int.unsigned n) 32 < 32). apply Z_mod_lt. omega. + assert (0 <= Z.modulo (Int.unsigned n) 32 < 32). apply Z_mod_lt. lia. unfold Int.ltu, Int.modu. change (Int.unsigned Int.iwordsize) with 32. - rewrite Int.unsigned_repr. apply zlt_true. omega. - assert (32 < Int.max_unsigned). compute; auto. omega. + rewrite Int.unsigned_repr. apply zlt_true. lia. + assert (32 < Int.max_unsigned). compute; auto. lia. Qed. Lemma mk_shift_amount_eq: diff --git a/arm/SelectOpproof.v b/arm/SelectOpproof.v index 70f8f191..bd9f01b1 100644 --- a/arm/SelectOpproof.v +++ b/arm/SelectOpproof.v @@ -754,7 +754,7 @@ Qed. Theorem eval_cast8unsigned: unary_constructor_sound cast8unsigned (Val.zero_ext 8). Proof. red; intros until x. unfold cast8unsigned. - rewrite Val.zero_ext_and. apply eval_andimm. omega. + rewrite Val.zero_ext_and. apply eval_andimm. lia. Qed. Theorem eval_cast16signed: unary_constructor_sound cast16signed (Val.sign_ext 16). @@ -767,7 +767,7 @@ Qed. Theorem eval_cast16unsigned: unary_constructor_sound cast16unsigned (Val.zero_ext 16). Proof. red; intros until x. unfold cast8unsigned. - rewrite Val.zero_ext_and. apply eval_andimm. omega. + rewrite Val.zero_ext_and. apply eval_andimm. lia. Qed. Theorem eval_singleoffloat: unary_constructor_sound singleoffloat Val.singleoffloat. diff --git a/arm/Stacklayout.v b/arm/Stacklayout.v index 462d83ad..f6e01e0c 100644 --- a/arm/Stacklayout.v +++ b/arm/Stacklayout.v @@ -72,12 +72,12 @@ Local Opaque Z.add Z.mul sepconj range. set (ocs := ol + 4 * b.(bound_local)); set (ostkdata := align (size_callee_save_area b ocs) 8). generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros. - assert (0 <= olink) by (unfold olink; omega). - assert (olink <= ora) by (unfold ora; omega). - assert (ora + 4 <= ol) by (apply align_le; omega). - assert (ol + 4 * b.(bound_local) <= ocs) by (unfold ocs; omega). + assert (0 <= olink) by (unfold olink; lia). + assert (olink <= ora) by (unfold ora; lia). + assert (ora + 4 <= ol) by (apply align_le; lia). + assert (ol + 4 * b.(bound_local) <= ocs) by (unfold ocs; lia). assert (ocs <= size_callee_save_area b ocs) by apply size_callee_save_area_incr. - assert (size_callee_save_area b ocs <= ostkdata) by (apply align_le; omega). + assert (size_callee_save_area b ocs <= ostkdata) by (apply align_le; lia). (* Reorder as: outgoing back link @@ -89,11 +89,11 @@ Local Opaque Z.add Z.mul sepconj range. rewrite sep_swap34. (* Apply range_split and range_split2 repeatedly *) unfold fe_ofs_arg. - apply range_split. omega. - apply range_split. omega. - apply range_split_2. fold ol; omega. omega. - apply range_split. omega. - apply range_drop_right with ostkdata. omega. + apply range_split. lia. + apply range_split. lia. + apply range_split_2. fold ol; lia. lia. + apply range_split. lia. + apply range_drop_right with ostkdata. lia. eapply sep_drop2. eexact H. Qed. @@ -109,13 +109,13 @@ Proof. set (ocs := ol + 4 * b.(bound_local)); set (ostkdata := align (size_callee_save_area b ocs) 8). generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros. - assert (0 <= olink) by (unfold olink; omega). - assert (olink <= ora) by (unfold ora; omega). - assert (ora + 4 <= ol) by (apply align_le; omega). - assert (ol + 4 * b.(bound_local) <= ocs) by (unfold ocs; omega). + assert (0 <= olink) by (unfold olink; lia). + assert (olink <= ora) by (unfold ora; lia). + assert (ora + 4 <= ol) by (apply align_le; lia). + assert (ol + 4 * b.(bound_local) <= ocs) by (unfold ocs; lia). assert (ocs <= size_callee_save_area b ocs) by apply size_callee_save_area_incr. - assert (size_callee_save_area b ocs <= ostkdata) by (apply align_le; omega). - split. omega. apply align_le; omega. + assert (size_callee_save_area b ocs <= ostkdata) by (apply align_le; lia). + split. lia. apply align_le; lia. Qed. Lemma frame_env_aligned: @@ -134,7 +134,7 @@ Proof. set (ocs := ol + 4 * b.(bound_local)); set (ostkdata := align (size_callee_save_area b ocs) 8). split. apply Z.divide_0_r. - split. apply align_divides; omega. - split. apply align_divides; omega. + split. apply align_divides; lia. + split. apply align_divides; lia. unfold ora, olink; auto using Z.divide_mul_l, Z.divide_add_r, Z.divide_refl. Qed. diff --git a/arm/TargetPrinter.ml b/arm/TargetPrinter.ml index 03e06a65..43dac44a 100644 --- a/arm/TargetPrinter.ml +++ b/arm/TargetPrinter.ml @@ -148,9 +148,9 @@ struct let name_of_section = function | Section_text -> ".text" | Section_data i | Section_small_data i -> - if i then ".data" else common_section () + variable_section ~sec:".data" ~bss:".bss" i | Section_const i | Section_small_const i -> - if i || (not !Clflags.option_fcommon) then ".section .rodata" else "COMM" + variable_section ~sec:".section .rodata" i | Section_string -> ".section .rodata" | Section_literal -> ".text" | Section_jumptable -> ".text" diff --git a/arm/extractionMachdep.v b/arm/extractionMachdep.v index a82cf749..5fee431c 100644 --- a/arm/extractionMachdep.v +++ b/arm/extractionMachdep.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/backend/Allocproof.v b/backend/Allocproof.v index 51755912..3fdbacbe 100644 --- a/backend/Allocproof.v +++ b/backend/Allocproof.v @@ -548,7 +548,7 @@ Proof. unfold select_reg_l; intros. destruct H. red in H. congruence. rewrite Pos.leb_le in *. red in H. destruct H as [A | [A B]]. - red in A. zify; omega. + red in A. zify; lia. rewrite <- A; auto. Qed. @@ -560,7 +560,7 @@ Proof. unfold select_reg_h; intros. destruct H. red in H. congruence. rewrite Pos.leb_le in *. red in H. destruct H as [A | [A B]]. - red in A. zify; omega. + red in A. zify; lia. rewrite A; auto. Qed. @@ -568,7 +568,7 @@ Remark select_reg_charact: forall r q, select_reg_l r q = true /\ select_reg_h r q = true <-> ereg q = r. Proof. unfold select_reg_l, select_reg_h; intros; split. - rewrite ! Pos.leb_le. unfold reg; zify; omega. + rewrite ! Pos.leb_le. unfold reg; zify; lia. intros. rewrite H. rewrite ! Pos.leb_refl; auto. Qed. diff --git a/backend/Asmexpandaux.ml b/backend/Asmexpandaux.ml index 0530abe4..f7feb303 100644 --- a/backend/Asmexpandaux.ml +++ b/backend/Asmexpandaux.ml @@ -54,7 +54,7 @@ let get_current_function_args () = (!current_function).fn_sig.sig_args let is_current_function_variadic () = - (!current_function).fn_sig.sig_cc.cc_vararg + (!current_function).fn_sig.sig_cc.cc_vararg <> None let get_current_function_sig () = (!current_function).fn_sig diff --git a/backend/Asmgenproof0.v b/backend/Asmgenproof0.v index 3638c465..85cee14f 100644 --- a/backend/Asmgenproof0.v +++ b/backend/Asmgenproof0.v @@ -31,7 +31,7 @@ Require Import Conventions. (** * Processor registers and register states *) -Hint Extern 2 (_ <> _) => congruence: asmgen. +Global Hint Extern 2 (_ <> _) => congruence: asmgen. Lemma ireg_of_eq: forall r r', ireg_of r = OK r' -> preg_of r = IR r'. @@ -56,7 +56,7 @@ Lemma preg_of_data: Proof. intros. destruct r; reflexivity. Qed. -Hint Resolve preg_of_data: asmgen. +Global Hint Resolve preg_of_data: asmgen. Lemma data_diff: forall r r', @@ -64,7 +64,7 @@ Lemma data_diff: Proof. congruence. Qed. -Hint Resolve data_diff: asmgen. +Global Hint Resolve data_diff: asmgen. Lemma preg_of_not_SP: forall r, preg_of r <> SP. @@ -78,7 +78,7 @@ Proof. intros. apply data_diff; auto with asmgen. Qed. -Hint Resolve preg_of_not_SP preg_of_not_PC: asmgen. +Global Hint Resolve preg_of_not_SP preg_of_not_PC: asmgen. Lemma nextinstr_pc: forall rs, (nextinstr rs)#PC = Val.offset_ptr rs#PC Ptrofs.one. @@ -473,7 +473,7 @@ Inductive code_tail: Z -> code -> code -> Prop := Lemma code_tail_pos: forall pos c1 c2, code_tail pos c1 c2 -> pos >= 0. Proof. - induction 1. omega. omega. + induction 1. lia. lia. Qed. Lemma find_instr_tail: @@ -484,8 +484,8 @@ Proof. induction c1; simpl; intros. inv H. destruct (zeq pos 0). subst pos. - inv H. auto. generalize (code_tail_pos _ _ _ H4). intro. omegaContradiction. - inv H. congruence. replace (pos0 + 1 - 1) with pos0 by omega. + inv H. auto. generalize (code_tail_pos _ _ _ H4). intro. extlia. + inv H. congruence. replace (pos0 + 1 - 1) with pos0 by lia. eauto. Qed. @@ -494,8 +494,8 @@ Remark code_tail_bounds_1: code_tail ofs fn c -> 0 <= ofs <= list_length_z fn. Proof. induction 1; intros; simpl. - generalize (list_length_z_pos c). omega. - rewrite list_length_z_cons. omega. + generalize (list_length_z_pos c). lia. + rewrite list_length_z_cons. lia. Qed. Remark code_tail_bounds_2: @@ -505,8 +505,8 @@ Proof. assert (forall ofs fn c, code_tail ofs fn c -> forall i c', c = i :: c' -> 0 <= ofs < list_length_z fn). induction 1; intros; simpl. - rewrite H. rewrite list_length_z_cons. generalize (list_length_z_pos c'). omega. - rewrite list_length_z_cons. generalize (IHcode_tail _ _ H0). omega. + rewrite H. rewrite list_length_z_cons. generalize (list_length_z_pos c'). lia. + rewrite list_length_z_cons. generalize (IHcode_tail _ _ H0). lia. eauto. Qed. @@ -531,7 +531,7 @@ Lemma code_tail_next_int: Proof. intros. rewrite Ptrofs.add_unsigned, Ptrofs.unsigned_one. rewrite Ptrofs.unsigned_repr. apply code_tail_next with i; auto. - generalize (code_tail_bounds_2 _ _ _ _ H0). omega. + generalize (code_tail_bounds_2 _ _ _ _ H0). lia. Qed. (** [transl_code_at_pc pc fb f c ep tf tc] holds if the code pointer [pc] points @@ -654,7 +654,7 @@ Opaque transl_instr. exists (Ptrofs.repr ofs). red; intros. rewrite Ptrofs.unsigned_repr. congruence. exploit code_tail_bounds_1; eauto. - apply transf_function_len in TF. omega. + apply transf_function_len in TF. lia. + exists Ptrofs.zero; red; intros. congruence. Qed. @@ -663,7 +663,7 @@ End RETADDR_EXISTS. Remark code_tail_no_bigger: forall pos c1 c2, code_tail pos c1 c2 -> (length c2 <= length c1)%nat. Proof. - induction 1; simpl; omega. + induction 1; simpl; lia. Qed. Remark code_tail_unique: @@ -671,8 +671,8 @@ Remark code_tail_unique: code_tail pos fn c -> code_tail pos' fn c -> pos = pos'. Proof. induction fn; intros until pos'; intros ITA CT; inv ITA; inv CT; auto. - generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. - generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. + generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; lia. + generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; lia. f_equal. eauto. Qed. @@ -713,13 +713,13 @@ Proof. case (is_label lbl a). intro EQ; injection EQ; intro; subst c'. exists (pos + 1). split. auto. split. - replace (pos + 1 - pos) with (0 + 1) by omega. constructor. constructor. - rewrite list_length_z_cons. generalize (list_length_z_pos c). omega. + replace (pos + 1 - pos) with (0 + 1) by lia. constructor. constructor. + rewrite list_length_z_cons. generalize (list_length_z_pos c). lia. intros. generalize (IHc (pos + 1) c' H). intros [pos' [A [B C]]]. exists pos'. split. auto. split. - replace (pos' - pos) with ((pos' - (pos + 1)) + 1) by omega. + replace (pos' - pos) with ((pos' - (pos + 1)) + 1) by lia. constructor. auto. - rewrite list_length_z_cons. omega. + rewrite list_length_z_cons. lia. Qed. (** Helper lemmas to reason about @@ -746,7 +746,7 @@ Qed. Definition nolabel (i: instruction) := match i with Plabel _ => False | _ => True end. -Hint Extern 1 (nolabel _) => exact I : labels. +Global Hint Extern 1 (nolabel _) => exact I : labels. Lemma tail_nolabel_cons: forall i c k, @@ -757,7 +757,7 @@ Proof. intros. simpl. rewrite <- H1. destruct i; reflexivity || contradiction. Qed. -Hint Resolve tail_nolabel_refl: labels. +Global Hint Resolve tail_nolabel_refl: labels. Ltac TailNoLabel := eauto with labels; diff --git a/backend/Bounds.v b/backend/Bounds.v index fa695234..4231d861 100644 --- a/backend/Bounds.v +++ b/backend/Bounds.v @@ -163,7 +163,7 @@ Proof. intros until valu. unfold max_over_list. assert (forall l z, fold_left (fun x y => Z.max x (valu y)) l z >= z). induction l; simpl; intros. - omega. apply Zge_trans with (Z.max z (valu a)). + lia. apply Zge_trans with (Z.max z (valu a)). auto. apply Z.le_ge. apply Z.le_max_l. auto. Qed. @@ -307,7 +307,7 @@ Proof. let f := fold_left (fun x y => Z.max x (valu y)) c z in z <= f /\ (In x c -> valu x <= f)). induction c; simpl; intros. - split. omega. tauto. + split. lia. tauto. elim (IHc (Z.max z (valu a))); intros. split. apply Z.le_trans with (Z.max z (valu a)). apply Z.le_max_l. auto. intro H1; elim H1; intro. @@ -446,12 +446,12 @@ Lemma size_callee_save_area_rec_incr: Proof. Local Opaque mreg_type. induction l as [ | r l]; intros; simpl. -- omega. +- lia. - eapply Z.le_trans. 2: apply IHl. generalize (AST.typesize_pos (mreg_type r)); intros. apply Z.le_trans with (align ofs (AST.typesize (mreg_type r))). apply align_le; auto. - omega. + lia. Qed. Lemma size_callee_save_area_incr: diff --git a/backend/CSEdomain.v b/backend/CSEdomain.v index 9b1243c8..e96c4cd4 100644 --- a/backend/CSEdomain.v +++ b/backend/CSEdomain.v @@ -92,7 +92,7 @@ Record wf_numbering (n: numbering) : Prop := { In r (PMap.get v n.(num_val)) -> PTree.get r n.(num_reg) = Some v }. -Hint Resolve wf_num_eqs wf_num_reg wf_num_val: cse. +Global Hint Resolve wf_num_eqs wf_num_reg wf_num_val: cse. (** Satisfiability of numberings. A numbering holds in a concrete execution state if there exists a valuation assigning values to @@ -130,7 +130,7 @@ Record numbering_holds (valu: valuation) (ge: genv) (sp: val) n.(num_reg)!r = Some v -> rs#r = valu v }. -Hint Resolve num_holds_wf num_holds_eq num_holds_reg: cse. +Global Hint Resolve num_holds_wf num_holds_eq num_holds_reg: cse. Lemma empty_numbering_holds: forall valu ge sp rs m, diff --git a/backend/CSEproof.v b/backend/CSEproof.v index 03c7ecfc..a2a1b461 100644 --- a/backend/CSEproof.v +++ b/backend/CSEproof.v @@ -128,9 +128,9 @@ Proof. exists valu2; splitall. + constructor; simpl; intros. * constructor; simpl; intros. - apply wf_equation_incr with (num_next n). eauto with cse. xomega. + apply wf_equation_incr with (num_next n). eauto with cse. extlia. rewrite PTree.gsspec in H0. destruct (peq r0 r). - inv H0; xomega. + inv H0; extlia. apply Plt_trans_succ; eauto with cse. rewrite PMap.gsspec in H0. destruct (peq v (num_next n)). replace r0 with r by (simpl in H0; intuition). rewrite PTree.gss. subst; auto. @@ -142,8 +142,8 @@ Proof. rewrite peq_false. eauto with cse. apply Plt_ne; eauto with cse. + unfold valu2. rewrite peq_true; auto. + auto. -+ xomega. -+ xomega. ++ extlia. ++ extlia. Qed. Lemma valnum_regs_holds: @@ -158,7 +158,7 @@ Lemma valnum_regs_holds: /\ Ple n.(num_next) n'.(num_next). Proof. induction rl; simpl; intros. -- inv H0. exists valu1; splitall; auto. red; auto. simpl; tauto. xomega. +- inv H0. exists valu1; splitall; auto. red; auto. simpl; tauto. extlia. - destruct (valnum_reg n a) as [n1 v1] eqn:V1. destruct (valnum_regs n1 rl) as [n2 vs] eqn:V2. inv H0. @@ -169,9 +169,9 @@ Proof. exists valu3; splitall. + auto. + simpl; f_equal; auto. rewrite R; auto. - + red; intros. transitivity (valu2 v); auto. apply R. xomega. - + simpl; intros. destruct H0; auto. subst v1; xomega. - + xomega. + + red; intros. transitivity (valu2 v); auto. apply R. extlia. + + simpl; intros. destruct H0; auto. subst v1; extlia. + + extlia. Qed. Lemma find_valnum_rhs_charact: @@ -327,11 +327,11 @@ Proof. { red; intros. unfold valu2. apply peq_false. apply Plt_ne; auto. } exists valu2; constructor; simpl; intros. + constructor; simpl; intros. - * destruct H3. inv H3. simpl; split. xomega. + * destruct H3. inv H3. simpl; split. extlia. red; intros. apply Plt_trans_succ; eauto. - apply wf_equation_incr with (num_next n). eauto with cse. xomega. + apply wf_equation_incr with (num_next n). eauto with cse. extlia. * rewrite PTree.gsspec in H3. destruct (peq r rd). - inv H3. xomega. + inv H3. extlia. apply Plt_trans_succ; eauto with cse. * apply update_reg_charact; eauto with cse. + destruct H3. inv H3. @@ -495,10 +495,10 @@ Lemma store_normalized_range_sound: Proof. intros. unfold Val.load_result; remember Archi.ptr64 as ptr64. destruct chunk; simpl in *; destruct v; auto. -- inv H. rewrite is_sgn_sign_ext in H4 by omega. rewrite H4; auto. -- inv H. rewrite is_uns_zero_ext in H4 by omega. rewrite H4; auto. -- inv H. rewrite is_sgn_sign_ext in H4 by omega. rewrite H4; auto. -- inv H. rewrite is_uns_zero_ext in H4 by omega. rewrite H4; auto. +- inv H. rewrite is_sgn_sign_ext in H4 by lia. rewrite H4; auto. +- inv H. rewrite is_uns_zero_ext in H4 by lia. rewrite H4; auto. +- inv H. rewrite is_sgn_sign_ext in H4 by lia. rewrite H4; auto. +- inv H. rewrite is_uns_zero_ext in H4 by lia. rewrite H4; auto. - destruct ptr64; auto. - destruct ptr64; auto. - destruct ptr64; auto. @@ -557,7 +557,7 @@ Proof. simpl. rewrite negb_false_iff in H8. eapply Mem.load_storebytes_other. eauto. - rewrite H6. rewrite Z2Nat.id by omega. + rewrite H6. rewrite Z2Nat.id by lia. eapply pdisjoint_sound. eauto. unfold aaddressing. apply match_aptr_of_aval. eapply eval_static_addressing_sound; eauto. erewrite <- regs_valnums_sound by eauto. eauto with va. @@ -578,39 +578,39 @@ Proof. set (n1 := i - ofs1). set (n2 := size_chunk chunk). set (n3 := sz - (n1 + n2)). - replace sz with (n1 + (n2 + n3)) in H by (unfold n3, n2, n1; omega). + replace sz with (n1 + (n2 + n3)) in H by (unfold n3, n2, n1; lia). exploit Mem.loadbytes_split; eauto. - unfold n1; omega. - unfold n3, n2, n1; omega. + unfold n1; lia. + unfold n3, n2, n1; lia. intros (bytes1 & bytes23 & LB1 & LB23 & EQ). clear H. exploit Mem.loadbytes_split; eauto. - unfold n2; omega. - unfold n3, n2, n1; omega. + unfold n2; lia. + unfold n3, n2, n1; lia. intros (bytes2 & bytes3 & LB2 & LB3 & EQ'). subst bytes23; subst bytes. exploit Mem.load_loadbytes; eauto. intros (bytes2' & A & B). assert (bytes2' = bytes2). - { replace (ofs1 + n1) with i in LB2 by (unfold n1; omega). unfold n2 in LB2. congruence. } + { replace (ofs1 + n1) with i in LB2 by (unfold n1; lia). unfold n2 in LB2. congruence. } subst bytes2'. exploit Mem.storebytes_split; eauto. intros (m1 & SB1 & SB23). clear H0. exploit Mem.storebytes_split; eauto. intros (m2 & SB2 & SB3). clear SB23. assert (L1: Z.of_nat (length bytes1) = n1). - { erewrite Mem.loadbytes_length by eauto. apply Z2Nat.id. unfold n1; omega. } + { erewrite Mem.loadbytes_length by eauto. apply Z2Nat.id. unfold n1; lia. } assert (L2: Z.of_nat (length bytes2) = n2). - { erewrite Mem.loadbytes_length by eauto. apply Z2Nat.id. unfold n2; omega. } + { erewrite Mem.loadbytes_length by eauto. apply Z2Nat.id. unfold n2; lia. } rewrite L1 in *. rewrite L2 in *. assert (LB': Mem.loadbytes m2 b2 (ofs2 + n1) n2 = Some bytes2). { rewrite <- L2. eapply Mem.loadbytes_storebytes_same; eauto. } assert (LB'': Mem.loadbytes m' b2 (ofs2 + n1) n2 = Some bytes2). { rewrite <- LB'. eapply Mem.loadbytes_storebytes_other; eauto. - unfold n2; omega. - right; left; omega. } + unfold n2; lia. + right; left; lia. } exploit Mem.load_valid_access; eauto. intros [P Q]. rewrite B. apply Mem.loadbytes_load. - replace (i + (ofs2 - ofs1)) with (ofs2 + n1) by (unfold n1; omega). + replace (i + (ofs2 - ofs1)) with (ofs2 + n1) by (unfold n1; lia). exact LB''. apply Z.divide_add_r; auto. Qed. @@ -655,9 +655,9 @@ Proof with (try discriminate). Mem.loadv chunk m (Vptr sp ofs) = Some v -> Mem.loadv chunk m' (Vptr sp (Ptrofs.repr j)) = Some v). { - simpl; intros. rewrite Ptrofs.unsigned_repr by omega. + simpl; intros. rewrite Ptrofs.unsigned_repr by lia. unfold j, delta. eapply load_memcpy; eauto. - apply Zmod_divide; auto. generalize (align_chunk_pos chunk); omega. + apply Zmod_divide; auto. generalize (align_chunk_pos chunk); lia. } inv H2. + inv H3. exploit eval_addressing_Ainstack_inv; eauto. intros [E1 E2]. diff --git a/backend/CleanupLabelsproof.v b/backend/CleanupLabelsproof.v index e92be2b4..fb8e57b7 100644 --- a/backend/CleanupLabelsproof.v +++ b/backend/CleanupLabelsproof.v @@ -286,7 +286,7 @@ Proof. constructor. econstructor; eauto with coqlib. (* eliminated *) - right. split. simpl. omega. split. auto. econstructor; eauto with coqlib. + right. split. simpl. lia. split. auto. econstructor; eauto with coqlib. (* Lgoto *) left; econstructor; split. econstructor. eapply find_label_translated; eauto. red; auto. diff --git a/backend/Cminor.v b/backend/Cminor.v index 91a4c104..1618866e 100644 --- a/backend/Cminor.v +++ b/backend/Cminor.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -588,7 +589,7 @@ Proof. exploit external_call_receptive; eauto. intros [vres2 [m2 EC2]]. exists (Returnstate vres2 k m2). econstructor; eauto. (* trace length *) - red; intros; inv H; simpl; try omega; eapply external_call_trace_length; eauto. + red; intros; inv H; simpl; try lia; eapply external_call_trace_length; eauto. Qed. (** This semantics is determinate. *) @@ -645,7 +646,7 @@ Proof. intros (A & B). split; intros; auto. apply B in H; destruct H; congruence. - (* single event *) - red; simpl. destruct 1; simpl; try omega; + red; simpl. destruct 1; simpl; try lia; eapply external_call_trace_length; eauto. - (* initial states *) inv H; inv H0. unfold ge0, ge1 in *. congruence. diff --git a/backend/CminorSel.v b/backend/CminorSel.v index 96cb8ae6..f6f6e34d 100644 --- a/backend/CminorSel.v +++ b/backend/CminorSel.v @@ -464,7 +464,7 @@ Inductive final_state: state -> int -> Prop := Definition semantics (p: program) := Semantics step (initial_state p) final_state (Genv.globalenv p). -Hint Constructors eval_expr eval_exprlist eval_condexpr: evalexpr. +Global Hint Constructors eval_expr eval_exprlist eval_condexpr: evalexpr. (** * Lifting of let-bound variables *) @@ -522,9 +522,9 @@ Lemma insert_lenv_lookup1: nth_error le' n = Some v. Proof. induction 1; intros. - omegaContradiction. + extlia. destruct n; simpl; simpl in H0. auto. - apply IHinsert_lenv. auto. omega. + apply IHinsert_lenv. auto. lia. Qed. Lemma insert_lenv_lookup2: @@ -536,8 +536,8 @@ Lemma insert_lenv_lookup2: Proof. induction 1; intros. simpl. assumption. - simpl. destruct n. omegaContradiction. - apply IHinsert_lenv. exact H0. omega. + simpl. destruct n. extlia. + apply IHinsert_lenv. exact H0. lia. Qed. Lemma eval_lift_expr: @@ -580,4 +580,4 @@ Proof. eexact H. apply insert_lenv_0. Qed. -Hint Resolve eval_lift: evalexpr. +Global Hint Resolve eval_lift: evalexpr. diff --git a/backend/Cminortyping.v b/backend/Cminortyping.v index 92ec45f2..9f35fe35 100644 --- a/backend/Cminortyping.v +++ b/backend/Cminortyping.v @@ -290,7 +290,7 @@ Lemma expect_incr: forall te e t1 t2 e', Proof. unfold expect; intros. destruct (typ_eq t1 t2); inv H; auto. Qed. -Hint Resolve expect_incr: ty. +Global Hint Resolve expect_incr: ty. Lemma expect_sound: forall e t1 t2 e', expect e t1 t2 = OK e' -> t1 = t2. @@ -305,7 +305,7 @@ Proof. - destruct (type_unop u) as [targ1 tres]; monadInv T; eauto with ty. - destruct (type_binop b) as [[targ1 targ2] tres]; monadInv T; eauto with ty. Qed. -Hint Resolve type_expr_incr: ty. +Global Hint Resolve type_expr_incr: ty. Lemma type_expr_sound: forall te a t e e', type_expr e a t = OK e' -> S.satisf te e' -> wt_expr te a t. @@ -325,7 +325,7 @@ Lemma type_exprlist_incr: forall te al tl e e', Proof. induction al; destruct tl; simpl; intros until e'; intros T SAT; monadInv T; eauto with ty. Qed. -Hint Resolve type_exprlist_incr: ty. +Global Hint Resolve type_exprlist_incr: ty. Lemma type_exprlist_sound: forall te al tl e e', type_exprlist e al tl = OK e' -> S.satisf te e' -> list_forall2 (wt_expr te) al tl. @@ -342,7 +342,7 @@ Proof. - destruct (type_unop u) as [targ1 tres]; monadInv T; eauto with ty. - destruct (type_binop b) as [[targ1 targ2] tres]; monadInv T; eauto with ty. Qed. -Hint Resolve type_assign_incr: ty. +Global Hint Resolve type_assign_incr: ty. Lemma type_assign_sound: forall te id a e e', type_assign e id a = OK e' -> S.satisf te e' -> wt_expr te a (te id). @@ -362,7 +362,7 @@ Lemma opt_set_incr: forall te optid optty e e', Proof. unfold opt_set; intros. destruct optid, optty; try (monadInv H); eauto with ty. Qed. -Hint Resolve opt_set_incr: ty. +Global Hint Resolve opt_set_incr: ty. Lemma opt_set_sound: forall te optid sg e e', opt_set e optid (proj_sig_res sg) = OK e' -> S.satisf te e' -> @@ -379,7 +379,7 @@ Proof. induction s; simpl; intros e1 e2 T SAT; try (monadInv T); eauto with ty. - destruct tret, o; try (monadInv T); eauto with ty. Qed. -Hint Resolve type_stmt_incr: ty. +Global Hint Resolve type_stmt_incr: ty. Lemma type_stmt_sound: forall te tret s e e', type_stmt tret e s = OK e' -> S.satisf te e' -> wt_stmt te tret s. diff --git a/backend/Constpropproof.v b/backend/Constpropproof.v index a5d08a0f..a3592c4d 100644 --- a/backend/Constpropproof.v +++ b/backend/Constpropproof.v @@ -364,7 +364,7 @@ Proof. - (* Inop, skipped over *) assert (s0 = pc') by congruence. subst s0. - right; exists n; split. omega. split. auto. + right; exists n; split. lia. split. auto. apply match_states_intro; auto. - (* Iop *) @@ -528,7 +528,7 @@ Opaque builtin_strength_reduction. - (* Icond, skipped over *) rewrite H1 in H; inv H. - right; exists n; split. omega. split. auto. + right; exists n; split. lia. split. auto. econstructor; eauto. - (* Ijumptable *) diff --git a/backend/Conventions.v b/backend/Conventions.v index 14ffb587..8910ee49 100644 --- a/backend/Conventions.v +++ b/backend/Conventions.v @@ -60,9 +60,9 @@ Remark fold_max_outgoing_above: forall l n, fold_left max_outgoing_2 l n >= n. Proof. assert (A: forall n l, max_outgoing_1 n l >= n). - { intros; unfold max_outgoing_1. destruct l as [_ | []]; xomega. } + { intros; unfold max_outgoing_1. destruct l as [_ | []]; extlia. } induction l; simpl; intros. - - omega. + - lia. - eapply Zge_trans. eauto. destruct a; simpl. apply A. eapply Zge_trans; eauto. Qed. @@ -80,14 +80,14 @@ Lemma loc_arguments_bounded: Proof. intros until ty. assert (A: forall n l, n <= max_outgoing_1 n l). - { intros; unfold max_outgoing_1. destruct l as [_ | []]; xomega. } + { intros; unfold max_outgoing_1. destruct l as [_ | []]; extlia. } assert (B: forall p n, In (S Outgoing ofs ty) (regs_of_rpair p) -> ofs + typesize ty <= max_outgoing_2 n p). { intros. destruct p; simpl in H; intuition; subst; simpl. - - xomega. - - eapply Z.le_trans. 2: apply A. xomega. - - xomega. } + - extlia. + - eapply Z.le_trans. 2: apply A. extlia. + - extlia. } assert (C: forall l n, In (S Outgoing ofs ty) (regs_of_rpairs l) -> ofs + typesize ty <= fold_left max_outgoing_2 l n). @@ -168,7 +168,7 @@ Proof. unfold loc_argument_acceptable. destruct l; intros. auto. destruct sl; try contradiction. destruct H1. generalize (loc_arguments_bounded _ _ _ H0). - generalize (typesize_pos ty). omega. + generalize (typesize_pos ty). lia. Qed. diff --git a/backend/Deadcodeproof.v b/backend/Deadcodeproof.v index 2edc0395..7be12c69 100644 --- a/backend/Deadcodeproof.v +++ b/backend/Deadcodeproof.v @@ -67,7 +67,7 @@ Lemma mextends_agree: forall m1 m2 P, Mem.extends m1 m2 -> magree m1 m2 P. Proof. intros. destruct H. destruct mext_inj. constructor; intros. -- replace ofs with (ofs + 0) by omega. eapply mi_perm; eauto. auto. +- replace ofs with (ofs + 0) by lia. eapply mi_perm; eauto. auto. - eauto. - exploit mi_memval; eauto. unfold inject_id; eauto. rewrite Z.add_0_r. auto. @@ -99,15 +99,15 @@ Proof. induction n; intros; simpl. constructor. rewrite Nat2Z.inj_succ in H. constructor. - apply H. omega. - apply IHn. intros; apply H; omega. + apply H. lia. + apply IHn. intros; apply H; lia. } Local Transparent Mem.loadbytes. unfold Mem.loadbytes; intros. destruct H. destruct (Mem.range_perm_dec m1 b ofs (ofs + n) Cur Readable); inv H0. rewrite pred_dec_true. econstructor; split; eauto. apply GETN. intros. rewrite Z_to_nat_max in H. - assert (ofs <= i < ofs + n) by xomega. + assert (ofs <= i < ofs + n) by extlia. apply ma_memval0; auto. red; intros; eauto. Qed. @@ -146,11 +146,11 @@ Proof. (ZMap.get q (Mem.setN bytes2 p c2))). { induction 1; intros; simpl. - - apply H; auto. simpl. omega. + - apply H; auto. simpl. lia. - simpl length in H1; rewrite Nat2Z.inj_succ in H1. apply IHlist_forall2; auto. intros. rewrite ! ZMap.gsspec. destruct (ZIndexed.eq i p). auto. - apply H1; auto. unfold ZIndexed.t in *; omega. + apply H1; auto. unfold ZIndexed.t in *; lia. } intros. destruct (Mem.range_perm_storebytes m2 b ofs bytes2) as [m2' ST2]. @@ -211,8 +211,8 @@ Proof. - rewrite (Mem.storebytes_mem_contents _ _ _ _ _ H0). rewrite PMap.gsspec. destruct (peq b0 b). + subst b0. rewrite Mem.setN_outside. eapply ma_memval; eauto. eapply Mem.perm_storebytes_2; eauto. - destruct (zlt ofs0 ofs); auto. destruct (zle (ofs + Z.of_nat (length bytes1)) ofs0); try omega. - elim (H1 ofs0). omega. auto. + destruct (zlt ofs0 ofs); auto. destruct (zle (ofs + Z.of_nat (length bytes1)) ofs0); try lia. + elim (H1 ofs0). lia. auto. + eapply ma_memval; eauto. eapply Mem.perm_storebytes_2; eauto. - rewrite (Mem.nextblock_storebytes _ _ _ _ _ H0). eapply ma_nextblock; eauto. @@ -358,7 +358,7 @@ Proof. intros. destruct ros; simpl in *. eapply add_need_all_eagree; eauto. auto. Qed. -Hint Resolve add_need_all_eagree add_need_all_lessdef +Global Hint Resolve add_need_all_eagree add_need_all_lessdef add_need_eagree add_need_vagree add_needs_all_eagree add_needs_all_lessdef add_needs_eagree add_needs_vagree @@ -966,7 +966,7 @@ Ltac UseTransfer := intros. eapply nlive_remove; eauto. unfold adst, vanalyze; rewrite AN; eapply aaddr_arg_sound_1; eauto. erewrite Mem.loadbytes_length in H1 by eauto. - rewrite Z2Nat.id in H1 by omega. auto. + rewrite Z2Nat.id in H1 by lia. auto. eauto. intros (tm' & A & B). econstructor; split. @@ -993,7 +993,7 @@ Ltac UseTransfer := intros (bc & A & B & C). intros. eapply nlive_contains; eauto. erewrite Mem.loadbytes_length in H0 by eauto. - rewrite Z2Nat.id in H0 by omega. auto. + rewrite Z2Nat.id in H0 by lia. auto. + (* annot *) destruct (transfer_builtin_args (kill_builtin_res res ne, nm) _x2) as (ne1, nm1) eqn:TR. InvSoundState. diff --git a/backend/IRC.ml b/backend/IRC.ml index ed5ae186..6f4bbe29 100644 --- a/backend/IRC.ml +++ b/backend/IRC.ml @@ -33,8 +33,8 @@ type node = { ident: int; (*r unique identifier *) typ: typ; (*r its type *) var: var; (*r the XTL variable it comes from *) - mutable regclass: int; (*r identifier of register class *) - mutable accesses: int; (*r number of defs and uses *) + regclass: int; (*r identifier of register class *) + accesses: int; (*r number of defs and uses *) mutable spillcost: float; (*r estimated cost of spilling *) mutable adjlist: node list; (*r all nodes it interferes with *) mutable degree: int; (*r number of adjacent nodes *) @@ -206,7 +206,7 @@ type graph = { varTable: (var, node) Hashtbl.t; mutable nextIdent: int; (* The adjacency set *) - mutable adjSet: unit IntPairs.t; + adjSet: unit IntPairs.t; (* Low-degree, non-move-related nodes *) simplifyWorklist: DLinkNode.t; (* Low-degree, move-related nodes *) diff --git a/backend/Inlining.v b/backend/Inlining.v index f7ee4166..d66d2586 100644 --- a/backend/Inlining.v +++ b/backend/Inlining.v @@ -71,12 +71,12 @@ Inductive sincr (s1 s2: state) : Prop := Remark sincr_refl: forall s, sincr s s. Proof. - intros; constructor; xomega. + intros; constructor; extlia. Qed. Lemma sincr_trans: forall s1 s2 s3, sincr s1 s2 -> sincr s2 s3 -> sincr s1 s3. Proof. - intros. inv H; inv H0. constructor; xomega. + intros. inv H; inv H0. constructor; extlia. Qed. (** Dependently-typed state monad, ensuring that the final state is @@ -111,7 +111,7 @@ Program Definition set_instr (pc: node) (i: instruction): mon unit := (mkstate s.(st_nextreg) s.(st_nextnode) (PTree.set pc i s.(st_code)) s.(st_stksize)) _. Next Obligation. - intros; constructor; simpl; xomega. + intros; constructor; simpl; extlia. Qed. Program Definition add_instr (i: instruction): mon node := @@ -121,7 +121,7 @@ Program Definition add_instr (i: instruction): mon node := (mkstate s.(st_nextreg) (Pos.succ pc) (PTree.set pc i s.(st_code)) s.(st_stksize)) _. Next Obligation. - intros; constructor; simpl; xomega. + intros; constructor; simpl; extlia. Qed. Program Definition reserve_nodes (numnodes: positive): mon positive := @@ -130,7 +130,7 @@ Program Definition reserve_nodes (numnodes: positive): mon positive := (mkstate s.(st_nextreg) (Pos.add s.(st_nextnode) numnodes) s.(st_code) s.(st_stksize)) _. Next Obligation. - intros; constructor; simpl; xomega. + intros; constructor; simpl; extlia. Qed. Program Definition reserve_regs (numregs: positive): mon positive := @@ -139,7 +139,7 @@ Program Definition reserve_regs (numregs: positive): mon positive := (mkstate (Pos.add s.(st_nextreg) numregs) s.(st_nextnode) s.(st_code) s.(st_stksize)) _. Next Obligation. - intros; constructor; simpl; xomega. + intros; constructor; simpl; extlia. Qed. Program Definition request_stack (sz: Z): mon unit := @@ -148,7 +148,7 @@ Program Definition request_stack (sz: Z): mon unit := (mkstate s.(st_nextreg) s.(st_nextnode) s.(st_code) (Z.max s.(st_stksize) sz)) _. Next Obligation. - intros; constructor; simpl; xomega. + intros; constructor; simpl; extlia. Qed. Program Definition ptree_mfold {A: Type} (f: positive -> A -> mon unit) (t: PTree.t A): mon unit := @@ -293,10 +293,13 @@ Inductive inline_decision (ros: reg + ident) : Type := | Cannot_inline | Can_inline (id: ident) (f: function) (P: ros = inr reg id) (Q: fenv!id = Some f). +Arguments Cannot_inline {ros}. +Arguments Can_inline {ros}. + Program Definition can_inline (ros: reg + ident): inline_decision ros := match ros with - | inl r => Cannot_inline _ - | inr id => match fenv!id with Some f => Can_inline _ id f _ _ | None => Cannot_inline _ end + | inl r => Cannot_inline + | inr id => match fenv!id with Some f => Can_inline id f _ _ | None => Cannot_inline end end. (** Inlining of a call to function [f]. An appropriate context is diff --git a/backend/Inliningproof.v b/backend/Inliningproof.v index cc84b1cc..0434a4a4 100644 --- a/backend/Inliningproof.v +++ b/backend/Inliningproof.v @@ -67,21 +67,21 @@ Qed. Remark sreg_below_diff: forall ctx r r', Plt r' ctx.(dreg) -> sreg ctx r <> r'. Proof. - intros. zify. unfold sreg; rewrite shiftpos_eq. xomega. + intros. zify. unfold sreg; rewrite shiftpos_eq. extlia. Qed. Remark context_below_diff: forall ctx1 ctx2 r1 r2, context_below ctx1 ctx2 -> Ple r1 ctx1.(mreg) -> sreg ctx1 r1 <> sreg ctx2 r2. Proof. - intros. red in H. zify. unfold sreg; rewrite ! shiftpos_eq. xomega. + intros. red in H. zify. unfold sreg; rewrite ! shiftpos_eq. extlia. Qed. Remark context_below_lt: forall ctx1 ctx2 r, context_below ctx1 ctx2 -> Ple r ctx1.(mreg) -> Plt (sreg ctx1 r) ctx2.(dreg). Proof. intros. red in H. unfold Plt; zify. unfold sreg; rewrite shiftpos_eq. - xomega. + extlia. Qed. (* @@ -89,7 +89,7 @@ Remark context_below_le: forall ctx1 ctx2 r, context_below ctx1 ctx2 -> Ple r ctx1.(mreg) -> Ple (sreg ctx1 r) ctx2.(dreg). Proof. intros. red in H. unfold Ple; zify. unfold sreg; rewrite shiftpos_eq. - xomega. + extlia. Qed. *) @@ -105,7 +105,7 @@ Definition val_reg_charact (F: meminj) (ctx: context) (rs': regset) (v: val) (r: Remark Plt_Ple_dec: forall p q, {Plt p q} + {Ple q p}. Proof. - intros. destruct (plt p q). left; auto. right; xomega. + intros. destruct (plt p q). left; auto. right; extlia. Qed. Lemma agree_val_reg_gen: @@ -149,7 +149,7 @@ Proof. repeat rewrite Regmap.gsspec. destruct (peq r0 r). subst r0. rewrite peq_true. auto. rewrite peq_false. auto. apply shiftpos_diff; auto. - rewrite Regmap.gso. auto. xomega. + rewrite Regmap.gso. auto. extlia. Qed. Lemma agree_set_reg_undef: @@ -184,7 +184,7 @@ Proof. unfold agree_regs; intros. destruct H. split; intros. rewrite H0. auto. apply shiftpos_above. - eapply Pos.lt_le_trans. apply shiftpos_below. xomega. + eapply Pos.lt_le_trans. apply shiftpos_below. extlia. apply H1; auto. Qed. @@ -272,7 +272,7 @@ Lemma range_private_invariant: range_private F1 m1 m1' sp lo hi. Proof. intros; red; intros. exploit H; eauto. intros [A B]. split; auto. - intros; red; intros. exploit H0; eauto. omega. intros [P Q]. + intros; red; intros. exploit H0; eauto. lia. intros [P Q]. eelim B; eauto. Qed. @@ -293,12 +293,12 @@ Lemma range_private_alloc_left: range_private F1 m1 m' sp' (base + Z.max sz 0) hi. Proof. intros; red; intros. - exploit (H ofs). generalize (Z.le_max_r sz 0). omega. intros [A B]. + exploit (H ofs). generalize (Z.le_max_r sz 0). lia. intros [A B]. split; auto. intros; red; intros. exploit Mem.perm_alloc_inv; eauto. destruct (eq_block b sp); intros. subst b. rewrite H1 in H4; inv H4. - rewrite Zmax_spec in H3. destruct (zlt 0 sz); omega. + rewrite Zmax_spec in H3. destruct (zlt 0 sz); lia. rewrite H2 in H4; auto. eelim B; eauto. Qed. @@ -313,21 +313,21 @@ Proof. intros; red; intros. destruct (zlt ofs (base + Z.max sz 0)) as [z|z]. red; split. - replace ofs with ((ofs - base) + base) by omega. + replace ofs with ((ofs - base) + base) by lia. eapply Mem.perm_inject; eauto. eapply Mem.free_range_perm; eauto. - rewrite Zmax_spec in z. destruct (zlt 0 sz); omega. + rewrite Zmax_spec in z. destruct (zlt 0 sz); lia. intros; red; intros. destruct (eq_block b b0). subst b0. rewrite H1 in H4; inv H4. - eelim Mem.perm_free_2; eauto. rewrite Zmax_spec in z. destruct (zlt 0 sz); omega. + eelim Mem.perm_free_2; eauto. rewrite Zmax_spec in z. destruct (zlt 0 sz); lia. exploit Mem.mi_no_overlap; eauto. apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable; auto with mem. eapply Mem.free_range_perm. eauto. - instantiate (1 := ofs - base). rewrite Zmax_spec in z. destruct (zlt 0 sz); omega. + instantiate (1 := ofs - base). rewrite Zmax_spec in z. destruct (zlt 0 sz); lia. eapply Mem.perm_free_3; eauto. - intros [A | A]. congruence. omega. + intros [A | A]. congruence. lia. - exploit (H ofs). omega. intros [A B]. split. auto. + exploit (H ofs). lia. intros [A B]. split. auto. intros; red; intros. eelim B; eauto. eapply Mem.perm_free_3; eauto. Qed. @@ -607,39 +607,39 @@ Proof. (* cons *) apply match_stacks_cons with (fenv := fenv) (ctx := ctx); auto. eapply match_stacks_inside_invariant; eauto. - intros; eapply INJ; eauto; xomega. - intros; eapply PERM1; eauto; xomega. - intros; eapply PERM2; eauto; xomega. - intros; eapply PERM3; eauto; xomega. + intros; eapply INJ; eauto; extlia. + intros; eapply PERM1; eauto; extlia. + intros; eapply PERM2; eauto; extlia. + intros; eapply PERM3; eauto; extlia. eapply agree_regs_incr; eauto. eapply range_private_invariant; eauto. (* untailcall *) apply match_stacks_untailcall with (ctx := ctx); auto. eapply match_stacks_inside_invariant; eauto. - intros; eapply INJ; eauto; xomega. - intros; eapply PERM1; eauto; xomega. - intros; eapply PERM2; eauto; xomega. - intros; eapply PERM3; eauto; xomega. + intros; eapply INJ; eauto; extlia. + intros; eapply PERM1; eauto; extlia. + intros; eapply PERM2; eauto; extlia. + intros; eapply PERM3; eauto; extlia. eapply range_private_invariant; eauto. induction 1; intros. (* base *) eapply match_stacks_inside_base; eauto. eapply match_stacks_invariant; eauto. - intros; eapply INJ; eauto; xomega. - intros; eapply PERM1; eauto; xomega. - intros; eapply PERM2; eauto; xomega. - intros; eapply PERM3; eauto; xomega. + intros; eapply INJ; eauto; extlia. + intros; eapply PERM1; eauto; extlia. + intros; eapply PERM2; eauto; extlia. + intros; eapply PERM3; eauto; extlia. (* inlined *) apply match_stacks_inside_inlined with (fenv := fenv) (ctx' := ctx'); auto. apply IHmatch_stacks_inside; auto. - intros. apply RS. red in BELOW. xomega. + intros. apply RS. red in BELOW. extlia. apply agree_regs_incr with F; auto. apply agree_regs_invariant with rs'; auto. - intros. apply RS. red in BELOW. xomega. + intros. apply RS. red in BELOW. extlia. eapply range_private_invariant; eauto. - intros. split. eapply INJ; eauto. xomega. eapply PERM1; eauto. xomega. - intros. eapply PERM2; eauto. xomega. + intros. split. eapply INJ; eauto. extlia. eapply PERM1; eauto. extlia. + intros. eapply PERM2; eauto. extlia. Qed. Lemma match_stacks_empty: @@ -668,7 +668,7 @@ Lemma match_stacks_inside_set_reg: match_stacks_inside F m m' stk stk' f' ctx sp' (rs'#(sreg ctx r) <- v). Proof. intros. eapply match_stacks_inside_invariant; eauto. - intros. apply Regmap.gso. zify. unfold sreg; rewrite shiftpos_eq. xomega. + intros. apply Regmap.gso. zify. unfold sreg; rewrite shiftpos_eq. extlia. Qed. Lemma match_stacks_inside_set_res: @@ -717,11 +717,11 @@ Proof. subst b1. rewrite H1 in H4. inv H4. eelim Plt_strict; eauto. (* inlined *) eapply match_stacks_inside_inlined; eauto. - eapply IHmatch_stacks_inside; eauto. destruct SBELOW. omega. + eapply IHmatch_stacks_inside; eauto. destruct SBELOW. lia. eapply agree_regs_incr; eauto. eapply range_private_invariant; eauto. intros. exploit Mem.perm_alloc_inv; eauto. destruct (eq_block b0 b); intros. - subst b0. rewrite H2 in H5; inv H5. elimtype False; xomega. + subst b0. rewrite H2 in H5; inv H5. elimtype False; extlia. rewrite H3 in H5; auto. Qed. @@ -753,25 +753,25 @@ Lemma min_alignment_sound: Proof. intros; red; intros. unfold min_alignment in H. assert (2 <= sz -> (2 | n)). intros. - destruct (zle sz 1). omegaContradiction. + destruct (zle sz 1). extlia. destruct (zle sz 2). auto. destruct (zle sz 4). apply Z.divide_trans with 4; auto. exists 2; auto. apply Z.divide_trans with 8; auto. exists 4; auto. assert (4 <= sz -> (4 | n)). intros. - destruct (zle sz 1). omegaContradiction. - destruct (zle sz 2). omegaContradiction. + destruct (zle sz 1). extlia. + destruct (zle sz 2). extlia. destruct (zle sz 4). auto. apply Z.divide_trans with 8; auto. exists 2; auto. assert (8 <= sz -> (8 | n)). intros. - destruct (zle sz 1). omegaContradiction. - destruct (zle sz 2). omegaContradiction. - destruct (zle sz 4). omegaContradiction. + destruct (zle sz 1). extlia. + destruct (zle sz 2). extlia. + destruct (zle sz 4). extlia. auto. destruct chunk; simpl in *; auto. apply Z.divide_1_l. apply Z.divide_1_l. - apply H2; omega. - apply H2; omega. + apply H2; lia. + apply H2; lia. Qed. (** Preservation by external calls *) @@ -803,19 +803,19 @@ Proof. inv MG. constructor; intros; eauto. destruct (F1 b1) as [[b2' delta']|] eqn:?. exploit INCR; eauto. intros EQ; rewrite H0 in EQ; inv EQ. eapply IMAGE; eauto. - exploit SEP; eauto. intros [A B]. elim B. red. xomega. + exploit SEP; eauto. intros [A B]. elim B. red. extlia. eapply match_stacks_cons; eauto. - eapply match_stacks_inside_extcall; eauto. xomega. + eapply match_stacks_inside_extcall; eauto. extlia. eapply agree_regs_incr; eauto. - eapply range_private_extcall; eauto. red; xomega. - intros. apply SSZ2; auto. apply MAXPERM'; auto. red; xomega. + eapply range_private_extcall; eauto. red; extlia. + intros. apply SSZ2; auto. apply MAXPERM'; auto. red; extlia. eapply match_stacks_untailcall; eauto. - eapply match_stacks_inside_extcall; eauto. xomega. - eapply range_private_extcall; eauto. red; xomega. - intros. apply SSZ2; auto. apply MAXPERM'; auto. red; xomega. + eapply match_stacks_inside_extcall; eauto. extlia. + eapply range_private_extcall; eauto. red; extlia. + intros. apply SSZ2; auto. apply MAXPERM'; auto. red; extlia. induction 1; intros. eapply match_stacks_inside_base; eauto. - eapply match_stacks_extcall; eauto. xomega. + eapply match_stacks_extcall; eauto. extlia. eapply match_stacks_inside_inlined; eauto. eapply agree_regs_incr; eauto. eapply range_private_extcall; eauto. @@ -829,7 +829,7 @@ Lemma align_unchanged: forall n amount, amount > 0 -> (amount | n) -> align n amount = n. Proof. intros. destruct H0 as [p EQ]. subst n. unfold align. decEq. - apply Zdiv_unique with (b := amount - 1). omega. omega. + apply Zdiv_unique with (b := amount - 1). lia. lia. Qed. Lemma match_stacks_inside_inlined_tailcall: @@ -849,10 +849,10 @@ Proof. (* inlined *) assert (dstk ctx <= dstk ctx'). rewrite H1. apply align_le. apply min_alignment_pos. eapply match_stacks_inside_inlined; eauto. - red; intros. destruct (zlt ofs (dstk ctx)). apply PAD; omega. apply H3. inv H4. xomega. + red; intros. destruct (zlt ofs (dstk ctx)). apply PAD; lia. apply H3. inv H4. extlia. congruence. - unfold context_below in *. xomega. - unfold context_stack_call in *. omega. + unfold context_below in *. extlia. + unfold context_stack_call in *. lia. Qed. (** ** Relating states *) @@ -1014,12 +1014,12 @@ Proof. + (* inlined *) assert (EQ: fd = Internal f0) by (eapply find_inlined_function; eauto). subst fd. - right; split. simpl; omega. split. auto. + right; split. simpl; lia. split. auto. econstructor; eauto. eapply match_stacks_inside_inlined; eauto. - red; intros. apply PRIV. inv H13. destruct H16. xomega. + red; intros. apply PRIV. inv H13. destruct H16. extlia. apply agree_val_regs_gen; auto. - red; intros; apply PRIV. destruct H16. omega. + red; intros; apply PRIV. destruct H16. lia. - (* tailcall *) exploit match_stacks_inside_globalenvs; eauto. intros [bound G]. @@ -1032,9 +1032,9 @@ Proof. assert (X: { m1' | Mem.free m'0 sp' 0 (fn_stacksize f') = Some m1'}). apply Mem.range_perm_free. red; intros. destruct (zlt ofs f.(fn_stacksize)). - replace ofs with (ofs + dstk ctx) by omega. eapply Mem.perm_inject; eauto. - eapply Mem.free_range_perm; eauto. omega. - inv FB. eapply range_private_perms; eauto. xomega. + replace ofs with (ofs + dstk ctx) by lia. eapply Mem.perm_inject; eauto. + eapply Mem.free_range_perm; eauto. lia. + inv FB. eapply range_private_perms; eauto. extlia. destruct X as [m1' FREE]. left; econstructor; split. eapply plus_one. eapply exec_Itailcall; eauto. @@ -1045,12 +1045,12 @@ Proof. intros. eapply Mem.perm_free_3; eauto. intros. eapply Mem.perm_free_1; eauto with ordered_type. intros. eapply Mem.perm_free_3; eauto. - erewrite Mem.nextblock_free; eauto. red in VB; xomega. + erewrite Mem.nextblock_free; eauto. red in VB; extlia. eapply agree_val_regs; eauto. eapply Mem.free_right_inject; eauto. eapply Mem.free_left_inject; eauto. (* show that no valid location points into the stack block being freed *) - intros. rewrite DSTK in PRIV'. exploit (PRIV' (ofs + delta)). omega. intros [P Q]. - eelim Q; eauto. replace (ofs + delta - delta) with ofs by omega. + intros. rewrite DSTK in PRIV'. exploit (PRIV' (ofs + delta)). lia. intros [P Q]. + eelim Q; eauto. replace (ofs + delta - delta) with ofs by lia. apply Mem.perm_max with k. apply Mem.perm_implies with p; auto with mem. + (* turned into a call *) left; econstructor; split. @@ -1065,7 +1065,7 @@ Proof. + (* inlined *) assert (EQ: fd = Internal f0) by (eapply find_inlined_function; eauto). subst fd. - right; split. simpl; omega. split. auto. + right; split. simpl; lia. split. auto. econstructor; eauto. eapply match_stacks_inside_inlined_tailcall; eauto. eapply match_stacks_inside_invariant; eauto. @@ -1074,7 +1074,7 @@ Proof. eapply Mem.free_left_inject; eauto. red; intros; apply PRIV'. assert (dstk ctx <= dstk ctx'). red in H14; rewrite H14. apply align_le. apply min_alignment_pos. - omega. + lia. - (* builtin *) exploit tr_funbody_inv; eauto. intros TR; inv TR. @@ -1124,10 +1124,10 @@ Proof. assert (X: { m1' | Mem.free m'0 sp' 0 (fn_stacksize f') = Some m1'}). apply Mem.range_perm_free. red; intros. destruct (zlt ofs f.(fn_stacksize)). - replace ofs with (ofs + dstk ctx) by omega. eapply Mem.perm_inject; eauto. - eapply Mem.free_range_perm; eauto. omega. + replace ofs with (ofs + dstk ctx) by lia. eapply Mem.perm_inject; eauto. + eapply Mem.free_range_perm; eauto. lia. inv FB. eapply range_private_perms; eauto. - generalize (Zmax_spec (fn_stacksize f) 0). destruct (zlt 0 (fn_stacksize f)); omega. + generalize (Zmax_spec (fn_stacksize f) 0). destruct (zlt 0 (fn_stacksize f)); lia. destruct X as [m1' FREE]. left; econstructor; split. eapply plus_one. eapply exec_Ireturn; eauto. @@ -1137,19 +1137,19 @@ Proof. intros. eapply Mem.perm_free_3; eauto. intros. eapply Mem.perm_free_1; eauto with ordered_type. intros. eapply Mem.perm_free_3; eauto. - erewrite Mem.nextblock_free; eauto. red in VB; xomega. + erewrite Mem.nextblock_free; eauto. red in VB; extlia. destruct or; simpl. apply agree_val_reg; auto. auto. eapply Mem.free_right_inject; eauto. eapply Mem.free_left_inject; eauto. (* show that no valid location points into the stack block being freed *) intros. inversion FB; subst. assert (PRIV': range_private F m' m'0 sp' (dstk ctx) f'.(fn_stacksize)). rewrite H8 in PRIV. eapply range_private_free_left; eauto. - rewrite DSTK in PRIV'. exploit (PRIV' (ofs + delta)). omega. intros [A B]. - eelim B; eauto. replace (ofs + delta - delta) with ofs by omega. + rewrite DSTK in PRIV'. exploit (PRIV' (ofs + delta)). lia. intros [A B]. + eelim B; eauto. replace (ofs + delta - delta) with ofs by lia. apply Mem.perm_max with k. apply Mem.perm_implies with p; auto with mem. + (* inlined *) - right. split. simpl. omega. split. auto. + right. split. simpl. lia. split. auto. econstructor; eauto. eapply match_stacks_inside_invariant; eauto. intros. eapply Mem.perm_free_3; eauto. @@ -1165,7 +1165,7 @@ Proof. { eapply tr_function_linkorder; eauto. } inversion TR; subst. exploit Mem.alloc_parallel_inject. eauto. eauto. apply Z.le_refl. - instantiate (1 := fn_stacksize f'). inv H1. xomega. + instantiate (1 := fn_stacksize f'). inv H1. extlia. intros [F' [m1' [sp' [A [B [C [D E]]]]]]]. left; econstructor; split. eapply plus_one. eapply exec_function_internal; eauto. @@ -1187,13 +1187,13 @@ Proof. rewrite H5. apply agree_regs_init_regs. eauto. auto. inv H1; auto. congruence. auto. eapply Mem.valid_new_block; eauto. red; intros. split. - eapply Mem.perm_alloc_2; eauto. inv H1; xomega. + eapply Mem.perm_alloc_2; eauto. inv H1; extlia. intros; red; intros. exploit Mem.perm_alloc_inv. eexact H. eauto. destruct (eq_block b stk); intros. - subst. rewrite D in H9; inv H9. inv H1; xomega. + subst. rewrite D in H9; inv H9. inv H1; extlia. rewrite E in H9; auto. eelim Mem.fresh_block_alloc. eexact A. eapply Mem.mi_mappedblocks; eauto. auto. - intros. exploit Mem.perm_alloc_inv; eauto. rewrite dec_eq_true. omega. + intros. exploit Mem.perm_alloc_inv; eauto. rewrite dec_eq_true. lia. - (* internal function, inlined *) inversion FB; subst. @@ -1203,19 +1203,19 @@ Proof. (* sp' is valid *) instantiate (1 := sp'). auto. (* offset is representable *) - instantiate (1 := dstk ctx). generalize (Z.le_max_r (fn_stacksize f) 0). omega. + instantiate (1 := dstk ctx). generalize (Z.le_max_r (fn_stacksize f) 0). lia. (* size of target block is representable *) - intros. right. exploit SSZ2; eauto with mem. inv FB; omega. + intros. right. exploit SSZ2; eauto with mem. inv FB; lia. (* we have full permissions on sp' at and above dstk ctx *) intros. apply Mem.perm_cur. apply Mem.perm_implies with Freeable; auto with mem. - eapply range_private_perms; eauto. xomega. + eapply range_private_perms; eauto. extlia. (* offset is aligned *) - replace (fn_stacksize f - 0) with (fn_stacksize f) by omega. + replace (fn_stacksize f - 0) with (fn_stacksize f) by lia. inv FB. apply min_alignment_sound; auto. (* nobody maps to (sp, dstk ctx...) *) - intros. exploit (PRIV (ofs + delta')); eauto. xomega. + intros. exploit (PRIV (ofs + delta')); eauto. extlia. intros [A B]. eelim B; eauto. - replace (ofs + delta' - delta') with ofs by omega. + replace (ofs + delta' - delta') with ofs by lia. apply Mem.perm_max with k. apply Mem.perm_implies with p; auto with mem. intros [F' [A [B [C D]]]]. exploit tr_moves_init_regs; eauto. intros [rs'' [P [Q R]]]. @@ -1224,7 +1224,7 @@ Proof. econstructor. eapply match_stacks_inside_alloc_left; eauto. eapply match_stacks_inside_invariant; eauto. - omega. + lia. eauto. auto. apply agree_regs_incr with F; auto. auto. auto. auto. @@ -1245,7 +1245,7 @@ Proof. eapply match_stacks_extcall with (F1 := F) (F2 := F1) (m1 := m) (m1' := m'0); eauto. intros; eapply external_call_max_perm; eauto. intros; eapply external_call_max_perm; eauto. - xomega. + extlia. eapply external_call_nextblock; eauto. auto. auto. @@ -1267,14 +1267,14 @@ Proof. eauto. auto. apply agree_set_reg; auto. auto. auto. auto. - red; intros. destruct (zlt ofs (dstk ctx)). apply PAD; omega. apply PRIV; omega. + red; intros. destruct (zlt ofs (dstk ctx)). apply PAD; lia. apply PRIV; lia. auto. auto. - (* return from inlined function *) inv MS0; try congruence. rewrite RET0 in RET; inv RET. unfold inline_return in AT. assert (PRIV': range_private F m m' sp' (dstk ctx' + mstk ctx') f'.(fn_stacksize)). - red; intros. destruct (zlt ofs (dstk ctx)). apply PAD. omega. apply PRIV. omega. + red; intros. destruct (zlt ofs (dstk ctx)). apply PAD. lia. apply PRIV. lia. destruct or. + (* with a result *) left; econstructor; split. diff --git a/backend/Inliningspec.v b/backend/Inliningspec.v index c345c942..477f883a 100644 --- a/backend/Inliningspec.v +++ b/backend/Inliningspec.v @@ -73,7 +73,7 @@ Qed. Lemma shiftpos_eq: forall x y, Zpos (shiftpos x y) = (Zpos x + Zpos y) - 1. Proof. intros. unfold shiftpos. zify. try rewrite Pos2Z.inj_sub. auto. - zify. omega. + zify. lia. Qed. Lemma shiftpos_inj: @@ -82,7 +82,7 @@ Proof. intros. assert (Zpos (shiftpos x n) = Zpos (shiftpos y n)) by congruence. rewrite ! shiftpos_eq in H0. - assert (Z.pos x = Z.pos y) by omega. + assert (Z.pos x = Z.pos y) by lia. congruence. Qed. @@ -95,25 +95,25 @@ Qed. Lemma shiftpos_above: forall x n, Ple n (shiftpos x n). Proof. - intros. unfold Ple; zify. rewrite shiftpos_eq. xomega. + intros. unfold Ple; zify. rewrite shiftpos_eq. extlia. Qed. Lemma shiftpos_not_below: forall x n, Plt (shiftpos x n) n -> False. Proof. - intros. generalize (shiftpos_above x n). xomega. + intros. generalize (shiftpos_above x n). extlia. Qed. Lemma shiftpos_below: forall x n, Plt (shiftpos x n) (Pos.add x n). Proof. - intros. unfold Plt; zify. rewrite shiftpos_eq. omega. + intros. unfold Plt; zify. rewrite shiftpos_eq. lia. Qed. Lemma shiftpos_le: forall x y n, Ple x y -> Ple (shiftpos x n) (shiftpos y n). Proof. - intros. unfold Ple in *; zify. rewrite ! shiftpos_eq. omega. + intros. unfold Ple in *; zify. rewrite ! shiftpos_eq. lia. Qed. @@ -219,9 +219,9 @@ Proof. induction srcs; simpl; intros. monadInv H. auto. destruct dsts; monadInv H. auto. - transitivity (st_code s0)!pc. eapply IHsrcs; eauto. monadInv EQ; simpl. xomega. + transitivity (st_code s0)!pc. eapply IHsrcs; eauto. monadInv EQ; simpl. extlia. monadInv EQ; simpl. apply PTree.gso. - inversion INCR0; simpl in *. xomega. + inversion INCR0; simpl in *. extlia. Qed. Lemma add_moves_spec: @@ -234,13 +234,13 @@ Proof. monadInv H. apply tr_moves_nil; auto. destruct dsts; monadInv H. apply tr_moves_nil; auto. apply tr_moves_cons with x. eapply IHsrcs; eauto. - intros. inversion INCR. apply H0; xomega. + intros. inversion INCR. apply H0; extlia. monadInv EQ. rewrite H0. erewrite add_moves_unchanged; eauto. simpl. apply PTree.gss. - simpl. xomega. - xomega. - inversion INCR; inversion INCR0; simpl in *; xomega. + simpl. extlia. + extlia. + inversion INCR; inversion INCR0; simpl in *; extlia. Qed. (** ** Relational specification of CFG expansion *) @@ -386,9 +386,9 @@ Proof. monadInv H. unfold inline_function in EQ. monadInv EQ. transitivity (s2.(st_code)!pc'). eauto. transitivity (s5.(st_code)!pc'). eapply add_moves_unchanged; eauto. - left. inversion INCR5. inversion INCR3. monadInv EQ1; simpl in *. xomega. + left. inversion INCR5. inversion INCR3. monadInv EQ1; simpl in *. extlia. transitivity (s4.(st_code)!pc'). eapply rec_unchanged; eauto. - simpl. monadInv EQ; simpl. monadInv EQ1; simpl. xomega. + simpl. monadInv EQ; simpl. monadInv EQ1; simpl. extlia. simpl. monadInv EQ1; simpl. auto. monadInv EQ; simpl. monadInv EQ1; simpl. auto. (* tailcall *) @@ -397,9 +397,9 @@ Proof. monadInv H. unfold inline_tail_function in EQ. monadInv EQ. transitivity (s2.(st_code)!pc'). eauto. transitivity (s5.(st_code)!pc'). eapply add_moves_unchanged; eauto. - left. inversion INCR5. inversion INCR3. monadInv EQ1; simpl in *. xomega. + left. inversion INCR5. inversion INCR3. monadInv EQ1; simpl in *. extlia. transitivity (s4.(st_code)!pc'). eapply rec_unchanged; eauto. - simpl. monadInv EQ; simpl. monadInv EQ1; simpl. xomega. + simpl. monadInv EQ; simpl. monadInv EQ1; simpl. extlia. simpl. monadInv EQ1; simpl. auto. monadInv EQ; simpl. monadInv EQ1; simpl. auto. (* return *) @@ -422,7 +422,7 @@ Proof. destruct a as [pc1 instr1]; simpl in *. monadInv H. inv H3. transitivity ((st_code s0)!pc). - eapply IHl; eauto. destruct INCR; xomega. destruct INCR; xomega. + eapply IHl; eauto. destruct INCR; extlia. destruct INCR; extlia. eapply expand_instr_unchanged; eauto. Qed. @@ -438,7 +438,7 @@ Proof. exploit ptree_mfold_spec; eauto. intros [INCR' ITER]. eapply iter_expand_instr_unchanged; eauto. subst s0; auto. - subst s0; simpl. xomega. + subst s0; simpl. extlia. red; intros. exploit list_in_map_inv; eauto. intros [pc1 [A B]]. subst pc. unfold spc in H1. eapply shiftpos_not_below; eauto. apply PTree.elements_keys_norepet. @@ -464,7 +464,7 @@ Remark min_alignment_pos: forall sz, min_alignment sz > 0. Proof. intros; unfold min_alignment. - destruct (zle sz 1). omega. destruct (zle sz 2). omega. destruct (zle sz 4); omega. + destruct (zle sz 1). lia. destruct (zle sz 2). lia. destruct (zle sz 4); lia. Qed. Ltac inv_incr := @@ -501,20 +501,20 @@ Proof. apply tr_call_inlined with (pc1 := x0) (ctx' := ctx') (f := f); auto. eapply BASE; eauto. eapply add_moves_spec; eauto. - intros. rewrite S1. eapply set_instr_other; eauto. unfold node; xomega. - xomega. xomega. + intros. rewrite S1. eapply set_instr_other; eauto. unfold node; extlia. + extlia. extlia. eapply rec_spec; eauto. red; intros. rewrite PTree.grspec in H. destruct (PTree.elt_eq id0 id); try discriminate. auto. - simpl. subst s2; simpl in *; xomega. - simpl. subst s3; simpl in *; xomega. - simpl. xomega. + simpl. subst s2; simpl in *; extlia. + simpl. subst s3; simpl in *; extlia. + simpl. extlia. simpl. apply align_divides. apply min_alignment_pos. - assert (dstk ctx + mstk ctx <= dstk ctx'). simpl. apply align_le. apply min_alignment_pos. omega. - omega. + assert (dstk ctx + mstk ctx <= dstk ctx'). simpl. apply align_le. apply min_alignment_pos. lia. + lia. intros. simpl in H. rewrite S1. - transitivity (s1.(st_code)!pc0). eapply set_instr_other; eauto. unfold node in *; xomega. - eapply add_moves_unchanged; eauto. unfold node in *; xomega. xomega. - red; simpl. subst s2; simpl in *. xomega. + transitivity (s1.(st_code)!pc0). eapply set_instr_other; eauto. unfold node in *; extlia. + eapply add_moves_unchanged; eauto. unfold node in *; extlia. extlia. + red; simpl. subst s2; simpl in *. extlia. red; simpl. split. auto. apply align_le. apply min_alignment_pos. (* tailcall *) destruct (can_inline fe s1) as [|id f P Q]. @@ -532,20 +532,20 @@ Proof. apply tr_tailcall_inlined with (pc1 := x0) (ctx' := ctx') (f := f); auto. eapply BASE; eauto. eapply add_moves_spec; eauto. - intros. rewrite S1. eapply set_instr_other; eauto. unfold node; xomega. xomega. xomega. + intros. rewrite S1. eapply set_instr_other; eauto. unfold node; extlia. extlia. extlia. eapply rec_spec; eauto. red; intros. rewrite PTree.grspec in H. destruct (PTree.elt_eq id0 id); try discriminate. auto. - simpl. subst s3; simpl in *. subst s2; simpl in *. xomega. - simpl. subst s3; simpl in *; xomega. - simpl. xomega. + simpl. subst s3; simpl in *. subst s2; simpl in *. extlia. + simpl. subst s3; simpl in *; extlia. + simpl. extlia. simpl. apply align_divides. apply min_alignment_pos. - assert (dstk ctx <= dstk ctx'). simpl. apply align_le. apply min_alignment_pos. omega. - omega. + assert (dstk ctx <= dstk ctx'). simpl. apply align_le. apply min_alignment_pos. lia. + lia. intros. simpl in H. rewrite S1. - transitivity (s1.(st_code))!pc0. eapply set_instr_other; eauto. unfold node in *; xomega. - eapply add_moves_unchanged; eauto. unfold node in *; xomega. xomega. + transitivity (s1.(st_code))!pc0. eapply set_instr_other; eauto. unfold node in *; extlia. + eapply add_moves_unchanged; eauto. unfold node in *; extlia. extlia. red; simpl. -subst s2; simpl in *; xomega. +subst s2; simpl in *; extlia. red; auto. (* builtin *) eapply tr_builtin; eauto. destruct b; eauto. @@ -577,31 +577,31 @@ Proof. destruct a as [pc1 instr1]; simpl in *. inv H0. monadInv H. inv_incr. assert (A: Ple ctx.(dpc) s0.(st_nextnode)). assert (B: Plt (spc ctx pc) (st_nextnode s)) by eauto. - unfold spc in B. generalize (shiftpos_above pc (dpc ctx)). xomega. + unfold spc in B. generalize (shiftpos_above pc (dpc ctx)). extlia. destruct H9. inv H. (* same pc *) eapply expand_instr_spec; eauto. - omega. + lia. intros. transitivity ((st_code s')!pc'). - apply H7. auto. xomega. + apply H7. auto. extlia. eapply iter_expand_instr_unchanged; eauto. red; intros. rewrite list_map_compose in H9. exploit list_in_map_inv; eauto. intros [[pc0 instr0] [P Q]]. simpl in P. - assert (Plt (spc ctx pc0) (st_nextnode s)) by eauto. xomega. + assert (Plt (spc ctx pc0) (st_nextnode s)) by eauto. extlia. transitivity ((st_code s')!(spc ctx pc)). eapply H8; eauto. eapply iter_expand_instr_unchanged; eauto. - assert (Plt (spc ctx pc) (st_nextnode s)) by eauto. xomega. + assert (Plt (spc ctx pc) (st_nextnode s)) by eauto. extlia. red; intros. rewrite list_map_compose in H. exploit list_in_map_inv; eauto. intros [[pc0 instr0] [P Q]]. simpl in P. assert (pc = pc0) by (eapply shiftpos_inj; eauto). subst pc0. elim H12. change pc with (fst (pc, instr0)). apply List.in_map; auto. (* older pc *) inv_incr. eapply IHl; eauto. - intros. eapply Pos.lt_le_trans. eapply H2. right; eauto. xomega. + intros. eapply Pos.lt_le_trans. eapply H2. right; eauto. extlia. intros; eapply Ple_trans; eauto. - intros. apply H7; auto. xomega. + intros. apply H7; auto. extlia. Qed. Lemma expand_cfg_rec_spec: @@ -629,16 +629,16 @@ Proof. intros. assert (Ple pc0 (max_pc_function f)). eapply max_pc_function_sound. eapply PTree.elements_complete; eauto. - eapply Pos.lt_le_trans. apply shiftpos_below. subst s0; simpl; xomega. + eapply Pos.lt_le_trans. apply shiftpos_below. subst s0; simpl; extlia. subst s0; simpl; auto. - intros. apply H8; auto. subst s0; simpl in H11; xomega. + intros. apply H8; auto. subst s0; simpl in H11; extlia. intros. apply H8. apply shiftpos_above. assert (Ple pc0 (max_pc_function f)). eapply max_pc_function_sound. eapply PTree.elements_complete; eauto. - eapply Pos.lt_le_trans. apply shiftpos_below. inversion i; xomega. + eapply Pos.lt_le_trans. apply shiftpos_below. inversion i; extlia. apply PTree.elements_correct; auto. auto. auto. auto. - inversion INCR0. subst s0; simpl in STKSIZE; xomega. + inversion INCR0. subst s0; simpl in STKSIZE; extlia. Qed. End EXPAND_INSTR. @@ -721,12 +721,12 @@ Opaque initstate. apply funenv_program_compat. eapply expand_cfg_spec with (fe := fenv); eauto. red; auto. - unfold ctx; rewrite <- H1; rewrite <- H2; rewrite <- H3; simpl. xomega. - unfold ctx; rewrite <- H0; rewrite <- H1; simpl. xomega. - simpl. xomega. + unfold ctx; rewrite <- H1; rewrite <- H2; rewrite <- H3; simpl. extlia. + unfold ctx; rewrite <- H0; rewrite <- H1; simpl. extlia. + simpl. extlia. simpl. apply Z.divide_0_r. - simpl. omega. - simpl. omega. + simpl. lia. + simpl. lia. simpl. split; auto. destruct INCR2. destruct INCR1. destruct INCR0. destruct INCR. - simpl. change 0 with (st_stksize initstate). omega. + simpl. change 0 with (st_stksize initstate). lia. Qed. diff --git a/backend/JsonAST.ml b/backend/JsonAST.ml index 8905e252..8ab874b1 100644 --- a/backend/JsonAST.ml +++ b/backend/JsonAST.ml @@ -21,14 +21,22 @@ open Sections let pp_storage pp static = pp_jstring pp (if static then "Static" else "Extern") +let pp_init pp init = + pp_jstring pp + (match init with + | Uninit -> "Uninit" + | Init -> "Init" + | Init_reloc -> "Init_reloc") + let pp_section pp sec = let pp_simple name = pp_jsingle_object pp "Section Name" pp_jstring name and pp_complex name init = pp_jobject_start pp; pp_jmember ~first:true pp "Section Name" pp_jstring name; - pp_jmember pp "Init" pp_jbool init; + pp_jmember pp "Init" pp_init init; pp_jobject_end pp in + match sec with | Section_text -> pp_simple "Text" | Section_data init -> pp_complex "Data" init @@ -106,11 +114,17 @@ let pp_program pp pp_inst prog = let prog_vars,prog_funs = List.fold_left (fun (vars,funs) (ident,def) -> match def with | Gfun (Internal f) -> + (* No assembly is generated for non static inline functions *) if not (atom_is_iso_inline_definition ident) then vars,(ident,f)::funs else vars,funs - | Gvar v -> (ident,v)::vars,funs + | Gvar v -> + (* No assembly is generated for variables without init *) + if v.gvar_init <> [] then + (ident,v)::vars,funs + else + vars, funs | _ -> vars,funs) ([],[]) prog.prog_defs in pp_jobject_start pp; pp_jmember ~first:true pp "Global Variables" (pp_jarray pp_vardef) prog_vars; diff --git a/backend/Linearizeproof.v b/backend/Linearizeproof.v index 10a3d8b2..b065238c 100644 --- a/backend/Linearizeproof.v +++ b/backend/Linearizeproof.v @@ -642,7 +642,7 @@ Proof. (* Lbranch *) assert ((reachable f)!!pc = true). apply REACH; simpl; auto. - right; split. simpl; omega. split. auto. simpl. econstructor; eauto. + right; split. simpl; lia. split. auto. simpl. econstructor; eauto. (* Lcond *) assert (REACH1: (reachable f)!!pc1 = true) by (apply REACH; simpl; auto). @@ -659,12 +659,12 @@ Proof. rewrite eval_negate_condition. rewrite H. auto. eauto. rewrite DC. econstructor; eauto. (* cond is false: branch is taken *) - right; split. simpl; omega. split. auto. rewrite <- DC. econstructor; eauto. + right; split. simpl; lia. split. auto. rewrite <- DC. econstructor; eauto. rewrite eval_negate_condition. rewrite H. auto. (* branch if cond is true *) destruct b. (* cond is true: branch is taken *) - right; split. simpl; omega. split. auto. econstructor; eauto. + right; split. simpl; lia. split. auto. econstructor; eauto. (* cond is false: no branch *) left; econstructor; split. apply plus_one. eapply exec_Lcond_false. eauto. eauto. @@ -673,7 +673,7 @@ Proof. (* Ljumptable *) assert (REACH': (reachable f)!!pc = true). apply REACH. simpl. eapply list_nth_z_in; eauto. - right; split. simpl; omega. split. auto. econstructor; eauto. + right; split. simpl; lia. split. auto. econstructor; eauto. (* Lreturn *) left; econstructor; split. diff --git a/backend/Locations.v b/backend/Locations.v index c437df5d..2a3ae1d7 100644 --- a/backend/Locations.v +++ b/backend/Locations.v @@ -157,7 +157,7 @@ Module Loc. forall l, ~(diff l l). Proof. destruct l; unfold diff; auto. - red; intros. destruct H; auto. generalize (typesize_pos ty); omega. + red; intros. destruct H; auto. generalize (typesize_pos ty); lia. Qed. Lemma diff_not_eq: @@ -184,7 +184,7 @@ Module Loc. left; auto. destruct (zle (pos0 + typesize ty0) pos). left; auto. - right; red; intros [P | [P | P]]. congruence. omega. omega. + right; red; intros [P | [P | P]]. congruence. lia. lia. left; auto. Defined. @@ -497,7 +497,7 @@ Module OrderedLoc <: OrderedType. destruct x. eelim Plt_strict; eauto. destruct H. eelim OrderedSlot.lt_not_eq; eauto. red; auto. - destruct H. destruct H0. omega. + destruct H. destruct H0. lia. destruct H0. eelim OrderedTyp.lt_not_eq; eauto. red; auto. Qed. Definition compare : forall x y : t, Compare lt eq x y. @@ -545,18 +545,18 @@ Module OrderedLoc <: OrderedType. { destruct H. apply not_eq_sym. apply Plt_ne; auto. apply Plt_ne; auto. } congruence. - assert (RANGE: forall ty, 1 <= typesize ty <= 2). - { intros; unfold typesize. destruct ty0; omega. } + { intros; unfold typesize. destruct ty0; lia. } destruct H. + destruct H. left. apply not_eq_sym. apply OrderedSlot.lt_not_eq; auto. destruct H. right. - destruct H0. right. generalize (RANGE ty'); omega. + destruct H0. right. generalize (RANGE ty'); lia. destruct H0. assert (ty' = Tint \/ ty' = Tsingle \/ ty' = Tany32). { unfold OrderedTyp.lt in H1. destruct ty'; auto; compute in H1; congruence. } - right. destruct H2 as [E|[E|E]]; subst ty'; simpl typesize; omega. + right. destruct H2 as [E|[E|E]]; subst ty'; simpl typesize; lia. + destruct H. left. apply OrderedSlot.lt_not_eq; auto. destruct H. right. - destruct H0. left; omega. + destruct H0. left; lia. destruct H0. exfalso. destruct ty'; compute in H1; congruence. Qed. @@ -572,14 +572,14 @@ Module OrderedLoc <: OrderedType. - destruct (OrderedSlot.compare sl sl'); auto. destruct H. contradiction. destruct H. - right; right; split; auto. left; omega. + right; right; split; auto. left; lia. left; right; split; auto. assert (EITHER: typesize ty' = 1 /\ OrderedTyp.lt ty' Tany64 \/ typesize ty' = 2). { destruct ty'; compute; auto. } destruct (zlt ofs' (ofs - 1)). left; auto. destruct EITHER as [[P Q] | P]. - right; split; auto. omega. - left; omega. + right; split; auto. lia. + left; lia. Qed. End OrderedLoc. diff --git a/backend/NeedDomain.v b/backend/NeedDomain.v index d9e9e025..62b8ff90 100644 --- a/backend/NeedDomain.v +++ b/backend/NeedDomain.v @@ -74,7 +74,7 @@ Proof. intros. simpl in H. auto. Qed. -Hint Resolve vagree_same vagree_lessdef lessdef_vagree: na. +Global Hint Resolve vagree_same vagree_lessdef lessdef_vagree: na. Inductive vagree_list: list val -> list val -> list nval -> Prop := | vagree_list_nil: forall nvl, @@ -100,7 +100,7 @@ Proof. destruct nvl; constructor; auto with na. Qed. -Hint Resolve lessdef_vagree_list vagree_lessdef_list: na. +Global Hint Resolve lessdef_vagree_list vagree_lessdef_list: na. (** ** Ordering and least upper bound between value needs *) @@ -116,8 +116,8 @@ Proof. destruct x; constructor; auto. Qed. -Hint Constructors nge: na. -Hint Resolve nge_refl: na. +Global Hint Constructors nge: na. +Global Hint Resolve nge_refl: na. Lemma nge_trans: forall x y, nge x y -> forall z, nge y z -> nge x z. Proof. @@ -240,9 +240,9 @@ Proof. destruct (zlt i (Int.unsigned n)). - auto. - generalize (Int.unsigned_range n); intros. - apply H. omega. rewrite Int.bits_shru by omega. - replace (i - Int.unsigned n + Int.unsigned n) with i by omega. - rewrite zlt_true by omega. auto. + apply H. lia. rewrite Int.bits_shru by lia. + replace (i - Int.unsigned n + Int.unsigned n) with i by lia. + rewrite zlt_true by lia. auto. Qed. Lemma iagree_shru: @@ -252,9 +252,9 @@ Proof. intros; red; intros. autorewrite with ints; auto. destruct (zlt (i + Int.unsigned n) Int.zwordsize). - generalize (Int.unsigned_range n); intros. - apply H. omega. rewrite Int.bits_shl by omega. - replace (i + Int.unsigned n - Int.unsigned n) with i by omega. - rewrite zlt_false by omega. auto. + apply H. lia. rewrite Int.bits_shl by lia. + replace (i + Int.unsigned n - Int.unsigned n) with i by lia. + rewrite zlt_false by lia. auto. - auto. Qed. @@ -266,7 +266,7 @@ Proof. intros; red; intros. rewrite <- H in H2. rewrite Int.bits_shru in H2 by auto. rewrite ! Int.bits_shr by auto. destruct (zlt (i + Int.unsigned n) Int.zwordsize). -- apply H0; auto. generalize (Int.unsigned_range n); omega. +- apply H0; auto. generalize (Int.unsigned_range n); lia. - discriminate. Qed. @@ -281,11 +281,11 @@ Proof. then i + Int.unsigned n else Int.zwordsize - 1). assert (0 <= j < Int.zwordsize). - { unfold j; destruct (zlt (i + Int.unsigned n) Int.zwordsize); omega. } + { unfold j; destruct (zlt (i + Int.unsigned n) Int.zwordsize); lia. } apply H; auto. autorewrite with ints; auto. apply orb_true_intro. unfold j; destruct (zlt (i + Int.unsigned n) Int.zwordsize). -- left. rewrite zlt_false by omega. - replace (i + Int.unsigned n - Int.unsigned n) with i by omega. +- left. rewrite zlt_false by lia. + replace (i + Int.unsigned n - Int.unsigned n) with i by lia. auto. - right. reflexivity. Qed. @@ -303,7 +303,7 @@ Proof. mod Int.zwordsize) with i. auto. apply eqmod_small_eq with Int.zwordsize; auto. apply eqmod_trans with ((i - Int.unsigned amount) + Int.unsigned amount). - apply eqmod_refl2; omega. + apply eqmod_refl2; lia. eapply eqmod_trans. 2: apply eqmod_mod; auto. apply eqmod_add. apply eqmod_mod; auto. @@ -330,12 +330,12 @@ Lemma eqmod_iagree: Proof. intros. set (p := Z.to_nat (Int.size m)). generalize (Int.size_range m); intros RANGE. - assert (EQ: Int.size m = Z.of_nat p). { symmetry; apply Z2Nat.id. omega. } + assert (EQ: Int.size m = Z.of_nat p). { symmetry; apply Z2Nat.id. lia. } rewrite EQ in H; rewrite <- two_power_nat_two_p in H. red; intros. rewrite ! Int.testbit_repr by auto. destruct (zlt i (Int.size m)). - eapply same_bits_eqmod; eauto. omega. - assert (Int.testbit m i = false) by (eapply Int.bits_size_2; omega). + eapply same_bits_eqmod; eauto. lia. + assert (Int.testbit m i = false) by (eapply Int.bits_size_2; lia). congruence. Qed. @@ -348,11 +348,11 @@ Lemma iagree_eqmod: Proof. intros. set (p := Z.to_nat (Int.size m)). generalize (Int.size_range m); intros RANGE. - assert (EQ: Int.size m = Z.of_nat p). { symmetry; apply Z2Nat.id. omega. } + assert (EQ: Int.size m = Z.of_nat p). { symmetry; apply Z2Nat.id. lia. } rewrite EQ; rewrite <- two_power_nat_two_p. - apply eqmod_same_bits. intros. apply H. omega. - unfold complete_mask. rewrite Int.bits_zero_ext by omega. - rewrite zlt_true by omega. rewrite Int.bits_mone by omega. auto. + apply eqmod_same_bits. intros. apply H. lia. + unfold complete_mask. rewrite Int.bits_zero_ext by lia. + rewrite zlt_true by lia. rewrite Int.bits_mone by lia. auto. Qed. Lemma complete_mask_idem: @@ -363,12 +363,12 @@ Proof. + assert (Int.unsigned m <> 0). { red; intros; elim n. rewrite <- (Int.repr_unsigned m). rewrite H; auto. } assert (0 < Int.size m). - { apply Zsize_pos'. generalize (Int.unsigned_range m); omega. } + { apply Zsize_pos'. generalize (Int.unsigned_range m); lia. } generalize (Int.size_range m); intros. f_equal. apply Int.bits_size_4. tauto. - rewrite Int.bits_zero_ext by omega. rewrite zlt_true by omega. - apply Int.bits_mone; omega. - intros. rewrite Int.bits_zero_ext by omega. apply zlt_false; omega. + rewrite Int.bits_zero_ext by lia. rewrite zlt_true by lia. + apply Int.bits_mone; lia. + intros. rewrite Int.bits_zero_ext by lia. apply zlt_false; lia. Qed. (** ** Abstract operations over value needs. *) @@ -676,12 +676,12 @@ Proof. destruct x; simpl in *. - auto. - unfold Val.zero_ext; InvAgree. - red; intros. autorewrite with ints; try omega. + red; intros. autorewrite with ints; try lia. destruct (zlt i1 n); auto. apply H; auto. - autorewrite with ints; try omega. rewrite zlt_true; auto. + autorewrite with ints; try lia. rewrite zlt_true; auto. - unfold Val.zero_ext; InvAgree; auto. apply Val.lessdef_same. f_equal. - Int.bit_solve; try omega. destruct (zlt i1 n); auto. apply H; auto. - autorewrite with ints; try omega. apply zlt_true; auto. + Int.bit_solve; try lia. destruct (zlt i1 n); auto. apply H; auto. + autorewrite with ints; try lia. apply zlt_true; auto. Qed. Definition sign_ext (n: Z) (x: nval) := @@ -700,25 +700,25 @@ Proof. unfold sign_ext; intros. destruct x; simpl in *. - auto. - unfold Val.sign_ext; InvAgree. - red; intros. autorewrite with ints; try omega. + red; intros. autorewrite with ints; try lia. set (j := if zlt i1 n then i1 else n - 1). assert (0 <= j < Int.zwordsize). - { unfold j; destruct (zlt i1 n); omega. } + { unfold j; destruct (zlt i1 n); lia. } apply H; auto. - autorewrite with ints; try omega. apply orb_true_intro. + autorewrite with ints; try lia. apply orb_true_intro. unfold j; destruct (zlt i1 n). left. rewrite zlt_true; auto. - right. rewrite Int.unsigned_repr. rewrite zlt_false by omega. - replace (n - 1 - (n - 1)) with 0 by omega. reflexivity. - generalize Int.wordsize_max_unsigned; omega. + right. rewrite Int.unsigned_repr. rewrite zlt_false by lia. + replace (n - 1 - (n - 1)) with 0 by lia. reflexivity. + generalize Int.wordsize_max_unsigned; lia. - unfold Val.sign_ext; InvAgree; auto. apply Val.lessdef_same. f_equal. - Int.bit_solve; try omega. + Int.bit_solve; try lia. set (j := if zlt i1 n then i1 else n - 1). assert (0 <= j < Int.zwordsize). - { unfold j; destruct (zlt i1 n); omega. } - apply H; auto. rewrite Int.bits_zero_ext; try omega. + { unfold j; destruct (zlt i1 n); lia. } + apply H; auto. rewrite Int.bits_zero_ext; try lia. rewrite zlt_true. apply Int.bits_mone; auto. - unfold j. destruct (zlt i1 n); omega. + unfold j. destruct (zlt i1 n); lia. Qed. (** The needs of a memory store concerning the value being stored. *) @@ -737,7 +737,7 @@ Lemma store_argument_sound: Proof. intros. assert (UNDEF: list_forall2 memval_lessdef - (list_repeat (size_chunk_nat chunk) Undef) + (List.repeat Undef (size_chunk_nat chunk)) (encode_val chunk w)). { rewrite <- (encode_val_length chunk w). @@ -778,11 +778,11 @@ Proof. - apply sign_ext_sound with (v := Vint i) (w := Vint i0) (x := All) (n := 8). auto. compute; auto. - apply zero_ext_sound with (v := Vint i) (w := Vint i0) (x := All) (n := 8). - auto. omega. + auto. lia. - apply sign_ext_sound with (v := Vint i) (w := Vint i0) (x := All) (n := 16). auto. compute; auto. - apply zero_ext_sound with (v := Vint i) (w := Vint i0) (x := All) (n := 16). - auto. omega. + auto. lia. Qed. (** The needs of a comparison *) @@ -1014,9 +1014,9 @@ Proof. unfold zero_ext_redundant; intros. destruct x; try discriminate. - auto. - simpl in *; InvAgree. simpl. InvBooleans. rewrite <- H. - red; intros; autorewrite with ints; try omega. + red; intros; autorewrite with ints; try lia. destruct (zlt i1 n). apply H0; auto. - rewrite Int.bits_zero_ext in H3 by omega. rewrite zlt_false in H3 by auto. discriminate. + rewrite Int.bits_zero_ext in H3 by lia. rewrite zlt_false in H3 by auto. discriminate. Qed. Definition sign_ext_redundant (n: Z) (x: nval) := @@ -1036,10 +1036,10 @@ Proof. unfold sign_ext_redundant; intros. destruct x; try discriminate. - auto. - simpl in *; InvAgree. simpl. InvBooleans. rewrite <- H. - red; intros; autorewrite with ints; try omega. + red; intros; autorewrite with ints; try lia. destruct (zlt i1 n). apply H0; auto. rewrite Int.bits_or; auto. rewrite H3; auto. - rewrite Int.bits_zero_ext in H3 by omega. rewrite zlt_false in H3 by auto. discriminate. + rewrite Int.bits_zero_ext in H3 by lia. rewrite zlt_false in H3 by auto. discriminate. Qed. (** * Neededness for register environments *) @@ -1084,7 +1084,7 @@ Proof. intros. apply H. Qed. -Hint Resolve nreg_agree: na. +Global Hint Resolve nreg_agree: na. Lemma eagree_ge: forall e1 e2 ne ne', @@ -1300,13 +1300,13 @@ Proof. split; simpl; auto; intros. rewrite PTree.gsspec in H6. destruct (peq id0 id). + inv H6. destruct H3. congruence. destruct gl!id as [iv0|] eqn:NG. - unfold iv'; rewrite ISet.In_add. intros [P|P]. omega. eelim GL; eauto. - unfold iv'; rewrite ISet.In_interval. omega. + unfold iv'; rewrite ISet.In_add. intros [P|P]. lia. eelim GL; eauto. + unfold iv'; rewrite ISet.In_interval. lia. + eauto. - (* Stk ofs *) split; simpl; auto; intros. destruct H3. elim H3. subst b'. eapply bc_stack; eauto. - rewrite ISet.In_add. intros [P|P]. omega. eapply STK; eauto. + rewrite ISet.In_add. intros [P|P]. lia. eapply STK; eauto. Qed. (** Test (conservatively) whether some locations in the range delimited diff --git a/backend/PrintAsm.ml b/backend/PrintAsm.ml index 155f5e55..22df68ae 100644 --- a/backend/PrintAsm.ml +++ b/backend/PrintAsm.ml @@ -121,7 +121,7 @@ module Printer(Target:TARGET) = let sec = match C2C.atom_sections name with | [s] -> s - | _ -> Section_data true + | _ -> Section_data Init and align = match C2C.atom_alignof name with | Some a -> a diff --git a/backend/PrintAsmaux.ml b/backend/PrintAsmaux.ml index d31507ff..e39ba8aa 100644 --- a/backend/PrintAsmaux.ml +++ b/backend/PrintAsmaux.ml @@ -303,11 +303,28 @@ let print_version_and_options oc comment = fprintf oc " %s" Commandline.argv.(i) done; fprintf oc "\n" -(** Get the name of the common section if it is used otherwise the given section - name, with bss as default *) -let common_section ?(sec = ".bss") () = - if !Clflags.option_fcommon then - "COMM" - else - sec +(** Determine the name of the section to use for a variable. + - [i] is the initialization status of the variable. + - [sec] is the name of the section to use if initialized (with no + relocations) or if no other cases apply. + - [reloc] is the name of the section to use if initialized and + containing relocations. If not provided, [sec] is used. + - [bss] is the name of the section to use if uninitialized and + common declarations are not used. If not provided, [sec] is used. + - [common] says whether common declarations can be used for uninitialized + variables. It defaults to the status of the [-fcommon] / [-fno-common] + command-line option. Passing [~common:false] is needed when + common declarations cannot be used at all, for example in the context of + small data areas. +*) + +let variable_section ~sec ?bss ?reloc ?(common = !Clflags.option_fcommon) i = + match i with + | Uninit -> + if common + then "COMM" + else begin match bss with Some s -> s | None -> sec end + | Init -> sec + | Init_reloc -> + begin match reloc with Some s -> s | None -> sec end diff --git a/backend/PrintCminor.ml b/backend/PrintCminor.ml index c9a6d399..59b340f7 100644 --- a/backend/PrintCminor.ml +++ b/backend/PrintCminor.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/backend/RTL.v b/backend/RTL.v index 9599a24a..a022f55a 100644 --- a/backend/RTL.v +++ b/backend/RTL.v @@ -352,7 +352,7 @@ Proof. exploit external_call_receptive; eauto. intros [vres2 [m2 EC2]]. exists (Returnstate s0 vres2 m2). econstructor; eauto. (* trace length *) - red; intros; inv H; simpl; try omega. + red; intros; inv H; simpl; try lia. eapply external_call_trace_length; eauto. eapply external_call_trace_length; eauto. Qed. @@ -450,8 +450,8 @@ Proof. rewrite PTree.gempty. congruence. (* inductive case *) intros. rewrite PTree.gsspec in H2. destruct (peq pc k). - inv H2. xomega. - apply Ple_trans with a. auto. xomega. + inv H2. extlia. + apply Ple_trans with a. auto. extlia. Qed. (** Maximum pseudo-register mentioned in a function. All results or arguments @@ -489,9 +489,9 @@ Proof. assert (X: forall l n, Ple m n -> Ple m (fold_left Pos.max l n)). { induction l; simpl; intros. auto. - apply IHl. xomega. } - destruct i; simpl; try (destruct s0); repeat (apply X); try xomega. - destruct o; xomega. + apply IHl. extlia. } + destruct i; simpl; try (destruct s0); repeat (apply X); try extlia. + destruct o; extlia. Qed. Remark max_reg_instr_def: @@ -499,12 +499,12 @@ Remark max_reg_instr_def: Proof. intros. assert (X: forall l n, Ple r n -> Ple r (fold_left Pos.max l n)). - { induction l; simpl; intros. xomega. apply IHl. xomega. } + { induction l; simpl; intros. extlia. apply IHl. extlia. } destruct i; simpl in *; inv H. -- apply X. xomega. -- apply X. xomega. -- destruct s0; apply X; xomega. -- destruct b; inv H1. apply X. simpl. xomega. +- apply X. extlia. +- apply X. extlia. +- destruct s0; apply X; extlia. +- destruct b; inv H1. apply X. simpl. extlia. Qed. Remark max_reg_instr_uses: @@ -514,14 +514,14 @@ Proof. assert (X: forall l n, In r l \/ Ple r n -> Ple r (fold_left Pos.max l n)). { induction l; simpl; intros. tauto. - apply IHl. destruct H0 as [[A|A]|A]. right; subst; xomega. auto. right; xomega. } + apply IHl. destruct H0 as [[A|A]|A]. right; subst; extlia. auto. right; extlia. } destruct i; simpl in *; try (destruct s0); try (apply X; auto). - contradiction. -- destruct H. right; subst; xomega. auto. -- destruct H. right; subst; xomega. auto. -- destruct H. right; subst; xomega. auto. -- intuition. subst; xomega. -- destruct o; simpl in H; intuition. subst; xomega. +- destruct H. right; subst; extlia. auto. +- destruct H. right; subst; extlia. auto. +- destruct H. right; subst; extlia. auto. +- intuition. subst; extlia. +- destruct o; simpl in H; intuition. subst; extlia. Qed. Lemma max_reg_function_def: @@ -539,7 +539,7 @@ Proof. + inv H3. eapply max_reg_instr_def; eauto. + apply Ple_trans with a. auto. apply max_reg_instr_ge. } - unfold max_reg_function. xomega. + unfold max_reg_function. extlia. Qed. Lemma max_reg_function_use: @@ -557,7 +557,7 @@ Proof. + inv H3. eapply max_reg_instr_uses; eauto. + apply Ple_trans with a. auto. apply max_reg_instr_ge. } - unfold max_reg_function. xomega. + unfold max_reg_function. extlia. Qed. Lemma max_reg_function_params: @@ -567,8 +567,8 @@ Proof. assert (X: forall l n, In r l \/ Ple r n -> Ple r (fold_left Pos.max l n)). { induction l; simpl; intros. tauto. - apply IHl. destruct H0 as [[A|A]|A]. right; subst; xomega. auto. right; xomega. } + apply IHl. destruct H0 as [[A|A]|A]. right; subst; extlia. auto. right; extlia. } assert (Y: Ple r (fold_left Pos.max f.(fn_params) 1%positive)). { apply X; auto. } - unfold max_reg_function. xomega. + unfold max_reg_function. extlia. Qed. diff --git a/backend/RTLgenproof.v b/backend/RTLgenproof.v index b94ec22f..1602823f 100644 --- a/backend/RTLgenproof.v +++ b/backend/RTLgenproof.v @@ -165,7 +165,7 @@ Proof. subst r0; contradiction. apply Regmap.gso; auto. Qed. -Hint Resolve match_env_update_temp: rtlg. +Global Hint Resolve match_env_update_temp: rtlg. (** Matching between environments is preserved by simultaneous assignment to a Cminor local variable (in the Cminor environments) @@ -205,7 +205,7 @@ Proof. eapply match_env_update_temp; eauto. eapply match_env_update_var; eauto. Qed. -Hint Resolve match_env_update_dest: rtlg. +Global Hint Resolve match_env_update_dest: rtlg. (** A variant of [match_env_update_var] corresponding to the assignment of the result of a builtin. *) @@ -1145,7 +1145,7 @@ Proof. Qed. Ltac Lt_state := - apply lt_state_intro; simpl; try omega. + apply lt_state_intro; simpl; try lia. Lemma lt_state_wf: well_founded lt_state. diff --git a/backend/RTLgenspec.v b/backend/RTLgenspec.v index 72693f63..25f9954c 100644 --- a/backend/RTLgenspec.v +++ b/backend/RTLgenspec.v @@ -128,7 +128,7 @@ Ltac monadInv H := (** * Monotonicity properties of the state *) -Hint Resolve state_incr_refl: rtlg. +Global Hint Resolve state_incr_refl: rtlg. Lemma instr_at_incr: forall s1 s2 n i, @@ -137,7 +137,7 @@ Proof. intros. inv H. destruct (H3 n); congruence. Qed. -Hint Resolve instr_at_incr: rtlg. +Global Hint Resolve instr_at_incr: rtlg. (** The following tactic saturates the hypotheses with [state_incr] properties that follow by transitivity from @@ -174,14 +174,14 @@ Lemma valid_fresh_absurd: Proof. intros r s. unfold reg_valid, reg_fresh; case r; tauto. Qed. -Hint Resolve valid_fresh_absurd: rtlg. +Global Hint Resolve valid_fresh_absurd: rtlg. Lemma valid_fresh_different: forall r1 r2 s, reg_valid r1 s -> reg_fresh r2 s -> r1 <> r2. Proof. unfold not; intros. subst r2. eauto with rtlg. Qed. -Hint Resolve valid_fresh_different: rtlg. +Global Hint Resolve valid_fresh_different: rtlg. Lemma reg_valid_incr: forall r s1 s2, state_incr s1 s2 -> reg_valid r s1 -> reg_valid r s2. @@ -190,7 +190,7 @@ Proof. inversion INCR. unfold reg_valid. intros; apply Plt_Ple_trans with (st_nextreg s1); auto. Qed. -Hint Resolve reg_valid_incr: rtlg. +Global Hint Resolve reg_valid_incr: rtlg. Lemma reg_fresh_decr: forall r s1 s2, state_incr s1 s2 -> reg_fresh r s2 -> reg_fresh r s1. @@ -199,7 +199,7 @@ Proof. unfold reg_fresh; unfold not; intros. apply H4. apply Plt_Ple_trans with (st_nextreg s1); auto. Qed. -Hint Resolve reg_fresh_decr: rtlg. +Global Hint Resolve reg_fresh_decr: rtlg. (** Validity of a list of registers. *) @@ -211,7 +211,7 @@ Lemma regs_valid_nil: Proof. intros; red; intros. elim H. Qed. -Hint Resolve regs_valid_nil: rtlg. +Global Hint Resolve regs_valid_nil: rtlg. Lemma regs_valid_cons: forall r1 rl s, @@ -232,7 +232,7 @@ Lemma regs_valid_incr: Proof. unfold regs_valid; intros; eauto with rtlg. Qed. -Hint Resolve regs_valid_incr: rtlg. +Global Hint Resolve regs_valid_incr: rtlg. (** A register is ``in'' a mapping if it is associated with a Cminor local or let-bound variable. *) @@ -253,7 +253,7 @@ Lemma map_valid_incr: Proof. unfold map_valid; intros; eauto with rtlg. Qed. -Hint Resolve map_valid_incr: rtlg. +Global Hint Resolve map_valid_incr: rtlg. (** * Properties of basic operations over the state *) @@ -265,7 +265,7 @@ Lemma add_instr_at: Proof. intros. monadInv H. simpl. apply PTree.gss. Qed. -Hint Resolve add_instr_at: rtlg. +Global Hint Resolve add_instr_at: rtlg. (** Properties of [update_instr]. *) @@ -278,7 +278,7 @@ Proof. destruct (check_empty_node s1 n); try discriminate. inv H. simpl. apply PTree.gss. Qed. -Hint Resolve update_instr_at: rtlg. +Global Hint Resolve update_instr_at: rtlg. (** Properties of [new_reg]. *) @@ -289,7 +289,7 @@ Proof. intros. monadInv H. unfold reg_valid; simpl. apply Plt_succ. Qed. -Hint Resolve new_reg_valid: rtlg. +Global Hint Resolve new_reg_valid: rtlg. Lemma new_reg_fresh: forall s1 s2 r i, @@ -299,7 +299,7 @@ Proof. unfold reg_fresh; simpl. exact (Plt_strict _). Qed. -Hint Resolve new_reg_fresh: rtlg. +Global Hint Resolve new_reg_fresh: rtlg. Lemma new_reg_not_in_map: forall s1 s2 m r i, @@ -307,7 +307,7 @@ Lemma new_reg_not_in_map: Proof. unfold not; intros; eauto with rtlg. Qed. -Hint Resolve new_reg_not_in_map: rtlg. +Global Hint Resolve new_reg_not_in_map: rtlg. (** * Properties of operations over compilation environments *) @@ -330,7 +330,7 @@ Proof. intros. inv H0. left; exists name; auto. intros. inv H0. Qed. -Hint Resolve find_var_in_map: rtlg. +Global Hint Resolve find_var_in_map: rtlg. Lemma find_var_valid: forall s1 s2 map name r i, @@ -338,7 +338,7 @@ Lemma find_var_valid: Proof. eauto with rtlg. Qed. -Hint Resolve find_var_valid: rtlg. +Global Hint Resolve find_var_valid: rtlg. (** Properties of [find_letvar]. *) @@ -350,7 +350,7 @@ Proof. caseEq (nth_error (map_letvars map) idx); intros; monadInv H0. right; apply nth_error_in with idx; auto. Qed. -Hint Resolve find_letvar_in_map: rtlg. +Global Hint Resolve find_letvar_in_map: rtlg. Lemma find_letvar_valid: forall s1 s2 map idx r i, @@ -358,7 +358,7 @@ Lemma find_letvar_valid: Proof. eauto with rtlg. Qed. -Hint Resolve find_letvar_valid: rtlg. +Global Hint Resolve find_letvar_valid: rtlg. (** Properties of [add_var]. *) @@ -445,7 +445,7 @@ Proof. intros until r. unfold alloc_reg. case a; eauto with rtlg. Qed. -Hint Resolve alloc_reg_valid: rtlg. +Global Hint Resolve alloc_reg_valid: rtlg. Lemma alloc_reg_fresh_or_in_map: forall map a s r s' i, @@ -469,7 +469,7 @@ Proof. apply regs_valid_nil. apply regs_valid_cons. eauto with rtlg. eauto with rtlg. Qed. -Hint Resolve alloc_regs_valid: rtlg. +Global Hint Resolve alloc_regs_valid: rtlg. Lemma alloc_regs_fresh_or_in_map: forall map al s rl s' i, @@ -494,7 +494,7 @@ Proof. intros until r. unfold alloc_reg. case dest; eauto with rtlg. Qed. -Hint Resolve alloc_optreg_valid: rtlg. +Global Hint Resolve alloc_optreg_valid: rtlg. Lemma alloc_optreg_fresh_or_in_map: forall map dest s r s' i, @@ -609,7 +609,7 @@ Proof. apply regs_valid_cons; eauto with rtlg. Qed. -Hint Resolve new_reg_target_ok alloc_reg_target_ok +Global Hint Resolve new_reg_target_ok alloc_reg_target_ok alloc_regs_target_ok: rtlg. (** The following predicate is a variant of [target_reg_ok] used @@ -631,7 +631,7 @@ Lemma return_reg_ok_incr: Proof. induction 1; intros; econstructor; eauto with rtlg. Qed. -Hint Resolve return_reg_ok_incr: rtlg. +Global Hint Resolve return_reg_ok_incr: rtlg. Lemma new_reg_return_ok: forall s1 r s2 map sig i, @@ -676,7 +676,7 @@ Inductive reg_map_ok: mapping -> reg -> option ident -> Prop := map.(map_vars)!id = Some rd -> reg_map_ok map rd (Some id). -Hint Resolve reg_map_ok_novar: rtlg. +Global Hint Resolve reg_map_ok_novar: rtlg. (** [tr_expr c map pr expr ns nd rd optid] holds if the graph [c], between nodes [ns] and [nd], contains instructions that compute the diff --git a/backend/SelectDivproof.v b/backend/SelectDivproof.v index c57d3652..9d581ec9 100644 --- a/backend/SelectDivproof.v +++ b/backend/SelectDivproof.v @@ -44,55 +44,55 @@ Proof. set (r := n mod d). intro EUCL. assert (0 <= r <= d - 1). - unfold r. generalize (Z_mod_lt n d d_pos). omega. + unfold r. generalize (Z_mod_lt n d d_pos). lia. assert (0 <= m). apply Zmult_le_0_reg_r with d. auto. - exploit (two_p_gt_ZERO (N + l)). omega. omega. + exploit (two_p_gt_ZERO (N + l)). lia. lia. set (k := m * d - two_p (N + l)). assert (0 <= k <= two_p l). - unfold k; omega. + unfold k; lia. assert ((m * n - two_p (N + l) * q) * d = k * n + two_p (N + l) * r). unfold k. rewrite EUCL. ring. assert (0 <= k * n). - apply Z.mul_nonneg_nonneg; omega. + apply Z.mul_nonneg_nonneg; lia. assert (k * n <= two_p (N + l) - two_p l). apply Z.le_trans with (two_p l * n). - apply Z.mul_le_mono_nonneg_r; omega. - replace (N + l) with (l + N) by omega. + apply Z.mul_le_mono_nonneg_r; lia. + replace (N + l) with (l + N) by lia. rewrite two_p_is_exp. replace (two_p l * two_p N - two_p l) with (two_p l * (two_p N - 1)) by ring. - apply Z.mul_le_mono_nonneg_l. omega. exploit (two_p_gt_ZERO l). omega. omega. - omega. omega. + apply Z.mul_le_mono_nonneg_l. lia. exploit (two_p_gt_ZERO l). lia. lia. + lia. lia. assert (0 <= two_p (N + l) * r). apply Z.mul_nonneg_nonneg. - exploit (two_p_gt_ZERO (N + l)). omega. omega. - omega. + exploit (two_p_gt_ZERO (N + l)). lia. lia. + lia. assert (two_p (N + l) * r <= two_p (N + l) * d - two_p (N + l)). replace (two_p (N + l) * d - two_p (N + l)) with (two_p (N + l) * (d - 1)) by ring. apply Z.mul_le_mono_nonneg_l. - omega. - exploit (two_p_gt_ZERO (N + l)). omega. omega. + lia. + exploit (two_p_gt_ZERO (N + l)). lia. lia. assert (0 <= m * n - two_p (N + l) * q). apply Zmult_le_reg_r with d. auto. - replace (0 * d) with 0 by ring. rewrite H2. omega. + replace (0 * d) with 0 by ring. rewrite H2. lia. assert (m * n - two_p (N + l) * q < two_p (N + l)). - apply Zmult_lt_reg_r with d. omega. + apply Zmult_lt_reg_r with d. lia. rewrite H2. apply Z.le_lt_trans with (two_p (N + l) * d - two_p l). - omega. - exploit (two_p_gt_ZERO l). omega. omega. + lia. + exploit (two_p_gt_ZERO l). lia. lia. symmetry. apply Zdiv_unique with (m * n - two_p (N + l) * q). - ring. omega. + ring. lia. Qed. Lemma Zdiv_unique_2: forall x y q, y > 0 -> 0 < y * q - x <= y -> Z.div x y = q - 1. Proof. intros. apply Zdiv_unique with (x - (q - 1) * y). ring. - replace ((q - 1) * y) with (y * q - y) by ring. omega. + replace ((q - 1) * y) with (y * q - y) by ring. lia. Qed. Lemma Zdiv_mul_opp: @@ -110,42 +110,42 @@ Proof. set (r := n mod d). intro EUCL. assert (0 <= r <= d - 1). - unfold r. generalize (Z_mod_lt n d d_pos). omega. + unfold r. generalize (Z_mod_lt n d d_pos). lia. assert (0 <= m). apply Zmult_le_0_reg_r with d. auto. - exploit (two_p_gt_ZERO (N + l)). omega. omega. + exploit (two_p_gt_ZERO (N + l)). lia. lia. cut (Z.div (- (m * n)) (two_p (N + l)) = -q - 1). - omega. + lia. apply Zdiv_unique_2. - apply two_p_gt_ZERO. omega. + apply two_p_gt_ZERO. lia. replace (two_p (N + l) * - q - - (m * n)) with (m * n - two_p (N + l) * q) by ring. set (k := m * d - two_p (N + l)). assert (0 < k <= two_p l). - unfold k; omega. + unfold k; lia. assert ((m * n - two_p (N + l) * q) * d = k * n + two_p (N + l) * r). unfold k. rewrite EUCL. ring. split. - apply Zmult_lt_reg_r with d. omega. - replace (0 * d) with 0 by omega. + apply Zmult_lt_reg_r with d. lia. + replace (0 * d) with 0 by lia. rewrite H2. - assert (0 < k * n). apply Z.mul_pos_pos; omega. + assert (0 < k * n). apply Z.mul_pos_pos; lia. assert (0 <= two_p (N + l) * r). - apply Z.mul_nonneg_nonneg. exploit (two_p_gt_ZERO (N + l)); omega. omega. - omega. - apply Zmult_le_reg_r with d. omega. + apply Z.mul_nonneg_nonneg. exploit (two_p_gt_ZERO (N + l)); lia. lia. + lia. + apply Zmult_le_reg_r with d. lia. rewrite H2. assert (k * n <= two_p (N + l)). - rewrite Z.add_comm. rewrite two_p_is_exp; try omega. - apply Z.le_trans with (two_p l * n). apply Z.mul_le_mono_nonneg_r; omega. - apply Z.mul_le_mono_nonneg_l. omega. exploit (two_p_gt_ZERO l). omega. omega. + rewrite Z.add_comm. rewrite two_p_is_exp; try lia. + apply Z.le_trans with (two_p l * n). apply Z.mul_le_mono_nonneg_r; lia. + apply Z.mul_le_mono_nonneg_l. lia. exploit (two_p_gt_ZERO l). lia. lia. assert (two_p (N + l) * r <= two_p (N + l) * d - two_p (N + l)). replace (two_p (N + l) * d - two_p (N + l)) with (two_p (N + l) * (d - 1)) by ring. - apply Z.mul_le_mono_nonneg_l. exploit (two_p_gt_ZERO (N + l)). omega. omega. omega. - omega. + apply Z.mul_le_mono_nonneg_l. exploit (two_p_gt_ZERO (N + l)). lia. lia. lia. + lia. Qed. (** This is theorem 5.1 from Granlund and Montgomery, PLDI 1994. *) @@ -159,13 +159,13 @@ Lemma Zquot_mul: Z.quot n d = Z.div (m * n) (two_p (N + l)) + (if zlt n 0 then 1 else 0). Proof. intros. destruct (zlt n 0). - exploit (Zdiv_mul_opp m l H H0 (-n)). omega. + exploit (Zdiv_mul_opp m l H H0 (-n)). lia. replace (- - n) with n by ring. replace (Z.quot n d) with (- Z.quot (-n) d). - rewrite Zquot_Zdiv_pos by omega. omega. - rewrite Z.quot_opp_l by omega. ring. - rewrite Z.add_0_r. rewrite Zquot_Zdiv_pos by omega. - apply Zdiv_mul_pos; omega. + rewrite Zquot_Zdiv_pos by lia. lia. + rewrite Z.quot_opp_l by lia. ring. + rewrite Z.add_0_r. rewrite Zquot_Zdiv_pos by lia. + apply Zdiv_mul_pos; lia. Qed. End Z_DIV_MUL. @@ -194,11 +194,11 @@ Proof with (try discriminate). destruct (zlt p1 32)... intros EQ; inv EQ. split. auto. split. auto. intros. - replace (32 + p') with (31 + (p' + 1)) by omega. - apply Zquot_mul; try omega. - replace (31 + (p' + 1)) with (32 + p') by omega. omega. + replace (32 + p') with (31 + (p' + 1)) by lia. + apply Zquot_mul; try lia. + replace (31 + (p' + 1)) with (32 + p') by lia. lia. change (Int.min_signed <= n < Int.half_modulus). - unfold Int.max_signed in H. omega. + unfold Int.max_signed in H. lia. Qed. Lemma divu_mul_params_sound: @@ -223,7 +223,7 @@ Proof with (try discriminate). destruct (zlt p1 32)... intros EQ; inv EQ. split. auto. split. auto. intros. - apply Zdiv_mul_pos; try omega. assumption. + apply Zdiv_mul_pos; try lia. assumption. Qed. Lemma divs_mul_shift_gen: @@ -237,25 +237,25 @@ Proof. exploit divs_mul_params_sound; eauto. intros (A & B & C). split. auto. split. auto. unfold Int.divs. fold n; fold d. rewrite C by (apply Int.signed_range). - rewrite two_p_is_exp by omega. rewrite <- Zdiv_Zdiv. + rewrite two_p_is_exp by lia. rewrite <- Zdiv_Zdiv. rewrite Int.shru_lt_zero. unfold Int.add. apply Int.eqm_samerepr. apply Int.eqm_add. rewrite Int.shr_div_two_p. apply Int.eqm_unsigned_repr_r. apply Int.eqm_refl2. rewrite Int.unsigned_repr. f_equal. rewrite Int.signed_repr. rewrite Int.modulus_power. f_equal. ring. cut (Int.min_signed <= n * m / Int.modulus < Int.half_modulus). - unfold Int.max_signed; omega. - apply Zdiv_interval_1. generalize Int.min_signed_neg; omega. apply Int.half_modulus_pos. + unfold Int.max_signed; lia. + apply Zdiv_interval_1. generalize Int.min_signed_neg; lia. apply Int.half_modulus_pos. apply Int.modulus_pos. split. apply Z.le_trans with (Int.min_signed * m). - apply Z.mul_le_mono_nonpos_l. generalize Int.min_signed_neg; omega. omega. - apply Z.mul_le_mono_nonneg_r. omega. unfold n; generalize (Int.signed_range x); tauto. + apply Z.mul_le_mono_nonpos_l. generalize Int.min_signed_neg; lia. lia. + apply Z.mul_le_mono_nonneg_r. lia. unfold n; generalize (Int.signed_range x); tauto. apply Z.le_lt_trans with (Int.half_modulus * m). - apply Z.mul_le_mono_nonneg_r. tauto. generalize (Int.signed_range x); unfold n, Int.max_signed; omega. - apply Zmult_lt_compat_l. generalize Int.half_modulus_pos; omega. tauto. - assert (32 < Int.max_unsigned) by (compute; auto). omega. + apply Z.mul_le_mono_nonneg_r. tauto. generalize (Int.signed_range x); unfold n, Int.max_signed; lia. + apply Zmult_lt_compat_l. generalize Int.half_modulus_pos; lia. tauto. + assert (32 < Int.max_unsigned) by (compute; auto). lia. unfold Int.lt; fold n. rewrite Int.signed_zero. destruct (zlt n 0); apply Int.eqm_unsigned_repr. - apply two_p_gt_ZERO. omega. - apply two_p_gt_ZERO. omega. + apply two_p_gt_ZERO. lia. + apply two_p_gt_ZERO. lia. Qed. Theorem divs_mul_shift_1: @@ -269,7 +269,7 @@ Proof. intros. exploit divs_mul_shift_gen; eauto. instantiate (1 := x). intros (A & B & C). split. auto. rewrite C. unfold Int.mulhs. rewrite Int.signed_repr. auto. - generalize Int.min_signed_neg; unfold Int.max_signed; omega. + generalize Int.min_signed_neg; unfold Int.max_signed; lia. Qed. Theorem divs_mul_shift_2: @@ -305,18 +305,18 @@ Proof. split. auto. rewrite Int.shru_div_two_p. rewrite Int.unsigned_repr. unfold Int.divu, Int.mulhu. f_equal. rewrite C by apply Int.unsigned_range. - rewrite two_p_is_exp by omega. rewrite <- Zdiv_Zdiv by (apply two_p_gt_ZERO; omega). + rewrite two_p_is_exp by lia. rewrite <- Zdiv_Zdiv by (apply two_p_gt_ZERO; lia). f_equal. rewrite (Int.unsigned_repr m). rewrite Int.unsigned_repr. f_equal. ring. cut (0 <= Int.unsigned x * m / Int.modulus < Int.modulus). - unfold Int.max_unsigned; omega. - apply Zdiv_interval_1. omega. compute; auto. compute; auto. - split. simpl. apply Z.mul_nonneg_nonneg. generalize (Int.unsigned_range x); omega. omega. + unfold Int.max_unsigned; lia. + apply Zdiv_interval_1. lia. compute; auto. compute; auto. + split. simpl. apply Z.mul_nonneg_nonneg. generalize (Int.unsigned_range x); lia. lia. apply Z.le_lt_trans with (Int.modulus * m). - apply Zmult_le_compat_r. generalize (Int.unsigned_range x); omega. omega. - apply Zmult_lt_compat_l. compute; auto. omega. - unfold Int.max_unsigned; omega. - assert (32 < Int.max_unsigned) by (compute; auto). omega. + apply Zmult_le_compat_r. generalize (Int.unsigned_range x); lia. lia. + apply Zmult_lt_compat_l. compute; auto. lia. + unfold Int.max_unsigned; lia. + assert (32 < Int.max_unsigned) by (compute; auto). lia. Qed. (** Same, for 64-bit integers *) @@ -343,11 +343,11 @@ Proof with (try discriminate). destruct (zlt p1 64)... intros EQ; inv EQ. split. auto. split. auto. intros. - replace (64 + p') with (63 + (p' + 1)) by omega. - apply Zquot_mul; try omega. - replace (63 + (p' + 1)) with (64 + p') by omega. omega. + replace (64 + p') with (63 + (p' + 1)) by lia. + apply Zquot_mul; try lia. + replace (63 + (p' + 1)) with (64 + p') by lia. lia. change (Int64.min_signed <= n < Int64.half_modulus). - unfold Int64.max_signed in H. omega. + unfold Int64.max_signed in H. lia. Qed. Lemma divlu_mul_params_sound: @@ -372,13 +372,13 @@ Proof with (try discriminate). destruct (zlt p1 64)... intros EQ; inv EQ. split. auto. split. auto. intros. - apply Zdiv_mul_pos; try omega. assumption. + apply Zdiv_mul_pos; try lia. assumption. Qed. Remark int64_shr'_div_two_p: forall x y, Int64.shr' x y = Int64.repr (Int64.signed x / two_p (Int.unsigned y)). Proof. - intros; unfold Int64.shr'. rewrite Zshiftr_div_two_p; auto. generalize (Int.unsigned_range y); omega. + intros; unfold Int64.shr'. rewrite Zshiftr_div_two_p; auto. generalize (Int.unsigned_range y); lia. Qed. Lemma divls_mul_shift_gen: @@ -392,25 +392,25 @@ Proof. exploit divls_mul_params_sound; eauto. intros (A & B & C). split. auto. split. auto. unfold Int64.divs. fold n; fold d. rewrite C by (apply Int64.signed_range). - rewrite two_p_is_exp by omega. rewrite <- Zdiv_Zdiv. + rewrite two_p_is_exp by lia. rewrite <- Zdiv_Zdiv. rewrite Int64.shru_lt_zero. unfold Int64.add. apply Int64.eqm_samerepr. apply Int64.eqm_add. rewrite int64_shr'_div_two_p. apply Int64.eqm_unsigned_repr_r. apply Int64.eqm_refl2. rewrite Int.unsigned_repr. f_equal. rewrite Int64.signed_repr. rewrite Int64.modulus_power. f_equal. ring. cut (Int64.min_signed <= n * m / Int64.modulus < Int64.half_modulus). - unfold Int64.max_signed; omega. - apply Zdiv_interval_1. generalize Int64.min_signed_neg; omega. apply Int64.half_modulus_pos. + unfold Int64.max_signed; lia. + apply Zdiv_interval_1. generalize Int64.min_signed_neg; lia. apply Int64.half_modulus_pos. apply Int64.modulus_pos. split. apply Z.le_trans with (Int64.min_signed * m). - apply Z.mul_le_mono_nonpos_l. generalize Int64.min_signed_neg; omega. omega. + apply Z.mul_le_mono_nonpos_l. generalize Int64.min_signed_neg; lia. lia. apply Z.mul_le_mono_nonneg_r. tauto. unfold n; generalize (Int64.signed_range x); tauto. apply Z.le_lt_trans with (Int64.half_modulus * m). - apply Zmult_le_compat_r. generalize (Int64.signed_range x); unfold n, Int64.max_signed; omega. tauto. - apply Zmult_lt_compat_l. generalize Int64.half_modulus_pos; omega. tauto. - assert (64 < Int.max_unsigned) by (compute; auto). omega. + apply Zmult_le_compat_r. generalize (Int64.signed_range x); unfold n, Int64.max_signed; lia. tauto. + apply Zmult_lt_compat_l. generalize Int64.half_modulus_pos; lia. tauto. + assert (64 < Int.max_unsigned) by (compute; auto). lia. unfold Int64.lt; fold n. rewrite Int64.signed_zero. destruct (zlt n 0); apply Int64.eqm_unsigned_repr. - apply two_p_gt_ZERO. omega. - apply two_p_gt_ZERO. omega. + apply two_p_gt_ZERO. lia. + apply two_p_gt_ZERO. lia. Qed. Theorem divls_mul_shift_1: @@ -424,7 +424,7 @@ Proof. intros. exploit divls_mul_shift_gen; eauto. instantiate (1 := x). intros (A & B & C). split. auto. rewrite C. unfold Int64.mulhs. rewrite Int64.signed_repr. auto. - generalize Int64.min_signed_neg; unfold Int64.max_signed; omega. + generalize Int64.min_signed_neg; unfold Int64.max_signed; lia. Qed. Theorem divls_mul_shift_2: @@ -453,7 +453,7 @@ Qed. Remark int64_shru'_div_two_p: forall x y, Int64.shru' x y = Int64.repr (Int64.unsigned x / two_p (Int.unsigned y)). Proof. - intros; unfold Int64.shru'. rewrite Zshiftr_div_two_p; auto. generalize (Int.unsigned_range y); omega. + intros; unfold Int64.shru'. rewrite Zshiftr_div_two_p; auto. generalize (Int.unsigned_range y); lia. Qed. Theorem divlu_mul_shift: @@ -466,18 +466,18 @@ Proof. split. auto. rewrite int64_shru'_div_two_p. rewrite Int.unsigned_repr. unfold Int64.divu, Int64.mulhu. f_equal. rewrite C by apply Int64.unsigned_range. - rewrite two_p_is_exp by omega. rewrite <- Zdiv_Zdiv by (apply two_p_gt_ZERO; omega). + rewrite two_p_is_exp by lia. rewrite <- Zdiv_Zdiv by (apply two_p_gt_ZERO; lia). f_equal. rewrite (Int64.unsigned_repr m). rewrite Int64.unsigned_repr. f_equal. ring. cut (0 <= Int64.unsigned x * m / Int64.modulus < Int64.modulus). - unfold Int64.max_unsigned; omega. - apply Zdiv_interval_1. omega. compute; auto. compute; auto. - split. simpl. apply Z.mul_nonneg_nonneg. generalize (Int64.unsigned_range x); omega. omega. + unfold Int64.max_unsigned; lia. + apply Zdiv_interval_1. lia. compute; auto. compute; auto. + split. simpl. apply Z.mul_nonneg_nonneg. generalize (Int64.unsigned_range x); lia. lia. apply Z.le_lt_trans with (Int64.modulus * m). - apply Zmult_le_compat_r. generalize (Int64.unsigned_range x); omega. omega. - apply Zmult_lt_compat_l. compute; auto. omega. - unfold Int64.max_unsigned; omega. - assert (64 < Int.max_unsigned) by (compute; auto). omega. + apply Zmult_le_compat_r. generalize (Int64.unsigned_range x); lia. lia. + apply Zmult_lt_compat_l. compute; auto. lia. + unfold Int64.max_unsigned; lia. + assert (64 < Int.max_unsigned) by (compute; auto). lia. Qed. (** * Correctness of the smart constructors for division and modulus *) @@ -515,7 +515,7 @@ Proof. replace (Int.ltu (Int.repr p) Int.iwordsize) with true in Q. inv Q. rewrite B. auto. unfold Int.ltu. rewrite Int.unsigned_repr. rewrite zlt_true; auto. tauto. - assert (32 < Int.max_unsigned) by (compute; auto). omega. + assert (32 < Int.max_unsigned) by (compute; auto). lia. Qed. Theorem eval_divuimm: @@ -630,7 +630,7 @@ Proof. simpl in LD. inv LD. assert (RANGE: 0 <= p < 32 -> Int.ltu (Int.repr p) Int.iwordsize = true). { intros. unfold Int.ltu. rewrite Int.unsigned_repr. rewrite zlt_true by tauto. auto. - assert (32 < Int.max_unsigned) by (compute; auto). omega. } + assert (32 < Int.max_unsigned) by (compute; auto). lia. } destruct (zlt M Int.half_modulus). - exploit (divs_mul_shift_1 x); eauto. intros [A B]. exploit eval_shrimm. eexact X. instantiate (1 := Int.repr p). intros [v1 [Z LD]]. @@ -768,7 +768,7 @@ Proof. simpl in B1; inv B1. simpl in B2. replace (Int.ltu (Int.repr p) Int64.iwordsize') with true in B2. inv B2. rewrite B. assumption. unfold Int.ltu. rewrite Int.unsigned_repr. rewrite zlt_true; auto. tauto. - assert (64 < Int.max_unsigned) by (compute; auto). omega. + assert (64 < Int.max_unsigned) by (compute; auto). lia. Qed. Theorem eval_divlu: @@ -847,10 +847,10 @@ Proof. exploit eval_addl. auto. eexact A5. eexact A3. intros (v6 & A6 & B6). assert (RANGE: forall x, 0 <= x < 64 -> Int.ltu (Int.repr x) Int64.iwordsize' = true). { intros. unfold Int.ltu. rewrite Int.unsigned_repr. rewrite zlt_true by tauto. auto. - assert (64 < Int.max_unsigned) by (compute; auto). omega. } + assert (64 < Int.max_unsigned) by (compute; auto). lia. } simpl in B1; inv B1. simpl in B2; inv B2. - simpl in B3; rewrite RANGE in B3 by omega; inv B3. + simpl in B3; rewrite RANGE in B3 by lia; inv B3. destruct (zlt M Int64.half_modulus). - exploit (divls_mul_shift_1 x); eauto. intros [A B]. simpl in B5; rewrite RANGE in B5 by auto; inv B5. diff --git a/backend/Selectionproof.v b/backend/Selectionproof.v index 987926aa..4755ab79 100644 --- a/backend/Selectionproof.v +++ b/backend/Selectionproof.v @@ -531,7 +531,7 @@ Lemma sel_switch_correct: (XElet arg (sel_switch make_cmp_eq make_cmp_ltu make_sub make_to_int O t)) (switch_target i dfl cases). Proof. - intros. exploit validate_switch_correct; eauto. omega. intros [A B]. + intros. exploit validate_switch_correct; eauto. lia. intros [A B]. econstructor. eauto. eapply sel_switch_correct_rec; eauto. Qed. @@ -564,7 +564,7 @@ Proof. inv R. unfold Val.cmp in B. simpl in B. revert B. predSpec Int.eq Int.eq_spec n0 (Int.repr n); intros B; inv B. rewrite Int.unsigned_repr. unfold proj_sumbool; rewrite zeq_true; auto. - unfold Int.max_unsigned; omega. + unfold Int.max_unsigned; lia. unfold proj_sumbool; rewrite zeq_false; auto. red; intros; elim H1. rewrite <- (Int.repr_unsigned n0). congruence. - intros until n; intros EVAL R RANGE. @@ -573,7 +573,7 @@ Proof. inv R. unfold Val.cmpu in B. simpl in B. unfold Int.ltu in B. rewrite Int.unsigned_repr in B. destruct (zlt (Int.unsigned n0) n); inv B; auto. - unfold Int.max_unsigned; omega. + unfold Int.max_unsigned; lia. - intros until n; intros EVAL R RANGE. exploit eval_sub. eexact EVAL. apply (INTCONST (Int.repr n)). intros (vb & A & B). inv R. simpl in B. inv B. econstructor; split; eauto. @@ -581,7 +581,7 @@ Proof. with (Int.unsigned (Int.sub n0 (Int.repr n))). constructor. unfold Int.sub. rewrite Int.unsigned_repr_eq. f_equal. f_equal. - apply Int.unsigned_repr. unfold Int.max_unsigned; omega. + apply Int.unsigned_repr. unfold Int.max_unsigned; lia. - intros until i0; intros EVAL R. exists v; split; auto. inv R. rewrite Z.mod_small by (apply Int.unsigned_range). constructor. - constructor. @@ -599,12 +599,12 @@ Proof. eapply eval_cmpl. eexact EVAL. apply eval_longconst with (n := Int64.repr n). inv R. unfold Val.cmpl. simpl. f_equal; f_equal. unfold Int64.eq. rewrite Int64.unsigned_repr. destruct (zeq (Int64.unsigned n0) n); auto. - unfold Int64.max_unsigned; omega. + unfold Int64.max_unsigned; lia. - intros until n; intros EVAL R RANGE. eapply eval_cmplu; auto. eexact EVAL. apply eval_longconst with (n := Int64.repr n). inv R. unfold Val.cmplu. simpl. f_equal; f_equal. unfold Int64.ltu. rewrite Int64.unsigned_repr. destruct (zlt (Int64.unsigned n0) n); auto. - unfold Int64.max_unsigned; omega. + unfold Int64.max_unsigned; lia. - intros until n; intros EVAL R RANGE. exploit eval_subl; auto; try apply HF'. eexact EVAL. apply eval_longconst with (n := Int64.repr n). intros (vb & A & B). @@ -613,7 +613,7 @@ Proof. with (Int64.unsigned (Int64.sub n0 (Int64.repr n))). constructor. unfold Int64.sub. rewrite Int64.unsigned_repr_eq. f_equal. f_equal. - apply Int64.unsigned_repr. unfold Int64.max_unsigned; omega. + apply Int64.unsigned_repr. unfold Int64.max_unsigned; lia. - intros until i0; intros EVAL R. exploit eval_lowlong. eexact EVAL. intros (vb & A & B). inv R. simpl in B. inv B. econstructor; split; eauto. @@ -1295,7 +1295,7 @@ Proof. eapply match_cont_call with (cunit := cunit) (hf := hf); eauto. + (* turned into Sbuiltin *) intros EQ. subst fd. - right; left; split. simpl; omega. split; auto. econstructor; eauto. + right; left; split. simpl; lia. split; auto. econstructor; eauto. - (* Stailcall *) exploit Mem.free_parallel_extends; eauto. intros [m2' [P Q]]. erewrite <- stackspace_function_translated in P by eauto. @@ -1413,7 +1413,7 @@ Proof. apply plus_one; econstructor. econstructor; eauto. destruct optid; simpl; auto. apply set_var_lessdef; auto. - (* return of an external call turned into a Sbuiltin *) - right; left; split. simpl; omega. split. auto. econstructor; eauto. + right; left; split. simpl; lia. split. auto. econstructor; eauto. Qed. Lemma sel_initial_states: diff --git a/backend/SplitLongproof.v b/backend/SplitLongproof.v index 18c1f18d..1e50b1c2 100644 --- a/backend/SplitLongproof.v +++ b/backend/SplitLongproof.v @@ -335,7 +335,7 @@ Proof. fold (Int.testbit i i0). destruct (zlt i0 Int.zwordsize). auto. - rewrite Int.bits_zero. rewrite Int.bits_above by omega. auto. + rewrite Int.bits_zero. rewrite Int.bits_above by lia. auto. Qed. Theorem eval_longofint: unary_constructor_sound longofint Val.longofint. @@ -352,13 +352,13 @@ Proof. apply Int64.same_bits_eq; intros. rewrite Int64.testbit_repr by auto. rewrite Int64.bits_ofwords by auto. - rewrite Int.bits_signed by omega. + rewrite Int.bits_signed by lia. destruct (zlt i0 Int.zwordsize). auto. assert (Int64.zwordsize = 2 * Int.zwordsize) by reflexivity. - rewrite Int.bits_shr by omega. + rewrite Int.bits_shr by lia. change (Int.unsigned (Int.repr 31)) with (Int.zwordsize - 1). - f_equal. destruct (zlt (i0 - Int.zwordsize + (Int.zwordsize - 1)) Int.zwordsize); omega. + f_equal. destruct (zlt (i0 - Int.zwordsize + (Int.zwordsize - 1)) Int.zwordsize); lia. Qed. Theorem eval_negl: unary_constructor_sound negl Val.negl. @@ -545,24 +545,24 @@ Proof. { red; intros. elim H. rewrite <- (Int.repr_unsigned n). rewrite H0. auto. } destruct (Int.ltu n Int.iwordsize) eqn:LT. exploit Int.ltu_iwordsize_inv; eauto. intros RANGE. - assert (0 <= Int.zwordsize - Int.unsigned n < Int.zwordsize) by omega. + assert (0 <= Int.zwordsize - Int.unsigned n < Int.zwordsize) by lia. apply A1. auto. auto. unfold Int.ltu, Int.sub. rewrite Int.unsigned_repr_wordsize. - rewrite Int.unsigned_repr. rewrite zlt_true; auto. omega. - generalize Int.wordsize_max_unsigned; omega. + rewrite Int.unsigned_repr. rewrite zlt_true; auto. lia. + generalize Int.wordsize_max_unsigned; lia. unfold Int.ltu. rewrite zlt_true; auto. change (Int.unsigned Int64.iwordsize') with 64. - change Int.zwordsize with 32 in RANGE. omega. + change Int.zwordsize with 32 in RANGE. lia. destruct (Int.ltu n Int64.iwordsize') eqn:LT'. exploit Int.ltu_inv; eauto. change (Int.unsigned Int64.iwordsize') with (Int.zwordsize * 2). intros RANGE. assert (Int.zwordsize <= Int.unsigned n). unfold Int.ltu in LT. rewrite Int.unsigned_repr_wordsize in LT. - destruct (zlt (Int.unsigned n) Int.zwordsize). discriminate. omega. + destruct (zlt (Int.unsigned n) Int.zwordsize). discriminate. lia. apply A2. tauto. unfold Int.ltu, Int.sub. rewrite Int.unsigned_repr_wordsize. - rewrite Int.unsigned_repr. rewrite zlt_true; auto. omega. - generalize Int.wordsize_max_unsigned; omega. + rewrite Int.unsigned_repr. rewrite zlt_true; auto. lia. + generalize Int.wordsize_max_unsigned; lia. auto. Qed. @@ -918,19 +918,19 @@ Proof. rewrite Int.bits_zero. rewrite Int.bits_or by auto. symmetry. apply orb_false_intro. transitivity (Int64.testbit (Int64.ofwords h l) (i + Int.zwordsize)). - rewrite Int64.bits_ofwords by omega. rewrite zlt_false by omega. f_equal; omega. + rewrite Int64.bits_ofwords by lia. rewrite zlt_false by lia. f_equal; lia. rewrite H0. apply Int64.bits_zero. transitivity (Int64.testbit (Int64.ofwords h l) i). - rewrite Int64.bits_ofwords by omega. rewrite zlt_true by omega. auto. + rewrite Int64.bits_ofwords by lia. rewrite zlt_true by lia. auto. rewrite H0. apply Int64.bits_zero. symmetry. apply Int.eq_false. red; intros; elim H0. apply Int64.same_bits_eq; intros. rewrite Int64.bits_zero. rewrite Int64.bits_ofwords by auto. destruct (zlt i Int.zwordsize). assert (Int.testbit (Int.or h l) i = false) by (rewrite H1; apply Int.bits_zero). - rewrite Int.bits_or in H3 by omega. exploit orb_false_elim; eauto. tauto. + rewrite Int.bits_or in H3 by lia. exploit orb_false_elim; eauto. tauto. assert (Int.testbit (Int.or h l) (i - Int.zwordsize) = false) by (rewrite H1; apply Int.bits_zero). - rewrite Int.bits_or in H3 by omega. exploit orb_false_elim; eauto. tauto. + rewrite Int.bits_or in H3 by lia. exploit orb_false_elim; eauto. tauto. Qed. Lemma eval_cmpl_eq_zero: diff --git a/backend/Stackingproof.v b/backend/Stackingproof.v index ffd9b227..7724c5d6 100644 --- a/backend/Stackingproof.v +++ b/backend/Stackingproof.v @@ -58,7 +58,7 @@ Lemma slot_outgoing_argument_valid: Proof. intros. exploit loc_arguments_acceptable_2; eauto. intros [A B]. unfold slot_valid. unfold proj_sumbool. - rewrite zle_true by omega. + rewrite zle_true by lia. rewrite pred_dec_true by auto. auto. Qed. @@ -126,7 +126,7 @@ Proof. destruct (wt_function f); simpl negb. destruct (zlt Ptrofs.max_unsigned (fe_size (make_env (function_bounds f)))). intros; discriminate. - intros. unfold fe. unfold b. omega. + intros. unfold fe. unfold b. lia. intros; discriminate. Qed. @@ -200,7 +200,7 @@ Next Obligation. - exploit H4; eauto. intros (v & A & B). exists v; split; auto. eapply Mem.load_unchanged_on; eauto. simpl; intros. rewrite size_type_chunk, typesize_typesize in H8. - split; auto. omega. + split; auto. lia. Qed. Next Obligation. eauto with mem. @@ -215,7 +215,7 @@ Remark valid_access_location: Proof. intros; split. - red; intros. apply Mem.perm_implies with Freeable; auto with mem. - apply H0. rewrite size_type_chunk, typesize_typesize in H4. omega. + apply H0. rewrite size_type_chunk, typesize_typesize in H4. lia. - rewrite align_type_chunk. apply Z.divide_add_r. apply Z.divide_trans with 8; auto. exists (8 / (4 * typealign ty)); destruct ty; reflexivity. @@ -233,7 +233,7 @@ Proof. intros. destruct H as (D & E & F & G & H). exploit H; eauto. intros (v & U & V). exists v; split; auto. unfold load_stack; simpl. rewrite Ptrofs.add_zero_l, Ptrofs.unsigned_repr; auto. - unfold Ptrofs.max_unsigned. generalize (typesize_pos ty). omega. + unfold Ptrofs.max_unsigned. generalize (typesize_pos ty). lia. Qed. Lemma set_location: @@ -252,19 +252,19 @@ Proof. { red; intros; eauto with mem. } exists m'; split. - unfold store_stack; simpl. rewrite Ptrofs.add_zero_l, Ptrofs.unsigned_repr; eauto. - unfold Ptrofs.max_unsigned. generalize (typesize_pos ty). omega. + unfold Ptrofs.max_unsigned. generalize (typesize_pos ty). lia. - simpl. intuition auto. + unfold Locmap.set. destruct (Loc.eq (S sl ofs ty) (S sl ofs0 ty0)); [|destruct (Loc.diff_dec (S sl ofs ty) (S sl ofs0 ty0))]. * (* same location *) inv e. rename ofs0 into ofs. rename ty0 into ty. exists (Val.load_result (chunk_of_type ty) v'); split. - eapply Mem.load_store_similar_2; eauto. omega. + eapply Mem.load_store_similar_2; eauto. lia. apply Val.load_result_inject; auto. * (* different locations *) exploit H; eauto. intros (v0 & X & Y). exists v0; split; auto. rewrite <- X; eapply Mem.load_store_other; eauto. - destruct d. congruence. right. rewrite ! size_type_chunk, ! typesize_typesize. omega. + destruct d. congruence. right. rewrite ! size_type_chunk, ! typesize_typesize. lia. * (* overlapping locations *) destruct (Mem.valid_access_load m' (chunk_of_type ty0) sp (pos + 4 * ofs0)) as [v'' LOAD]. apply Mem.valid_access_implies with Writable; auto with mem. @@ -273,7 +273,7 @@ Proof. + apply (m_invar P) with m; auto. eapply Mem.store_unchanged_on; eauto. intros i; rewrite size_type_chunk, typesize_typesize. intros; red; intros. - eelim C; eauto. simpl. split; auto. omega. + eelim C; eauto. simpl. split; auto. lia. Qed. Lemma initial_locations: @@ -933,8 +933,8 @@ Local Opaque mreg_type. { unfold pos1. apply Z.divide_trans with sz. unfold sz; rewrite <- size_type_chunk. apply align_size_chunk_divides. apply align_divides; auto. } - apply range_drop_left with (mid := pos1) in SEP; [ | omega ]. - apply range_split with (mid := pos1 + sz) in SEP; [ | omega ]. + apply range_drop_left with (mid := pos1) in SEP; [ | lia ]. + apply range_split with (mid := pos1 + sz) in SEP; [ | lia ]. unfold sz at 1 in SEP. rewrite <- size_type_chunk in SEP. apply range_contains in SEP; auto. exploit (contains_set_stack (fun v' => Val.inject j (ls (R r)) v') (rs r)). @@ -1073,7 +1073,7 @@ Local Opaque b fe. instantiate (1 := fe_stack_data fe). tauto. reflexivity. instantiate (1 := fe_stack_data fe + bound_stack_data b). rewrite Z.max_comm. reflexivity. - generalize (bound_stack_data_pos b) size_no_overflow; omega. + generalize (bound_stack_data_pos b) size_no_overflow; lia. tauto. tauto. clear SEP. intros (j' & SEP & INCR & SAME). @@ -1607,7 +1607,7 @@ Proof. + simpl in SEP. unfold parent_sp. assert (slot_valid f Outgoing pos ty = true). { destruct H0. unfold slot_valid, proj_sumbool. - rewrite zle_true by omega. rewrite pred_dec_true by auto. reflexivity. } + rewrite zle_true by lia. rewrite pred_dec_true by auto. reflexivity. } assert (slot_within_bounds (function_bounds f) Outgoing pos ty) by eauto. exploit frame_get_outgoing; eauto. intros (v & A & B). exists v; split. diff --git a/backend/Tailcallproof.v b/backend/Tailcallproof.v index 9ec89553..7a5be5ed 100644 --- a/backend/Tailcallproof.v +++ b/backend/Tailcallproof.v @@ -47,11 +47,11 @@ Proof. intro f. assert (forall n pc, (return_measure_rec n f pc <= n)%nat). induction n; intros; simpl. - omega. - destruct (f!pc); try omega. - destruct i; try omega. - generalize (IHn n0). omega. - generalize (IHn n0). omega. + lia. + destruct (f!pc); try lia. + destruct i; try lia. + generalize (IHn n0). lia. + generalize (IHn n0). lia. intros. unfold return_measure. apply H. Qed. @@ -61,11 +61,11 @@ Remark return_measure_rec_incr: (return_measure_rec n1 f pc <= return_measure_rec n2 f pc)%nat. Proof. induction n1; intros; simpl. - omega. - destruct n2. omegaContradiction. assert (n1 <= n2)%nat by omega. - simpl. destruct f!pc; try omega. destruct i; try omega. - generalize (IHn1 n2 n H0). omega. - generalize (IHn1 n2 n H0). omega. + lia. + destruct n2. extlia. assert (n1 <= n2)%nat by lia. + simpl. destruct f!pc; try lia. destruct i; try lia. + generalize (IHn1 n2 n H0). lia. + generalize (IHn1 n2 n H0). lia. Qed. Lemma is_return_measure_rec: @@ -75,13 +75,13 @@ Lemma is_return_measure_rec: Proof. induction n; simpl; intros. congruence. - destruct n'. omegaContradiction. simpl. + destruct n'. extlia. simpl. destruct (fn_code f)!pc; try congruence. destruct i; try congruence. - decEq. apply IHn with r. auto. omega. + decEq. apply IHn with r. auto. lia. destruct (is_move_operation o l); try congruence. destruct (Reg.eq r r1); try congruence. - decEq. apply IHn with r0. auto. omega. + decEq. apply IHn with r0. auto. lia. Qed. (** ** Relational characterization of the code transformation *) @@ -117,22 +117,22 @@ Proof. generalize H. simpl. caseEq ((fn_code f)!pc); try congruence. intro i. caseEq i; try congruence. - intros s; intros. eapply is_return_nop; eauto. eapply IHn; eauto. omega. + intros s; intros. eapply is_return_nop; eauto. eapply IHn; eauto. lia. unfold return_measure. rewrite <- (is_return_measure_rec f (S n) niter pc rret); auto. rewrite <- (is_return_measure_rec f n niter s rret); auto. - simpl. rewrite H2. omega. omega. + simpl. rewrite H2. lia. lia. intros op args dst s EQ1 EQ2. caseEq (is_move_operation op args); try congruence. intros src IMO. destruct (Reg.eq rret src); try congruence. subst rret. intro. exploit is_move_operation_correct; eauto. intros [A B]. subst. - eapply is_return_move; eauto. eapply IHn; eauto. omega. + eapply is_return_move; eauto. eapply IHn; eauto. lia. unfold return_measure. rewrite <- (is_return_measure_rec f (S n) niter pc src); auto. rewrite <- (is_return_measure_rec f n niter s dst); auto. - simpl. rewrite EQ2. omega. omega. + simpl. rewrite EQ2. lia. lia. intros or EQ1 EQ2. destruct or; intros. assert (r = rret). eapply proj_sumbool_true; eauto. subst r. @@ -407,7 +407,7 @@ Proof. eapply exec_Inop; eauto. constructor; auto. - (* eliminated nop *) assert (s0 = pc') by congruence. subst s0. - right. split. simpl. omega. split. auto. + right. split. simpl. lia. split. auto. econstructor; eauto. - (* op *) @@ -421,7 +421,7 @@ Proof. econstructor; eauto. apply set_reg_lessdef; auto. - (* eliminated move *) rewrite H1 in H. clear H1. inv H. - right. split. simpl. omega. split. auto. + right. split. simpl. lia. split. auto. econstructor; eauto. simpl in H0. rewrite PMap.gss. congruence. - (* load *) @@ -455,13 +455,13 @@ Proof. + (* call turned tailcall *) assert ({ m'' | Mem.free m' sp0 0 (fn_stacksize (transf_function f)) = Some m''}). apply Mem.range_perm_free. rewrite stacksize_preserved. rewrite H7. - red; intros; omegaContradiction. + red; intros; extlia. destruct X as [m'' FREE]. left. exists (Callstate s' (transf_fundef fd) (rs'##args) m''); split. eapply exec_Itailcall; eauto. apply sig_preserved. constructor. eapply match_stackframes_tail; eauto. apply regs_lessdef_regs; auto. eapply Mem.free_right_extends; eauto. - rewrite stacksize_preserved. rewrite H7. intros. omegaContradiction. + rewrite stacksize_preserved. rewrite H7. intros. extlia. + (* call that remains a call *) left. exists (Callstate (Stackframe res (transf_function f) (Vptr sp0 Ptrofs.zero) pc' rs' :: s') (transf_fundef fd) (rs'##args) m'); split. @@ -514,22 +514,22 @@ Proof. - (* eliminated return None *) assert (or = None) by congruence. subst or. - right. split. simpl. omega. split. auto. + right. split. simpl. lia. split. auto. constructor. auto. simpl. constructor. eapply Mem.free_left_extends; eauto. - (* eliminated return Some *) assert (or = Some r) by congruence. subst or. - right. split. simpl. omega. split. auto. + right. split. simpl. lia. split. auto. constructor. auto. simpl. auto. eapply Mem.free_left_extends; eauto. - (* internal call *) exploit Mem.alloc_extends; eauto. - instantiate (1 := 0). omega. - instantiate (1 := fn_stacksize f). omega. + instantiate (1 := 0). lia. + instantiate (1 := fn_stacksize f). lia. intros [m'1 [ALLOC EXT]]. assert (fn_stacksize (transf_function f) = fn_stacksize f /\ fn_entrypoint (transf_function f) = fn_entrypoint f /\ @@ -559,7 +559,7 @@ Proof. right. split. unfold measure. simpl length. change (S (length s) * (niter + 2))%nat with ((niter + 2) + (length s) * (niter + 2))%nat. - generalize (return_measure_bounds (fn_code f) pc). omega. + generalize (return_measure_bounds (fn_code f) pc). lia. split. auto. econstructor; eauto. rewrite Regmap.gss. auto. diff --git a/backend/Tunneling.v b/backend/Tunneling.v index da1ce45a..265e06ba 100644 --- a/backend/Tunneling.v +++ b/backend/Tunneling.v @@ -12,6 +12,7 @@ (** Branch tunneling (optimization of branches to branches). *) +Require Import FunInd. Require Import Coqlib Maps UnionFind. Require Import AST. Require Import LTL. @@ -21,8 +22,8 @@ Require Import LTL. so that they jump directly to the end of the branch sequence. For example: << - L1: nop L2; L1: nop L3; - L2; nop L3; becomes L2: nop L3; + L1: branch L2; L1: branch L3; + L2; branch L3; becomes L2: branch L3; L3: instr; L3: instr; L4: if (cond) goto L1; L4: if (cond) goto L3; >> @@ -33,70 +34,156 @@ Require Import LTL. computations or useless moves), therefore there are more opportunities for tunneling after allocation than before. Symmetrically, prior tunneling helps linearization to produce - better code, e.g. by revealing that some [nop] instructions are - dead code (as the "nop L3" in the example above). + better code, e.g. by revealing that some [branch] instructions are + dead code (as the "branch L3" in the example above). *) (** The naive implementation of branch tunneling would replace any branch to a node [pc] by a branch to the node [branch_target f pc], defined as follows: << - branch_target f pc = branch_target f pc' if f(pc) = nop pc' + branch_target f pc = branch_target f pc' if f(pc) = branch pc' = pc otherwise >> However, this definition can fail to terminate if the program can contain loops consisting only of branches, as in << - L1: nop L1; + L1: branch L1; >> or -<< L1: nop L2; - L2: nop L1; +<< + L1: branch L2; + L2: branch L1; >> Coq warns us of this fact by not accepting the definition of [branch_target] above. - To handle this problem, we proceed in two passes. The first pass - populates a union-find data structure, adding equalities [pc = pc'] - for every instruction [pc: nop pc'] in the function. *) + To handle this problem, we proceed in two passes: + +- The first pass populates a union-find data structure, adding equalities + between PCs of blocks that are connected by branches and no other + computation. + +- The second pass rewrites the code, replacing every branch to a node [pc] + by a branch to the canonical representative of the equivalence class of [pc]. +*) + +(** * Construction of the union-find data structure *) Module U := UnionFind.UF(PTree). -Definition record_goto (uf: U.t) (pc: node) (b: bblock) : U.t := +(** We start populating the union-find data structure by adding + equalities [pc = pc'] for every block [pc: branch pc'] in the function. *) + +Definition record_branch (uf: U.t) (pc: node) (b: bblock) : U.t := match b with | Lbranch s :: _ => U.union uf pc s | _ => uf end. +Definition record_branches (f: LTL.function) : U.t := + PTree.fold record_branch f.(fn_code) U.empty. + +(** An additional optimization opportunity comes from conditional branches. + Consider a block [pc: cond ifso ifnot]. If the [ifso] case + and the [ifnot] case jump to the same block [pc'] + (modulo intermediate branches), the block can be simplified into + [pc: branch pc'], and the equality [pc = pc'] can be added to the + union-find data structure. *) + +(** In rare cases, the extra equation [pc = pc'] introduced by the + simplification of a conditional branch can trigger further simplifications + of other conditional branches. We therefore iterate the analysis + until no optimizable conditional branch remains. *) + +(** The code [c] (first component of the [st] triple) starts identical + to the code [fn.(fn_code)] of the current function, but each time + conditional branch at [pc] is optimized, we remove the block at + [pc] from the code [c]. This guarantees termination of the + iteration. *) + +Definition record_cond (st: code * U.t * bool) (pc: node) (b: bblock) : code * U.t * bool := + match b with + | Lcond cond args s1 s2 :: _ => + let '(c, u, _) := st in + if peq (U.repr u s1) (U.repr u s2) + then (PTree.remove pc c, U.union u pc s1, true) + else st + | _ => + st + end. + +Definition record_conds_1 (cu: code * U.t) : code * U.t * bool := + let (c, u) := cu in PTree.fold record_cond c (c, u, false). + +Definition measure_state (cu: code * U.t) : nat := + PTree_Properties.cardinal (fst cu). + +Function record_conds (cu: code * U.t) {measure measure_state cu} : U.t := + let (cu', changed) := record_conds_1 cu in + if changed then record_conds cu' else snd cu. +Proof. + intros [c0 u0] [c1 u1]. + set (P := fun (c: code) (s: code * U.t * bool) => + (forall pc, c!pc = None -> (fst (fst s))!pc = c0!pc) /\ + (PTree_Properties.cardinal (fst (fst s)) + + (if snd s then 1 else 0) + <= PTree_Properties.cardinal c0)%nat). + assert (A: P c0 (PTree.fold record_cond c0 (c0, u0, false))). + { apply PTree_Properties.fold_rec; unfold P. + - intros. destruct H0; split; auto. intros. rewrite <- H in H2. auto. + - simpl; split; intros. auto. simpl; lia. + - intros cd [[c u] changed] pc b NONE SOME [HR1 HR2]. simpl. split. + + intros p EQ. rewrite PTree.gsspec in EQ. destruct (peq p pc); try discriminate. + unfold record_cond. destruct b as [ | [] b ]; auto. + destruct (peq (U.repr u s1) (U.repr u s2)); auto. + simpl. rewrite PTree.gro by auto. auto. + + unfold record_cond. destruct b as [ | [] b ]; auto. + destruct (peq (U.repr u s1) (U.repr u s2)); auto. + simpl in *. + assert (SOME': c!pc = Some (Lcond cond args s1 s2 :: b)). + { rewrite HR1 by auto. auto. } + generalize (PTree_Properties.cardinal_remove SOME'). + destruct changed; lia. + } + unfold record_conds_1, measure_state; intros. + destruct A as [_ A]. rewrite teq in A. simpl in *. + lia. +Qed. + Definition record_gotos (f: LTL.function) : U.t := - PTree.fold record_goto f.(fn_code) U.empty. + record_conds (f.(fn_code), record_branches f). + +(** * Code transformation *) -(** The second pass rewrites all LTL instructions, replacing every +(** The code transformation rewrites all LTL instruction, replacing every successor [s] of every instruction by the canonical representative - of its equivalence class in the union-find data structure. *) + of its equivalence class in the union-find data structure. + Additionally, [Lcond] conditional branches are turned into [Lbranch] + unconditional branches whenever possible. *) -Definition tunnel_instr (uf: U.t) (i: instruction) : instruction := +Definition tunnel_instr (u: U.t) (i: instruction) : instruction := match i with - | Lbranch s => Lbranch (U.repr uf s) + | Lbranch s => Lbranch (U.repr u s) | Lcond cond args s1 s2 => - let s1' := U.repr uf s1 in let s2' := U.repr uf s2 in + let s1' := U.repr u s1 in let s2' := U.repr u s2 in if peq s1' s2' then Lbranch s1' else Lcond cond args s1' s2' - | Ljumptable arg tbl => Ljumptable arg (List.map (U.repr uf) tbl) + | Ljumptable arg tbl => Ljumptable arg (List.map (U.repr u) tbl) | _ => i end. -Definition tunnel_block (uf: U.t) (b: bblock) : bblock := - List.map (tunnel_instr uf) b. +Definition tunnel_block (u: U.t) (b: bblock) : bblock := + List.map (tunnel_instr u) b. Definition tunnel_function (f: LTL.function) : LTL.function := - let uf := record_gotos f in + let u := record_gotos f in mkfunction (fn_sig f) (fn_stacksize f) - (PTree.map1 (tunnel_block uf) (fn_code f)) - (U.repr uf (fn_entrypoint f)). + (PTree.map1 (tunnel_block u) (fn_code f)) + (U.repr u (fn_entrypoint f)). Definition tunnel_fundef (f: LTL.fundef) : LTL.fundef := transf_fundef tunnel_function f. diff --git a/backend/Tunnelingproof.v b/backend/Tunnelingproof.v index 4f95ac9b..68913fc9 100644 --- a/backend/Tunnelingproof.v +++ b/backend/Tunnelingproof.v @@ -12,6 +12,7 @@ (** Correctness proof for the branch tunneling optimization. *) +Require Import FunInd. Require Import Coqlib Maps UnionFind. Require Import AST Linking. Require Import Values Memory Events Globalenvs Smallstep. @@ -29,112 +30,232 @@ Qed. (** * Properties of the branch map computed using union-find. *) -(** A variant of [record_goto] that also incrementally computes a measure [f: node -> nat] - counting the number of [Lnop] instructions starting at a given [pc] that were eliminated. *) +Section BRANCH_MAP_CORRECT. -Definition measure_edge (u: U.t) (pc s: node) (f: node -> nat) : node -> nat := +Variable fn: LTL.function. + +Definition measure_branch (u: U.t) (pc s: node) (f: node -> nat) : node -> nat := fun x => if peq (U.repr u s) pc then f x else if peq (U.repr u x) pc then (f x + f s + 1)%nat else f x. -Definition record_goto' (uf: U.t * (node -> nat)) (pc: node) (b: bblock) : U.t * (node -> nat) := - match b with - | Lbranch s :: b' => let (u, f) := uf in (U.union u pc s, measure_edge u pc s f) - | _ => uf - end. +Definition measure_cond (u: U.t) (pc s1 s2: node) (f: node -> nat) : node -> nat := + fun x => if peq (U.repr u s1) pc then f x + else if peq (U.repr u x) pc then (f x + Nat.max (f s1) (f s2) + 1)%nat + else f x. -Definition branch_map_correct (c: code) (uf: U.t * (node -> nat)): Prop := +Definition branch_map_correct_1 (c: code) (u: U.t) (f: node -> nat): Prop := forall pc, match c!pc with | Some(Lbranch s :: b) => - U.repr (fst uf) pc = pc \/ (U.repr (fst uf) pc = U.repr (fst uf) s /\ snd uf s < snd uf pc)%nat + U.repr u pc = pc \/ (U.repr u pc = U.repr u s /\ f s < f pc)%nat | _ => - U.repr (fst uf) pc = pc + U.repr u pc = pc end. -Lemma record_gotos'_correct: - forall c, - branch_map_correct c (PTree.fold record_goto' c (U.empty, fun (x: node) => O)). +Lemma record_branch_correct: + forall c u f pc b, + branch_map_correct_1 (PTree.remove pc c) u f -> + c!pc = Some b -> + { f' | branch_map_correct_1 c (record_branch u pc b) f' }. Proof. - intros. - apply PTree_Properties.fold_rec with (P := fun c uf => branch_map_correct c uf). - -- (* extensionality *) - intros. red; intros. rewrite <- H. apply H0. + intros c u f pc b BMC GET1. + assert (PC: U.repr u pc = pc). + { specialize (BMC pc). rewrite PTree.grs in BMC. auto. } + assert (DFL: { f | branch_map_correct_1 c u f }). + { exists f. intros p. destruct (peq p pc). + - subst p. rewrite GET1. destruct b as [ | [] b ]; auto. + - specialize (BMC p). rewrite PTree.gro in BMC by auto. exact BMC. + } + unfold record_branch. destruct b as [ | [] b ]; auto. + exists (measure_branch u pc s f). intros p. destruct (peq p pc). ++ subst p. rewrite GET1. unfold measure_branch. + rewrite (U.repr_union_2 u pc s); auto. rewrite U.repr_union_3. + destruct (peq (U.repr u s) pc); auto. rewrite PC, peq_true. right; split; auto. lia. ++ specialize (BMC p). rewrite PTree.gro in BMC by auto. + assert (U.repr u p = p -> U.repr (U.union u pc s) p = p). + { intro. rewrite <- H at 2. apply U.repr_union_1. congruence. } + destruct (c!p) as [ [ | [] _ ] | ]; auto. + destruct BMC as [A | [A B]]. auto. + right; split. apply U.sameclass_union_2; auto. + unfold measure_branch. destruct (peq (U.repr u s) pc). auto. + rewrite A. destruct (peq (U.repr u s0) pc); lia. +Qed. +Lemma record_branches_correct: + { f | branch_map_correct_1 fn.(fn_code) (record_branches fn) f }. +Proof. + unfold record_branches. apply PTree_Properties.fold_ind. - (* base case *) - red; intros; simpl. rewrite PTree.gempty. apply U.repr_empty. - + intros m EMPTY. exists (fun _ => O). + red; intros. rewrite EMPTY. apply U.repr_empty. - (* inductive case *) - intros m uf pc bb; intros. destruct uf as [u f]. + intros m u pc bb GET1 GET2 [f BMC]. eapply record_branch_correct; eauto. +Qed. + +Definition branch_map_correct_2 (c: code) (u: U.t) (f: node -> nat): Prop := + forall pc, + match fn.(fn_code)!pc with + | Some(Lbranch s :: b) => + U.repr u pc = pc \/ (U.repr u pc = U.repr u s /\ f s < f pc)%nat + | Some(Lcond cond args s1 s2 :: b) => + U.repr u pc = pc \/ (c!pc = None /\ U.repr u pc = U.repr u s1 /\ U.repr u pc = U.repr u s2 /\ f s1 < f pc /\ f s2 < f pc)%nat + | _ => + U.repr u pc = pc + end. + +Lemma record_cond_correct: + forall c u changed f pc b, + branch_map_correct_2 c u f -> + fn.(fn_code)!pc = Some b -> + c!pc <> None -> + let '(c1, u1, _) := record_cond (c, u, changed) pc b in + { f' | branch_map_correct_2 c1 u1 f' }. +Proof. + intros c u changed f pc b BMC GET1 GET2. + assert (DFL: { f' | branch_map_correct_2 c u f' }). + { exists f; auto. } + unfold record_cond. destruct b as [ | [] b ]; auto. + destruct (peq (U.repr u s1) (U.repr u s2)); auto. + exists (measure_cond u pc s1 s2 f). assert (PC: U.repr u pc = pc). - generalize (H1 pc). rewrite H. auto. - assert (record_goto' (u, f) pc bb = (u, f) - \/ exists s, exists bb', bb = Lbranch s :: bb' /\ record_goto' (u, f) pc bb = (U.union u pc s, measure_edge u pc s f)). - unfold record_goto'; simpl. destruct bb; auto. destruct i; auto. right. exists s; exists bb; auto. - destruct H2 as [B | [s [bb' [EQ B]]]]. - -+ (* u and f are unchanged *) - rewrite B. - red. intro pc'. simpl. rewrite PTree.gsspec. destruct (peq pc' pc). subst pc'. - destruct bb; auto. destruct i; auto. - apply H1. + { specialize (BMC pc). rewrite GET1 in BMC. intuition congruence. } + intro p. destruct (peq p pc). +- subst p. rewrite GET1. unfold measure_cond. + rewrite U.repr_union_2 by auto. rewrite <- e, PC, peq_true. + destruct (peq (U.repr u s1) pc); auto. + right; repeat split. + + apply PTree.grs. + + rewrite U.repr_union_3. auto. + + rewrite U.repr_union_1 by congruence. auto. + + lia. + + lia. +- assert (P: U.repr u p = p -> U.repr (U.union u pc s1) p = p). + { intros. rewrite U.repr_union_1 by congruence. auto. } + specialize (BMC p). destruct (fn_code fn)!p as [ [ | [] bb ] | ]; auto. + + destruct BMC as [A | (A & B)]; auto. right; split. + * apply U.sameclass_union_2; auto. + * unfold measure_cond. rewrite <- A. + destruct (peq (U.repr u s1) pc). auto. + destruct (peq (U.repr u p) pc); lia. + + destruct BMC as [A | (A & B & C & D & E)]; auto. right; split; [ | split; [ | split]]. + * rewrite PTree.gro by auto. auto. + * apply U.sameclass_union_2; auto. + * apply U.sameclass_union_2; auto. + * unfold measure_cond. rewrite <- B, <- C. + destruct (peq (U.repr u s1) pc). auto. + destruct (peq (U.repr u p) pc); lia. +Qed. -+ (* b is Lbranch s, u becomes union u pc s, f becomes measure_edge u pc s f *) - rewrite B. - red. intro pc'. simpl. rewrite PTree.gsspec. destruct (peq pc' pc). subst pc'. rewrite EQ. +Definition code_compat (c: code) : Prop := + forall pc b, c!pc = Some b -> fn.(fn_code)!pc = Some b. -* (* The new instruction *) - rewrite (U.repr_union_2 u pc s); auto. rewrite U.repr_union_3. - unfold measure_edge. destruct (peq (U.repr u s) pc). auto. right. split. auto. - rewrite PC. rewrite peq_true. omega. - -* (* An old instruction *) - assert (U.repr u pc' = pc' -> U.repr (U.union u pc s) pc' = pc'). - { intro. rewrite <- H2 at 2. apply U.repr_union_1. congruence. } - generalize (H1 pc'). simpl. destruct (m!pc'); auto. destruct b; auto. destruct i; auto. - intros [P | [P Q]]. left; auto. right. - split. apply U.sameclass_union_2. auto. - unfold measure_edge. destruct (peq (U.repr u s) pc). auto. - rewrite P. destruct (peq (U.repr u s0) pc). omega. auto. +Definition code_invariant (c0 c1 c2: code) : Prop := + forall pc, c0!pc = None -> c1!pc = c2!pc. + +Lemma record_conds_1_correct: + forall c u f, + branch_map_correct_2 c u f -> + code_compat c -> + let '(c', u', _) := record_conds_1 (c, u) in + (code_compat c' * { f' | branch_map_correct_2 c' u' f' })%type. +Proof. + intros c0 u0 f0 BMC0 COMPAT0. + unfold record_conds_1. + set (x := PTree.fold record_cond c0 (c0, u0, false)). + set (P := fun (cd: code) (cuc: code * U.t * bool) => + (code_compat (fst (fst cuc)) * + code_invariant cd (fst (fst cuc)) c0 * + { f | branch_map_correct_2 (fst (fst cuc)) (snd (fst cuc)) f })%type). + assert (REC: P c0 x). + { unfold x; apply PTree_Properties.fold_ind. + - intros cd EMPTY. split; [split|]; simpl. + + auto. + + red; auto. + + exists f0; auto. + - intros cd [[c u] changed] pc b GET1 GET2 [[COMPAT INV] [f BMC]]. simpl in *. + split; [split|]. + + unfold record_cond; destruct b as [ | [] b]; simpl; auto. + destruct (peq (U.repr u s1) (U.repr u s2)); simpl; auto. + red; intros. rewrite PTree.grspec in H. destruct (PTree.elt_eq pc0 pc). discriminate. auto. + + assert (DFL: code_invariant cd c c0). + { intros p GET. apply INV. rewrite PTree.gro by congruence. auto. } + unfold record_cond; destruct b as [ | [] b]; simpl; auto. + destruct (peq (U.repr u s1) (U.repr u s2)); simpl; auto. + intros p GET. rewrite PTree.gro by congruence. apply INV. rewrite PTree.gro by congruence. auto. + + assert (GET3: c!pc = Some b). + { rewrite <- GET2. apply INV. apply PTree.grs. } + assert (X: fn.(fn_code)!pc = Some b) by auto. + assert (Y: c!pc <> None) by congruence. + generalize (record_cond_correct c u changed f pc b BMC X Y). + destruct (record_cond (c, u, changed) pc b) as [[c1 u1] changed1]; simpl. + auto. + } + destruct x as [[c1 u1] changed1]; destruct REC as [[COMPAT1 INV1] BMC1]; auto. Qed. -Definition record_gotos' (f: function) := - PTree.fold record_goto' f.(fn_code) (U.empty, fun (x: node) => O). +Definition branch_map_correct (u: U.t) (f: node -> nat): Prop := + forall pc, + match fn.(fn_code)!pc with + | Some(Lbranch s :: b) => + U.repr u pc = pc \/ (U.repr u pc = U.repr u s /\ f s < f pc)%nat + | Some(Lcond cond args s1 s2 :: b) => + U.repr u pc = pc \/ (U.repr u pc = U.repr u s1 /\ U.repr u pc = U.repr u s2 /\ f s1 < f pc /\ f s2 < f pc)%nat + | _ => + U.repr u pc = pc + end. -Lemma record_gotos_gotos': - forall f, fst (record_gotos' f) = record_gotos f. +Lemma record_conds_correct: + forall cu, + { f | branch_map_correct_2 (fst cu) (snd cu) f } -> + code_compat (fst cu) -> + { f | branch_map_correct (record_conds cu) f }. Proof. - intros. unfold record_gotos', record_gotos. - repeat rewrite PTree.fold_spec. - generalize (PTree.elements (fn_code f)) (U.empty) (fun _ : node => O). - induction l; intros; simpl. - auto. - unfold record_goto' at 2. unfold record_goto at 2. - destruct (snd a). apply IHl. destruct i; apply IHl. + intros cu0. functional induction (record_conds cu0); intros. +- destruct cu as [c u], cu' as [c' u'], H as [f BMC]. + generalize (record_conds_1_correct c u f BMC H0). + rewrite e. intros [U V]. apply IHt; auto. +- destruct cu as [c u], H as [f BMC]. + exists f. intros pc. specialize (BMC pc); simpl in *. + destruct (fn_code fn)!pc as [ [ | [] b ] | ]; tauto. Qed. -Definition branch_target (f: function) (pc: node) : node := - U.repr (record_gotos f) pc. +Lemma record_gotos_correct_1: + { f | branch_map_correct (record_gotos fn) f }. +Proof. + apply record_conds_correct; simpl. +- destruct record_branches_correct as [f BMC]. + exists f. intros pc. specialize (BMC pc); simpl in *. + destruct (fn_code fn)!pc as [ [ | [] b ] | ]; auto. +- red; auto. +Qed. -Definition count_gotos (f: function) (pc: node) : nat := - snd (record_gotos' f) pc. +Definition branch_target (pc: node) : node := + U.repr (record_gotos fn) pc. + +Definition count_gotos (pc: node) : nat := + proj1_sig record_gotos_correct_1 pc. Theorem record_gotos_correct: - forall f pc, - match f.(fn_code)!pc with + forall pc, + match fn.(fn_code)!pc with | Some(Lbranch s :: b) => - branch_target f pc = pc \/ - (branch_target f pc = branch_target f s /\ count_gotos f s < count_gotos f pc)%nat - | _ => branch_target f pc = pc + branch_target pc = pc \/ + (branch_target pc = branch_target s /\ count_gotos s < count_gotos pc)%nat + | Some(Lcond cond args s1 s2 :: b) => + branch_target pc = pc \/ + (branch_target pc = branch_target s1 /\ branch_target pc = branch_target s2 + /\ count_gotos s1 < count_gotos pc /\ count_gotos s2 < count_gotos pc)%nat + | _ => + branch_target pc = pc end. Proof. - intros. - generalize (record_gotos'_correct f.(fn_code) pc). simpl. - fold (record_gotos' f). unfold branch_map_correct, branch_target, count_gotos. - rewrite record_gotos_gotos'. auto. + intros. unfold count_gotos. destruct record_gotos_correct_1 as [f P]; simpl. + apply P. Qed. +End BRANCH_MAP_CORRECT. + (** * Preservation of semantics *) Section PRESERVATION. @@ -226,13 +347,21 @@ Inductive match_states: state -> state -> Prop := (MEM: Mem.extends m tm), match_states (Block s f sp bb ls m) (Block ts (tunnel_function f) sp (tunneled_block f bb) tls tm) - | match_states_interm: + | match_states_interm_branch: forall s f sp pc bb ls m ts tls tm (STK: list_forall2 match_stackframes s ts) (LS: locmap_lessdef ls tls) (MEM: Mem.extends m tm), match_states (Block s f sp (Lbranch pc :: bb) ls m) (State ts (tunnel_function f) sp (branch_target f pc) tls tm) + | match_states_interm_cond: + forall s f sp cond args pc1 pc2 bb ls m ts tls tm + (STK: list_forall2 match_stackframes s ts) + (LS: locmap_lessdef ls tls) + (MEM: Mem.extends m tm) + (SAME: branch_target f pc1 = branch_target f pc2), + match_states (Block s f sp (Lcond cond args pc1 pc2 :: bb) ls m) + (State ts (tunnel_function f) sp (branch_target f pc1) tls tm) | match_states_call: forall s f ls m ts tls tm (STK: list_forall2 match_stackframes s ts) @@ -385,6 +514,7 @@ Definition measure (st: state) : nat := match st with | State s f sp pc ls m => (count_gotos f pc * 2)%nat | Block s f sp (Lbranch pc :: _) ls m => (count_gotos f pc * 2 + 1)%nat + | Block s f sp (Lcond _ _ pc1 pc2 :: _) ls m => (Nat.max (count_gotos f pc1) (count_gotos f pc2) * 2 + 1)%nat | Block s f sp bb ls m => 0%nat | Callstate s f ls m => 0%nat | Returnstate s ls m => 0%nat @@ -419,10 +549,16 @@ Proof. generalize (record_gotos_correct f pc). rewrite H. destruct bb; auto. destruct i; auto. ++ (* Lbranch *) intros [A | [B C]]. auto. - right. split. simpl. omega. + right. split. simpl. lia. split. auto. rewrite B. econstructor; eauto. ++ (* Lcond *) + intros [A | (B & C & D & E)]. auto. + right. split. simpl. lia. + split. auto. + rewrite B. econstructor; eauto. congruence. - (* Lop *) exploit eval_operation_lessdef. apply reglist_lessdef; eauto. eauto. eauto. @@ -487,20 +623,26 @@ Proof. eapply exec_Lbranch; eauto. fold (branch_target f pc). econstructor; eauto. - (* Lbranch (eliminated) *) - right; split. simpl. omega. split. auto. constructor; auto. + right; split. simpl. lia. split. auto. constructor; auto. -- (* Lcond *) +- (* Lcond (preserved) *) simpl tunneled_block. set (s1 := U.repr (record_gotos f) pc1). set (s2 := U.repr (record_gotos f) pc2). destruct (peq s1 s2). + left; econstructor; split. - eapply exec_Lbranch. - destruct b. -* constructor; eauto using locmap_undef_regs_lessdef_1. -* rewrite e. constructor; eauto using locmap_undef_regs_lessdef_1. + eapply exec_Lbranch. + set (pc := if b then pc1 else pc2). + replace s1 with (branch_target f pc) by (unfold pc; destruct b; auto). + constructor; eauto using locmap_undef_regs_lessdef_1. + left; econstructor; split. eapply exec_Lcond; eauto. eapply eval_condition_lessdef; eauto using reglist_lessdef. destruct b; econstructor; eauto using locmap_undef_regs_lessdef. +- (* Lcond (eliminated) *) + right; split. simpl. destruct b; lia. + split. auto. + set (pc := if b then pc1 else pc2). + replace (branch_target f pc1) with (branch_target f pc) by (unfold pc; destruct b; auto). + econstructor; eauto. - (* Ljumptable *) assert (tls (R arg) = Vint n). diff --git a/backend/Unusedglobproof.v b/backend/Unusedglobproof.v index 680daba7..3216ec50 100644 --- a/backend/Unusedglobproof.v +++ b/backend/Unusedglobproof.v @@ -982,7 +982,7 @@ Proof. intros. exploit G; eauto. intros [U V]. assert (Mem.valid_block m sp0) by (eapply Mem.valid_block_inject_1; eauto). assert (Mem.valid_block tm tsp) by (eapply Mem.valid_block_inject_2; eauto). - unfold Mem.valid_block in *; xomega. + unfold Mem.valid_block in *; extlia. apply set_res_inject; auto. apply regset_inject_incr with j; auto. - (* cond *) @@ -1036,7 +1036,7 @@ Proof. apply match_stacks_bound with (Mem.nextblock m) (Mem.nextblock tm). apply match_stacks_incr with j; auto. intros. exploit G; eauto. intros [P Q]. - unfold Mem.valid_block in *; xomega. + unfold Mem.valid_block in *; extlia. eapply external_call_nextblock; eauto. eapply external_call_nextblock; eauto. @@ -1063,7 +1063,7 @@ Proof. - apply IHl. unfold Genv.add_global, P; simpl. intros LT. apply Plt_succ_inv in LT. destruct LT. + rewrite PTree.gso. apply H; auto. apply Plt_ne; auto. + rewrite H0. rewrite PTree.gss. exists g1; auto. } - apply H. red; simpl; intros. exfalso; xomega. + apply H. red; simpl; intros. exfalso; extlia. Qed. *) @@ -1123,10 +1123,10 @@ Lemma Mem_getN_forall2: P (ZMap.get i c1) (ZMap.get i c2). Proof. induction n; simpl Mem.getN; intros. -- simpl in H1. omegaContradiction. +- simpl in H1. extlia. - inv H. rewrite Nat2Z.inj_succ in H1. destruct (zeq i p0). + congruence. -+ apply IHn with (p0 + 1); auto. omega. omega. ++ apply IHn with (p0 + 1); auto. lia. lia. Qed. Lemma init_mem_inj_1: @@ -1143,7 +1143,7 @@ Proof. + intros (P2 & Q2 & R2 & S2) (P1 & Q1 & R1 & S1). apply Q1 in H0. destruct H0. subst. apply Mem.perm_cur. eapply Mem.perm_implies; eauto. - apply P2. omega. + apply P2. lia. - exploit init_meminj_invert; eauto. intros (A & id & B & C). subst delta. apply Z.divide_0_r. - exploit init_meminj_invert_strong; eauto. intros (A & id & gd & B & C & D & E & F). @@ -1162,8 +1162,8 @@ Local Transparent Mem.loadbytes. rewrite Z.add_0_r. apply Mem_getN_forall2 with (p := 0) (n := Z.to_nat (init_data_list_size (gvar_init v))). rewrite H3, H4. apply bytes_of_init_inject. auto. - omega. - rewrite Z2Nat.id by (apply Z.ge_le; apply init_data_list_size_pos). omega. + lia. + rewrite Z2Nat.id by (apply Z.ge_le; apply init_data_list_size_pos). lia. Qed. Lemma init_mem_inj_2: @@ -1181,18 +1181,18 @@ Proof. exploit init_meminj_invert. eexact H1. intros (A2 & id2 & B2 & C2). destruct (ident_eq id1 id2). congruence. left; eapply Genv.global_addresses_distinct; eauto. - exploit init_meminj_invert; eauto. intros (A & id & B & C). subst delta. - split. omega. generalize (Ptrofs.unsigned_range_2 ofs). omega. + split. lia. generalize (Ptrofs.unsigned_range_2 ofs). lia. - exploit init_meminj_invert_strong; eauto. intros (A & id & gd & B & C & D & E & F). exploit (Genv.init_mem_characterization_gen p); eauto. exploit (Genv.init_mem_characterization_gen tp); eauto. destruct gd as [f|v]. + intros (P2 & Q2) (P1 & Q1). - apply Q2 in H0. destruct H0. subst. replace ofs with 0 by omega. + apply Q2 in H0. destruct H0. subst. replace ofs with 0 by lia. left; apply Mem.perm_cur; auto. + intros (P2 & Q2 & R2 & S2) (P1 & Q1 & R1 & S1). apply Q2 in H0. destruct H0. subst. left. apply Mem.perm_cur. eapply Mem.perm_implies; eauto. - apply P1. omega. + apply P1. lia. Qed. End INIT_MEM. diff --git a/backend/ValueAnalysis.v b/backend/ValueAnalysis.v index b0ce019c..ebf2c5ea 100644 --- a/backend/ValueAnalysis.v +++ b/backend/ValueAnalysis.v @@ -342,7 +342,7 @@ Proof. induction rl; simpl; intros. constructor. constructor; auto. apply areg_sound; auto. Qed. -Hint Resolve areg_sound aregs_sound: va. +Global Hint Resolve areg_sound aregs_sound: va. Lemma abuiltin_arg_sound: forall bc ge rs sp m ae rm am, @@ -544,8 +544,8 @@ Proof. eapply SM; auto. eapply mmatch_top; eauto. + (* below *) red; simpl; intros. rewrite NB. destruct (eq_block b sp). - subst b; rewrite SP; xomega. - exploit mmatch_below; eauto. xomega. + subst b; rewrite SP; extlia. + exploit mmatch_below; eauto. extlia. - (* unchanged *) simpl; intros. apply dec_eq_false. apply Plt_ne. auto. - (* values *) @@ -1147,11 +1147,11 @@ Proof. - constructor. - assert (Plt sp bound') by eauto with va. eapply sound_stack_public_call; eauto. apply IHsound_stack; intros. - apply INV. xomega. rewrite SAME; auto with ordered_type. xomega. auto. auto. + apply INV. extlia. rewrite SAME; auto with ordered_type. extlia. auto. auto. - assert (Plt sp bound') by eauto with va. eapply sound_stack_private_call; eauto. apply IHsound_stack; intros. - apply INV. xomega. rewrite SAME; auto with ordered_type. xomega. auto. auto. - apply bmatch_ext with m; auto. intros. apply INV. xomega. auto. auto. auto. + apply INV. extlia. rewrite SAME; auto with ordered_type. extlia. auto. auto. + apply bmatch_ext with m; auto. intros. apply INV. extlia. auto. auto. auto. Qed. Lemma sound_stack_inv: @@ -1210,8 +1210,8 @@ Lemma sound_stack_new_bound: Proof. intros. inv H. - constructor. -- eapply sound_stack_public_call with (bound' := bound'0); eauto. xomega. -- eapply sound_stack_private_call with (bound' := bound'0); eauto. xomega. +- eapply sound_stack_public_call with (bound' := bound'0); eauto. extlia. +- eapply sound_stack_private_call with (bound' := bound'0); eauto. extlia. Qed. Lemma sound_stack_exten: @@ -1224,12 +1224,12 @@ Proof. - constructor. - assert (Plt sp bound') by eauto with va. eapply sound_stack_public_call; eauto. - rewrite H0; auto. xomega. - intros. rewrite H0; auto. xomega. + rewrite H0; auto. extlia. + intros. rewrite H0; auto. extlia. - assert (Plt sp bound') by eauto with va. eapply sound_stack_private_call; eauto. - rewrite H0; auto. xomega. - intros. rewrite H0; auto. xomega. + rewrite H0; auto. extlia. + intros. rewrite H0; auto. extlia. Qed. (** ** Preservation of the semantic invariant by one step of execution *) @@ -1912,7 +1912,7 @@ Proof. - exact NOSTACK. Qed. -Hint Resolve areg_sound aregs_sound: va. +Global Hint Resolve areg_sound aregs_sound: va. (** * Interface with other optimizations *) diff --git a/backend/ValueDomain.v b/backend/ValueDomain.v index c132ce7c..01f080ff 100644 --- a/backend/ValueDomain.v +++ b/backend/ValueDomain.v @@ -43,12 +43,12 @@ Proof. elim H. apply H0; auto. Qed. -Hint Extern 2 (_ = _) => congruence : va. -Hint Extern 2 (_ <> _) => congruence : va. -Hint Extern 2 (_ < _) => xomega : va. -Hint Extern 2 (_ <= _) => xomega : va. -Hint Extern 2 (_ > _) => xomega : va. -Hint Extern 2 (_ >= _) => xomega : va. +Global Hint Extern 2 (_ = _) => congruence : va. +Global Hint Extern 2 (_ <> _) => congruence : va. +Global Hint Extern 2 (_ < _) => extlia : va. +Global Hint Extern 2 (_ <= _) => extlia : va. +Global Hint Extern 2 (_ > _) => extlia : va. +Global Hint Extern 2 (_ >= _) => extlia : va. Section MATCH. @@ -595,17 +595,17 @@ Hint Extern 1 (vmatch _ _) => constructor : va. Lemma is_uns_mon: forall n1 n2 i, is_uns n1 i -> n1 <= n2 -> is_uns n2 i. Proof. - intros; red; intros. apply H; omega. + intros; red; intros. apply H; lia. Qed. Lemma is_sgn_mon: forall n1 n2 i, is_sgn n1 i -> n1 <= n2 -> is_sgn n2 i. Proof. - intros; red; intros. apply H; omega. + intros; red; intros. apply H; lia. Qed. Lemma is_uns_sgn: forall n1 n2 i, is_uns n1 i -> n1 < n2 -> is_sgn n2 i. Proof. - intros; red; intros. rewrite ! H by omega. auto. + intros; red; intros. rewrite ! H by lia. auto. Qed. Definition usize := Int.size. @@ -616,7 +616,7 @@ Lemma is_uns_usize: forall i, is_uns (usize i) i. Proof. unfold usize; intros; red; intros. - apply Int.bits_size_2. omega. + apply Int.bits_size_2. lia. Qed. Lemma is_sgn_ssize: @@ -628,10 +628,10 @@ Proof. rewrite <- (negb_involutive (Int.testbit i (Int.zwordsize - 1))). f_equal. generalize (Int.size_range (Int.not i)); intros RANGE. - rewrite <- ! Int.bits_not by omega. - rewrite ! Int.bits_size_2 by omega. + rewrite <- ! Int.bits_not by lia. + rewrite ! Int.bits_size_2 by lia. auto. -- rewrite ! Int.bits_size_2 by omega. +- rewrite ! Int.bits_size_2 by lia. auto. Qed. @@ -639,8 +639,8 @@ Lemma is_uns_zero_ext: forall n i, is_uns n i <-> Int.zero_ext n i = i. Proof. intros; split; intros. - Int.bit_solve. destruct (zlt i0 n); auto. symmetry; apply H; auto. omega. - rewrite <- H. red; intros. rewrite Int.bits_zero_ext by omega. rewrite zlt_false by omega. auto. + Int.bit_solve. destruct (zlt i0 n); auto. symmetry; apply H; auto. lia. + rewrite <- H. red; intros. rewrite Int.bits_zero_ext by lia. rewrite zlt_false by lia. auto. Qed. Lemma is_sgn_sign_ext: @@ -649,18 +649,18 @@ Proof. intros; split; intros. Int.bit_solve. destruct (zlt i0 n); auto. transitivity (Int.testbit i (Int.zwordsize - 1)). - apply H0; omega. symmetry; apply H0; omega. - rewrite <- H0. red; intros. rewrite ! Int.bits_sign_ext by omega. - f_equal. transitivity (n-1). destruct (zlt m n); omega. - destruct (zlt (Int.zwordsize - 1) n); omega. + apply H0; lia. symmetry; apply H0; lia. + rewrite <- H0. red; intros. rewrite ! Int.bits_sign_ext by lia. + f_equal. transitivity (n-1). destruct (zlt m n); lia. + destruct (zlt (Int.zwordsize - 1) n); lia. Qed. Lemma is_zero_ext_uns: forall i n m, is_uns m i \/ n <= m -> is_uns m (Int.zero_ext n i). Proof. - intros. red; intros. rewrite Int.bits_zero_ext by omega. - destruct (zlt m0 n); auto. destruct H. apply H; omega. omegaContradiction. + intros. red; intros. rewrite Int.bits_zero_ext by lia. + destruct (zlt m0 n); auto. destruct H. apply H; lia. extlia. Qed. Lemma is_zero_ext_sgn: @@ -668,9 +668,9 @@ Lemma is_zero_ext_sgn: n < m -> is_sgn m (Int.zero_ext n i). Proof. - intros. red; intros. rewrite ! Int.bits_zero_ext by omega. - transitivity false. apply zlt_false; omega. - symmetry; apply zlt_false; omega. + intros. red; intros. rewrite ! Int.bits_zero_ext by lia. + transitivity false. apply zlt_false; lia. + symmetry; apply zlt_false; lia. Qed. Lemma is_sign_ext_uns: @@ -679,8 +679,8 @@ Lemma is_sign_ext_uns: is_uns m i -> is_uns m (Int.sign_ext n i). Proof. - intros; red; intros. rewrite Int.bits_sign_ext by omega. - apply H0. destruct (zlt m0 n); omega. destruct (zlt m0 n); omega. + intros; red; intros. rewrite Int.bits_sign_ext by lia. + apply H0. destruct (zlt m0 n); lia. destruct (zlt m0 n); lia. Qed. Lemma is_sign_ext_sgn: @@ -690,9 +690,9 @@ Lemma is_sign_ext_sgn: Proof. intros. apply is_sgn_sign_ext; auto. destruct (zlt m n). destruct H1. apply is_sgn_sign_ext in H1; auto. - rewrite <- H1. rewrite (Int.sign_ext_widen i) by omega. apply Int.sign_ext_idem; auto. - omegaContradiction. - apply Int.sign_ext_widen; omega. + rewrite <- H1. rewrite (Int.sign_ext_widen i) by lia. apply Int.sign_ext_idem; auto. + extlia. + apply Int.sign_ext_widen; lia. Qed. Hint Resolve is_uns_mon is_sgn_mon is_uns_sgn is_uns_usize is_sgn_ssize : va. @@ -701,8 +701,8 @@ Lemma is_uns_1: forall n, is_uns 1 n -> n = Int.zero \/ n = Int.one. Proof. intros. destruct (Int.testbit n 0) eqn:B0; [right|left]; apply Int.same_bits_eq; intros. - rewrite Int.bits_one. destruct (zeq i 0). subst i; auto. apply H; omega. - rewrite Int.bits_zero. destruct (zeq i 0). subst i; auto. apply H; omega. + rewrite Int.bits_one. destruct (zeq i 0). subst i; auto. apply H; lia. + rewrite Int.bits_zero. destruct (zeq i 0). subst i; auto. apply H; lia. Qed. (** Tracking leakage of pointers through arithmetic operations. @@ -958,13 +958,13 @@ Hint Resolve vge_uns_uns' vge_uns_i' vge_sgn_sgn' vge_sgn_i' : va. Lemma usize_pos: forall n, 0 <= usize n. Proof. - unfold usize; intros. generalize (Int.size_range n); omega. + unfold usize; intros. generalize (Int.size_range n); lia. Qed. Lemma ssize_pos: forall n, 0 < ssize n. Proof. unfold ssize; intros. - generalize (Int.size_range (if Int.lt n Int.zero then Int.not n else n)); omega. + generalize (Int.size_range (if Int.lt n Int.zero then Int.not n else n)); lia. Qed. Lemma vge_lub_l: @@ -975,12 +975,12 @@ Proof. unfold vlub; destruct x, y; eauto using pge_lub_l with va. - predSpec Int.eq Int.eq_spec n n0. auto with va. destruct (Int.lt n Int.zero || Int.lt n0 Int.zero). - apply vge_sgn_i'. generalize (ssize_pos n); xomega. eauto with va. - apply vge_uns_i'. generalize (usize_pos n); xomega. eauto with va. + apply vge_sgn_i'. generalize (ssize_pos n); extlia. eauto with va. + apply vge_uns_i'. generalize (usize_pos n); extlia. eauto with va. - destruct (Int.lt n Int.zero). - apply vge_sgn_i'. generalize (ssize_pos n); xomega. eauto with va. - apply vge_uns_i'. generalize (usize_pos n); xomega. eauto with va. -- apply vge_sgn_i'. generalize (ssize_pos n); xomega. eauto with va. + apply vge_sgn_i'. generalize (ssize_pos n); extlia. eauto with va. + apply vge_uns_i'. generalize (usize_pos n); extlia. eauto with va. +- apply vge_sgn_i'. generalize (ssize_pos n); extlia. eauto with va. - destruct (Int.lt n0 Int.zero). eapply vge_trans. apply vge_sgn_sgn'. apply vge_trans with (Sgn p (n + 1)); eauto with va. @@ -1269,12 +1269,12 @@ Proof. destruct (Int.ltu n Int.iwordsize) eqn:LTU; auto. exploit Int.ltu_inv; eauto. intros RANGE. inv H; auto with va. -- apply vmatch_uns'. red; intros. rewrite Int.bits_shl by omega. - destruct (zlt m (Int.unsigned n)). auto. apply H1; xomega. +- apply vmatch_uns'. red; intros. rewrite Int.bits_shl by lia. + destruct (zlt m (Int.unsigned n)). auto. apply H1; extlia. - apply vmatch_sgn'. red; intros. zify. - rewrite ! Int.bits_shl by omega. - rewrite ! zlt_false by omega. - rewrite H1 by omega. symmetry. rewrite H1 by omega. auto. + rewrite ! Int.bits_shl by lia. + rewrite ! zlt_false by lia. + rewrite H1 by lia. symmetry. rewrite H1 by lia. auto. - destruct v; constructor. Qed. @@ -1306,13 +1306,13 @@ Proof. assert (DEFAULT2: forall i, vmatch (Vint (Int.shru i n)) (uns (provenance x) (Int.zwordsize - Int.unsigned n))). { intros. apply vmatch_uns. red; intros. - rewrite Int.bits_shru by omega. apply zlt_false. omega. + rewrite Int.bits_shru by lia. apply zlt_false. lia. } inv H; auto with va. - apply vmatch_uns'. red; intros. zify. - rewrite Int.bits_shru by omega. + rewrite Int.bits_shru by lia. destruct (zlt (m + Int.unsigned n) Int.zwordsize); auto. - apply H1; omega. + apply H1; lia. - destruct v; constructor. Qed. @@ -1345,22 +1345,22 @@ Proof. assert (DEFAULT2: forall i, vmatch (Vint (Int.shr i n)) (sgn (provenance x) (Int.zwordsize - Int.unsigned n))). { intros. apply vmatch_sgn. red; intros. - rewrite ! Int.bits_shr by omega. f_equal. + rewrite ! Int.bits_shr by lia. f_equal. destruct (zlt (m + Int.unsigned n) Int.zwordsize); destruct (zlt (Int.zwordsize - 1 + Int.unsigned n) Int.zwordsize); - omega. + lia. } assert (SGN: forall q i p, is_sgn p i -> 0 < p -> vmatch (Vint (Int.shr i n)) (sgn q (p - Int.unsigned n))). { intros. apply vmatch_sgn'. red; intros. zify. - rewrite ! Int.bits_shr by omega. + rewrite ! Int.bits_shr by lia. transitivity (Int.testbit i (Int.zwordsize - 1)). destruct (zlt (m + Int.unsigned n) Int.zwordsize). - apply H0; omega. + apply H0; lia. auto. symmetry. destruct (zlt (Int.zwordsize - 1 + Int.unsigned n) Int.zwordsize). - apply H0; omega. + apply H0; lia. auto. } inv H; eauto with va. @@ -1418,12 +1418,12 @@ Proof. assert (UNS: forall i j n m, is_uns n i -> is_uns m j -> is_uns (Z.max n m) (Int.or i j)). { intros; red; intros. rewrite Int.bits_or by auto. - rewrite H by xomega. rewrite H0 by xomega. auto. + rewrite H by extlia. rewrite H0 by extlia. auto. } assert (SGN: forall i j n m, is_sgn n i -> is_sgn m j -> is_sgn (Z.max n m) (Int.or i j)). { - intros; red; intros. rewrite ! Int.bits_or by xomega. - rewrite H by xomega. rewrite H0 by xomega. auto. + intros; red; intros. rewrite ! Int.bits_or by extlia. + rewrite H by extlia. rewrite H0 by extlia. auto. } intros. unfold or, Val.or; inv H; eauto with va; inv H0; eauto with va. Qed. @@ -1443,12 +1443,12 @@ Proof. assert (UNS: forall i j n m, is_uns n i -> is_uns m j -> is_uns (Z.max n m) (Int.xor i j)). { intros; red; intros. rewrite Int.bits_xor by auto. - rewrite H by xomega. rewrite H0 by xomega. auto. + rewrite H by extlia. rewrite H0 by extlia. auto. } assert (SGN: forall i j n m, is_sgn n i -> is_sgn m j -> is_sgn (Z.max n m) (Int.xor i j)). { - intros; red; intros. rewrite ! Int.bits_xor by xomega. - rewrite H by xomega. rewrite H0 by xomega. auto. + intros; red; intros. rewrite ! Int.bits_xor by extlia. + rewrite H by extlia. rewrite H0 by extlia. auto. } intros. unfold xor, Val.xor; inv H; eauto with va; inv H0; eauto with va. Qed. @@ -1466,7 +1466,7 @@ Lemma notint_sound: Proof. assert (SGN: forall n i, is_sgn n i -> is_sgn n (Int.not i)). { - intros; red; intros. rewrite ! Int.bits_not by omega. + intros; red; intros. rewrite ! Int.bits_not by lia. f_equal. apply H; auto. } intros. unfold Val.notint, notint; inv H; eauto with va. @@ -1492,13 +1492,13 @@ Proof. inv H; auto with va. - apply vmatch_uns. red; intros. rewrite Int.bits_rol by auto. generalize (Int.unsigned_range n); intros. - rewrite Z.mod_small by omega. - apply H1. omega. omega. + rewrite Z.mod_small by lia. + apply H1. lia. lia. - destruct (zlt n0 Int.zwordsize); auto with va. - apply vmatch_sgn. red; intros. rewrite ! Int.bits_rol by omega. + apply vmatch_sgn. red; intros. rewrite ! Int.bits_rol by lia. generalize (Int.unsigned_range n); intros. - rewrite ! Z.mod_small by omega. - rewrite H1 by omega. symmetry. rewrite H1 by omega. auto. + rewrite ! Z.mod_small by lia. + rewrite H1 by lia. symmetry. rewrite H1 by lia. auto. - destruct (zlt n0 Int.zwordsize); auto with va. Qed. @@ -1674,8 +1674,8 @@ Proof. generalize (Int.unsigned_range_2 j); intros RANGE. assert (Int.unsigned j <> 0). { red; intros; elim H. rewrite <- (Int.repr_unsigned j). rewrite H0. auto. } - exploit (Z_mod_lt (Int.unsigned i) (Int.unsigned j)). omega. intros MOD. - unfold Int.modu. rewrite Int.unsigned_repr. omega. omega. + exploit (Z_mod_lt (Int.unsigned i) (Int.unsigned j)). lia. intros MOD. + unfold Int.modu. rewrite Int.unsigned_repr. lia. lia. } intros. destruct v; destruct w; try discriminate; simpl in H1. destruct (Int.eq i0 Int.zero) eqn:Z; inv H1. @@ -2084,12 +2084,12 @@ Lemma zero_ext_sound: Proof. assert (DFL: forall nbits i, is_uns nbits (Int.zero_ext nbits i)). { - intros; red; intros. rewrite Int.bits_zero_ext by omega. apply zlt_false; auto. + intros; red; intros. rewrite Int.bits_zero_ext by lia. apply zlt_false; auto. } intros. inv H; simpl; auto with va. apply vmatch_uns. red; intros. zify. - rewrite Int.bits_zero_ext by omega. - destruct (zlt m nbits); auto. apply H1; omega. + rewrite Int.bits_zero_ext by lia. + destruct (zlt m nbits); auto. apply H1; lia. Qed. Definition sign_ext (nbits: Z) (v: aval) := @@ -2109,7 +2109,7 @@ Proof. intros. apply vmatch_sgn. apply is_sign_ext_sgn; auto with va. } intros. unfold sign_ext. destruct (zle nbits 0). -- destruct v; simpl; auto with va. constructor. omega. +- destruct v; simpl; auto with va. constructor. lia. rewrite Int.sign_ext_below by auto. red; intros; apply Int.bits_zero. - inv H; simpl; auto with va. + destruct (zlt n nbits); eauto with va. @@ -2514,26 +2514,26 @@ Proof. intros c [lo hi] x n; simpl; intros R. destruct c; unfold zcmp, proj_sumbool. - (* eq *) - destruct (zlt n lo). rewrite zeq_false by omega. constructor. - destruct (zlt hi n). rewrite zeq_false by omega. constructor. + destruct (zlt n lo). rewrite zeq_false by lia. constructor. + destruct (zlt hi n). rewrite zeq_false by lia. constructor. constructor. - (* ne *) constructor. - (* lt *) - destruct (zlt hi n). rewrite zlt_true by omega. constructor. - destruct (zle n lo). rewrite zlt_false by omega. constructor. + destruct (zlt hi n). rewrite zlt_true by lia. constructor. + destruct (zle n lo). rewrite zlt_false by lia. constructor. constructor. - (* le *) - destruct (zle hi n). rewrite zle_true by omega. constructor. - destruct (zlt n lo). rewrite zle_false by omega. constructor. + destruct (zle hi n). rewrite zle_true by lia. constructor. + destruct (zlt n lo). rewrite zle_false by lia. constructor. constructor. - (* gt *) - destruct (zlt n lo). rewrite zlt_true by omega. constructor. - destruct (zle hi n). rewrite zlt_false by omega. constructor. + destruct (zlt n lo). rewrite zlt_true by lia. constructor. + destruct (zle hi n). rewrite zlt_false by lia. constructor. constructor. - (* ge *) - destruct (zle n lo). rewrite zle_true by omega. constructor. - destruct (zlt hi n). rewrite zle_false by omega. constructor. + destruct (zle n lo). rewrite zle_true by lia. constructor. + destruct (zlt hi n). rewrite zle_false by lia. constructor. constructor. Qed. @@ -2567,10 +2567,10 @@ Lemma uintv_sound: forall n v, vmatch (Vint n) v -> fst (uintv v) <= Int.unsigned n <= snd (uintv v). Proof. intros. inv H; simpl; try (apply Int.unsigned_range_2). -- omega. +- lia. - destruct (zlt n0 Int.zwordsize); simpl. -+ rewrite is_uns_zero_ext in H2. rewrite <- H2. rewrite Int.zero_ext_mod by omega. - exploit (Z_mod_lt (Int.unsigned n) (two_p n0)). apply two_p_gt_ZERO; auto. omega. ++ rewrite is_uns_zero_ext in H2. rewrite <- H2. rewrite Int.zero_ext_mod by lia. + exploit (Z_mod_lt (Int.unsigned n) (two_p n0)). apply two_p_gt_ZERO; auto. lia. + apply Int.unsigned_range_2. Qed. @@ -2582,8 +2582,8 @@ Proof. intros. simpl. replace (Int.cmpu c n1 n2) with (zcmp c (Int.unsigned n1) (Int.unsigned n2)). apply zcmp_intv_sound; apply uintv_sound; auto. destruct c; simpl; auto. - unfold Int.ltu. destruct (zle (Int.unsigned n1) (Int.unsigned n2)); [rewrite zlt_false|rewrite zlt_true]; auto; omega. - unfold Int.ltu. destruct (zle (Int.unsigned n2) (Int.unsigned n1)); [rewrite zlt_false|rewrite zlt_true]; auto; omega. + unfold Int.ltu. destruct (zle (Int.unsigned n1) (Int.unsigned n2)); [rewrite zlt_false|rewrite zlt_true]; auto; lia. + unfold Int.ltu. destruct (zle (Int.unsigned n2) (Int.unsigned n1)); [rewrite zlt_false|rewrite zlt_true]; auto; lia. Qed. Lemma cmpu_intv_sound_2: @@ -2610,22 +2610,22 @@ Lemma sintv_sound: forall n v, vmatch (Vint n) v -> fst (sintv v) <= Int.signed n <= snd (sintv v). Proof. intros. inv H; simpl; try (apply Int.signed_range). -- omega. +- lia. - destruct (zlt n0 Int.zwordsize); simpl. + rewrite is_uns_zero_ext in H2. rewrite <- H2. - assert (Int.unsigned (Int.zero_ext n0 n) = Int.unsigned n mod two_p n0) by (apply Int.zero_ext_mod; omega). + assert (Int.unsigned (Int.zero_ext n0 n) = Int.unsigned n mod two_p n0) by (apply Int.zero_ext_mod; lia). exploit (Z_mod_lt (Int.unsigned n) (two_p n0)). apply two_p_gt_ZERO; auto. intros. replace (Int.signed (Int.zero_ext n0 n)) with (Int.unsigned (Int.zero_ext n0 n)). - rewrite H. omega. + rewrite H. lia. unfold Int.signed. rewrite zlt_true. auto. assert (two_p n0 <= Int.half_modulus). { change Int.half_modulus with (two_p (Int.zwordsize - 1)). - apply two_p_monotone. omega. } - omega. + apply two_p_monotone. lia. } + lia. + apply Int.signed_range. - destruct (zlt n0 (Int.zwordsize)); simpl. + rewrite is_sgn_sign_ext in H2 by auto. rewrite <- H2. - exploit (Int.sign_ext_range n0 n). omega. omega. + exploit (Int.sign_ext_range n0 n). lia. lia. + apply Int.signed_range. Qed. @@ -2637,8 +2637,8 @@ Proof. intros. simpl. replace (Int.cmp c n1 n2) with (zcmp c (Int.signed n1) (Int.signed n2)). apply zcmp_intv_sound; apply sintv_sound; auto. destruct c; simpl; rewrite ? Int.eq_signed; auto. - unfold Int.lt. destruct (zle (Int.signed n1) (Int.signed n2)); [rewrite zlt_false|rewrite zlt_true]; auto; omega. - unfold Int.lt. destruct (zle (Int.signed n2) (Int.signed n1)); [rewrite zlt_false|rewrite zlt_true]; auto; omega. + unfold Int.lt. destruct (zle (Int.signed n1) (Int.signed n2)); [rewrite zlt_false|rewrite zlt_true]; auto; lia. + unfold Int.lt. destruct (zle (Int.signed n2) (Int.signed n1)); [rewrite zlt_false|rewrite zlt_true]; auto; lia. Qed. Lemma cmp_intv_sound_2: @@ -2823,7 +2823,7 @@ Proof. assert (DEFAULT: vmatch (Val.of_optbool ob) (Uns Pbot 1)). { destruct ob; simpl; auto with va. - destruct b; constructor; try omega. + destruct b; constructor; try lia. change 1 with (usize Int.one). apply is_uns_usize. red; intros. apply Int.bits_zero. } @@ -2942,27 +2942,27 @@ Proof. - destruct (zlt n 8); constructor; auto with va. apply is_sign_ext_uns; auto. apply is_sign_ext_sgn; auto with va. -- constructor. xomega. apply is_zero_ext_uns. apply Z.min_case; auto with va. +- constructor. extlia. apply is_zero_ext_uns. apply Z.min_case; auto with va. - destruct (zlt n 16); constructor; auto with va. apply is_sign_ext_uns; auto. apply is_sign_ext_sgn; auto with va. -- constructor. xomega. apply is_zero_ext_uns. apply Z.min_case; auto with va. +- constructor. extlia. apply is_zero_ext_uns. apply Z.min_case; auto with va. - destruct (zlt n 8); auto with va. - destruct (zlt n 16); auto with va. -- constructor. xomega. apply is_sign_ext_sgn; auto with va. apply Z.min_case; auto with va. -- constructor. omega. apply is_zero_ext_uns; auto with va. -- constructor. xomega. apply is_sign_ext_sgn; auto with va. apply Z.min_case; auto with va. -- constructor. omega. apply is_zero_ext_uns; auto with va. +- constructor. extlia. apply is_sign_ext_sgn; auto with va. apply Z.min_case; auto with va. +- constructor. lia. apply is_zero_ext_uns; auto with va. +- constructor. extlia. apply is_sign_ext_sgn; auto with va. apply Z.min_case; auto with va. +- constructor. lia. apply is_zero_ext_uns; auto with va. - destruct ptr64; auto with va. - destruct ptr64; auto with va. - destruct ptr64; auto with va. - destruct ptr64; auto with va. - destruct ptr64; auto with va. - destruct ptr64; auto with va. -- constructor. omega. apply is_sign_ext_sgn; auto with va. -- constructor. omega. apply is_zero_ext_uns; auto with va. -- constructor. omega. apply is_sign_ext_sgn; auto with va. -- constructor. omega. apply is_zero_ext_uns; auto with va. +- constructor. lia. apply is_sign_ext_sgn; auto with va. +- constructor. lia. apply is_zero_ext_uns; auto with va. +- constructor. lia. apply is_sign_ext_sgn; auto with va. +- constructor. lia. apply is_zero_ext_uns; auto with va. - destruct ptr64; auto with va. - destruct ptr64; auto with va. - destruct ptr64; auto with va. @@ -2977,13 +2977,13 @@ Proof. intros. exploit Mem.load_cast; eauto. exploit Mem.load_type; eauto. destruct chunk; simpl; intros. - (* int8signed *) - rewrite H2. destruct v; simpl; constructor. omega. apply is_sign_ext_sgn; auto with va. + rewrite H2. destruct v; simpl; constructor. lia. apply is_sign_ext_sgn; auto with va. - (* int8unsigned *) - rewrite H2. destruct v; simpl; constructor. omega. apply is_zero_ext_uns; auto with va. + rewrite H2. destruct v; simpl; constructor. lia. apply is_zero_ext_uns; auto with va. - (* int16signed *) - rewrite H2. destruct v; simpl; constructor. omega. apply is_sign_ext_sgn; auto with va. + rewrite H2. destruct v; simpl; constructor. lia. apply is_sign_ext_sgn; auto with va. - (* int16unsigned *) - rewrite H2. destruct v; simpl; constructor. omega. apply is_zero_ext_uns; auto with va. + rewrite H2. destruct v; simpl; constructor. lia. apply is_zero_ext_uns; auto with va. - (* int32 *) auto. - (* int64 *) @@ -3025,9 +3025,9 @@ Proof with (auto using provenance_monotone with va). apply is_sign_ext_sgn... - constructor... apply is_zero_ext_uns... apply Z.min_case... - unfold provenance; destruct (va_strict tt)... -- destruct (zlt n1 8). rewrite zlt_true by omega... +- destruct (zlt n1 8). rewrite zlt_true by lia... destruct (zlt n2 8)... -- destruct (zlt n1 16). rewrite zlt_true by omega... +- destruct (zlt n1 16). rewrite zlt_true by lia... destruct (zlt n2 16)... - constructor... apply is_sign_ext_sgn... apply Z.min_case... - constructor... apply is_zero_ext_uns... @@ -3148,7 +3148,7 @@ Function inval_after (lo: Z) (hi: Z) (c: ZTree.t acontent) { wf (Zwf lo) hi } : then inval_after lo (hi - 1) (ZTree.remove hi c) else c. Proof. - intros; red; omega. + intros; red; lia. apply Zwf_well_founded. Qed. @@ -3163,7 +3163,7 @@ Function inval_before (hi: Z) (lo: Z) (c: ZTree.t acontent) { wf (Zwf_up hi) lo then inval_before hi (lo + 1) (inval_if hi lo c) else c. Proof. - intros; red; omega. + intros; red; lia. apply Zwf_up_well_founded. Qed. @@ -3201,7 +3201,7 @@ Remark loadbytes_load_ext: Proof. intros. exploit Mem.load_loadbytes; eauto. intros [bytes [A B]]. exploit Mem.load_valid_access; eauto. intros [C D]. - subst v. apply Mem.loadbytes_load; auto. apply H; auto. generalize (size_chunk_pos chunk); omega. + subst v. apply Mem.loadbytes_load; auto. apply H; auto. generalize (size_chunk_pos chunk); lia. Qed. Lemma smatch_ext: @@ -3212,7 +3212,7 @@ Lemma smatch_ext: Proof. intros. destruct H. split; intros. eapply H; eauto. eapply loadbytes_load_ext; eauto. - eapply H1; eauto. apply H0; eauto. omega. + eapply H1; eauto. apply H0; eauto. lia. Qed. Lemma smatch_inv: @@ -3247,19 +3247,19 @@ Proof. + rewrite (Mem.loadbytes_empty m b ofs sz) in LOAD by auto. inv LOAD. contradiction. + exploit (Mem.loadbytes_split m b ofs 1 (sz - 1) bytes). - replace (1 + (sz - 1)) with sz by omega. auto. - omega. - omega. + replace (1 + (sz - 1)) with sz by lia. auto. + lia. + lia. intros (bytes1 & bytes2 & LOAD1 & LOAD2 & CONCAT). subst bytes. exploit Mem.loadbytes_length. eexact LOAD1. change (Z.to_nat 1) with 1%nat. intros LENGTH1. rewrite in_app_iff in IN. destruct IN. * destruct bytes1; try discriminate. destruct bytes1; try discriminate. simpl in H. destruct H; try contradiction. subst m0. - exists ofs; split. omega. auto. - * exploit (REC (sz - 1)). red; omega. eexact LOAD2. auto. + exists ofs; split. lia. auto. + * exploit (REC (sz - 1)). red; lia. eexact LOAD2. auto. intros (ofs' & A & B). - exists ofs'; split. omega. auto. + exists ofs'; split. lia. auto. Qed. Lemma smatch_loadbytes: @@ -3285,13 +3285,13 @@ Proof. - apply Zwf_well_founded. - intros sz REC ofs bytes LOAD LOAD1 IN. exploit (Mem.loadbytes_split m b ofs 1 (sz - 1) bytes). - replace (1 + (sz - 1)) with sz by omega. auto. - omega. - omega. + replace (1 + (sz - 1)) with sz by lia. auto. + lia. + lia. intros (bytes1 & bytes2 & LOAD3 & LOAD4 & CONCAT). subst bytes. rewrite in_app_iff. destruct (zeq ofs ofs'). + subst ofs'. rewrite LOAD1 in LOAD3; inv LOAD3. left; simpl; auto. -+ right. eapply (REC (sz - 1)). red; omega. eexact LOAD4. auto. omega. ++ right. eapply (REC (sz - 1)). red; lia. eexact LOAD4. auto. lia. Qed. Lemma storebytes_provenance: @@ -3309,10 +3309,10 @@ Proof. destruct (eq_block b' b); auto. destruct (zle (ofs' + 1) ofs); auto. destruct (zle (ofs + Z.of_nat (length bytes)) ofs'); auto. - right. split. auto. omega. + right. split. auto. lia. } destruct EITHER as [A | (A & B)]. -- right. rewrite <- H0. symmetry. eapply Mem.loadbytes_storebytes_other; eauto. omega. +- right. rewrite <- H0. symmetry. eapply Mem.loadbytes_storebytes_other; eauto. lia. - subst b'. left. eapply loadbytes_provenance; eauto. eapply Mem.loadbytes_storebytes_same; eauto. @@ -3457,7 +3457,7 @@ Remark inval_after_outside: forall i lo hi c, i < lo \/ i > hi -> (inval_after lo hi c)##i = c##i. Proof. intros until c. functional induction (inval_after lo hi c); intros. - rewrite IHt by omega. apply ZTree.gro. unfold ZTree.elt, ZIndexed.t; omega. + rewrite IHt by lia. apply ZTree.gro. unfold ZTree.elt, ZIndexed.t; lia. auto. Qed. @@ -3468,18 +3468,18 @@ Remark inval_after_contents: Proof. intros until c. functional induction (inval_after lo hi c); intros. destruct (zeq i hi). - subst i. rewrite inval_after_outside in H by omega. rewrite ZTree.grs in H. discriminate. - exploit IHt; eauto. intros [A B]. rewrite ZTree.gro in A by auto. split. auto. omega. - split. auto. omega. + subst i. rewrite inval_after_outside in H by lia. rewrite ZTree.grs in H. discriminate. + exploit IHt; eauto. intros [A B]. rewrite ZTree.gro in A by auto. split. auto. lia. + split. auto. lia. Qed. Remark inval_before_outside: forall i hi lo c, i < lo \/ i >= hi -> (inval_before hi lo c)##i = c##i. Proof. intros until c. functional induction (inval_before hi lo c); intros. - rewrite IHt by omega. unfold inval_if. destruct (c##lo) as [[chunk av]|]; auto. + rewrite IHt by lia. unfold inval_if. destruct (c##lo) as [[chunk av]|]; auto. destruct (zle (lo + size_chunk chunk) hi); auto. - apply ZTree.gro. unfold ZTree.elt, ZIndexed.t; omega. + apply ZTree.gro. unfold ZTree.elt, ZIndexed.t; lia. auto. Qed. @@ -3490,21 +3490,21 @@ Remark inval_before_contents_1: Proof. intros until c. functional induction (inval_before hi lo c); intros. - destruct (zeq lo i). -+ subst i. rewrite inval_before_outside in H0 by omega. ++ subst i. rewrite inval_before_outside in H0 by lia. unfold inval_if in H0. destruct (c##lo) as [[chunk0 v0]|] eqn:C; try congruence. destruct (zle (lo + size_chunk chunk0) hi). rewrite C in H0; inv H0. auto. rewrite ZTree.grs in H0. congruence. -+ exploit IHt. omega. auto. intros [A B]; split; auto. ++ exploit IHt. lia. auto. intros [A B]; split; auto. unfold inval_if in A. destruct (c##lo) as [[chunk0 v0]|] eqn:C; auto. destruct (zle (lo + size_chunk chunk0) hi); auto. rewrite ZTree.gro in A; auto. -- omegaContradiction. +- extlia. Qed. Lemma max_size_chunk: forall chunk, size_chunk chunk <= 8. Proof. - destruct chunk; simpl; omega. + destruct chunk; simpl; lia. Qed. Remark inval_before_contents: @@ -3513,12 +3513,12 @@ Remark inval_before_contents: c##j = Some (ACval chunk' av') /\ (j + size_chunk chunk' <= i \/ i <= j). Proof. intros. destruct (zlt j (i - 7)). - rewrite inval_before_outside in H by omega. - split. auto. left. generalize (max_size_chunk chunk'); omega. + rewrite inval_before_outside in H by lia. + split. auto. left. generalize (max_size_chunk chunk'); lia. destruct (zlt j i). - exploit inval_before_contents_1; eauto. omega. tauto. - rewrite inval_before_outside in H by omega. - split. auto. omega. + exploit inval_before_contents_1; eauto. lia. tauto. + rewrite inval_before_outside in H by lia. + split. auto. lia. Qed. Lemma ablock_store_contents: @@ -3534,7 +3534,7 @@ Proof. right. rewrite ZTree.gso in H by auto. exploit inval_before_contents; eauto. intros [A B]. exploit inval_after_contents; eauto. intros [C D]. - split. auto. omega. + split. auto. lia. Qed. Lemma chunk_compat_true: @@ -3604,7 +3604,7 @@ Proof. unfold ablock_storebytes; simpl; intros. exploit inval_before_contents; eauto. clear H. intros [A B]. exploit inval_after_contents; eauto. clear A. intros [C D]. - split. auto. xomega. + split. auto. extlia. Qed. Lemma ablock_storebytes_sound: @@ -3627,7 +3627,7 @@ Proof. exploit ablock_storebytes_contents; eauto. intros [A B]. assert (Mem.load chunk' m b ofs' = Some v'). { rewrite <- LOAD'; symmetry. eapply Mem.load_storebytes_other; eauto. - rewrite U. rewrite LENGTH. rewrite Z_to_nat_max. right; omega. } + rewrite U. rewrite LENGTH. rewrite Z_to_nat_max. right; lia. } exploit BM2; eauto. unfold ablock_load. rewrite A. rewrite COMPAT. auto. Qed. @@ -3755,7 +3755,7 @@ Proof. apply bmatch_inv with m; auto. + intros. eapply Mem.loadbytes_store_other; eauto. left. red; intros; subst b0. elim (C ofs). apply Mem.perm_cur_max. - apply P. generalize (size_chunk_pos chunk); omega. + apply P. generalize (size_chunk_pos chunk); lia. - intros; red; intros; elim (C ofs0). eauto with mem. Qed. @@ -4184,7 +4184,7 @@ Proof. - apply bmatch_ext with m; eauto with va. - apply smatch_ext with m; auto with va. - apply smatch_ext with m; auto with va. -- red; intros. exploit mmatch_below0; eauto. xomega. +- red; intros. exploit mmatch_below0; eauto. extlia. Qed. Lemma mmatch_free: @@ -4195,7 +4195,7 @@ Lemma mmatch_free: Proof. intros. apply mmatch_ext with m; auto. intros. eapply Mem.loadbytes_free_2; eauto. - erewrite <- Mem.nextblock_free by eauto. xomega. + erewrite <- Mem.nextblock_free by eauto. extlia. Qed. Lemma mmatch_top': @@ -4419,7 +4419,7 @@ Proof. { Local Transparent Mem.loadbytes. unfold Mem.loadbytes. rewrite pred_dec_true. reflexivity. - red; intros. replace ofs0 with ofs by omega. auto. + red; intros. replace ofs0 with ofs by lia. auto. } destruct mv; econstructor. destruct v; econstructor. apply inj_of_bc_valid. @@ -4440,7 +4440,7 @@ Proof. auto. - (* overflow *) intros. exploit inj_of_bc_inv; eauto. intros (A & B & C); subst. - rewrite Z.add_0_r. split. omega. apply Ptrofs.unsigned_range_2. + rewrite Z.add_0_r. split. lia. apply Ptrofs.unsigned_range_2. - (* perm inv *) intros. exploit inj_of_bc_inv; eauto. intros (A & B & C); subst. rewrite Z.add_0_r in H2. auto. @@ -4711,10 +4711,10 @@ Module VA <: SEMILATTICE. End VA. -Hint Constructors cmatch : va. -Hint Constructors pmatch: va. -Hint Constructors vmatch: va. -Hint Resolve cnot_sound symbol_address_sound +Global Hint Constructors cmatch : va. +Global Hint Constructors pmatch: va. +Global Hint Constructors vmatch: va. +Global Hint Resolve cnot_sound symbol_address_sound shl_sound shru_sound shr_sound and_sound or_sound xor_sound notint_sound ror_sound rolm_sound diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index ef028255..3c71718c 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -252,83 +253,11 @@ let builtins_generic = { (TVoid [], [TPtr(TVoid [], [])], false); - "__compcert_va_int32", - (TInt(IUInt, []), - [TPtr(TVoid [], [])], - false); - "__compcert_va_int64", - (TInt(IULongLong, []), - [TPtr(TVoid [], [])], - false); - "__compcert_va_float64", - (TFloat(FDouble, []), - [TPtr(TVoid [], [])], - false); - "__compcert_va_composite", - (TPtr(TVoid [], []), - [TPtr(TVoid [], []); TInt(IULong, [])], - false); - (* Helper functions for int64 arithmetic *) - "__compcert_i64_dtos", - (TInt(ILongLong, []), - [TFloat(FDouble, [])], - false); - "__compcert_i64_dtou", - (TInt(IULongLong, []), - [TFloat(FDouble, [])], - false); - "__compcert_i64_stod", - (TFloat(FDouble, []), - [TInt(ILongLong, [])], - false); - "__compcert_i64_utod", - (TFloat(FDouble, []), - [TInt(IULongLong, [])], - false); - "__compcert_i64_stof", - (TFloat(FFloat, []), - [TInt(ILongLong, [])], - false); - "__compcert_i64_utof", - (TFloat(FFloat, []), - [TInt(IULongLong, [])], - false); - "__compcert_i64_sdiv", - (TInt(ILongLong, []), - [TInt(ILongLong, []); TInt(ILongLong, [])], - false); - "__compcert_i64_udiv", - (TInt(IULongLong, []), - [TInt(IULongLong, []); TInt(IULongLong, [])], - false); - "__compcert_i64_smod", - (TInt(ILongLong, []), - [TInt(ILongLong, []); TInt(ILongLong, [])], - false); - "__compcert_i64_umod", - (TInt(IULongLong, []), - [TInt(IULongLong, []); TInt(IULongLong, [])], - false); - "__compcert_i64_shl", - (TInt(ILongLong, []), - [TInt(ILongLong, []); TInt(IInt, [])], - false); - "__compcert_i64_shr", - (TInt(IULongLong, []), - [TInt(IULongLong, []); TInt(IInt, [])], - false); - "__compcert_i64_sar", - (TInt(ILongLong, []), - [TInt(ILongLong, []); TInt(IInt, [])], - false); - "__compcert_i64_smulh", - (TInt(ILongLong, []), - [TInt(ILongLong, []); TInt(ILongLong, [])], - false); - "__compcert_i64_umulh", - (TInt(IULongLong, []), - [TInt(IULongLong, []); TInt(IULongLong, [])], - false) + (* Optimization hints *) + "__builtin_unreachable", + (TVoid [], [], false); + "__builtin_expect", + (TInt(ILong, []), [TInt(ILong, []); TInt(ILong, [])], false) ] } @@ -552,10 +481,16 @@ let convertAttr a = let n = Cutil.alignas_attribute a in if n > 0 then Some (N.of_int (log2 n)) else None } -let convertCallconv va unproto attr = +let convertCallconv _tres targs va attr = + let vararg = + match targs with + | None -> None + | Some tl -> if va then Some (Z.of_uint (List.length tl)) else None in let sr = Cutil.find_custom_attributes ["structreturn"; "__structreturn"] attr in - { AST.cc_vararg = va; cc_unproto = unproto; cc_structret = sr <> [] } + { AST.cc_vararg = vararg; + AST.cc_unproto = (targs = None); + AST.cc_structret = (sr <> []) } (** Types *) @@ -600,7 +535,7 @@ let checkFunctionType env tres targs = end end -let rec convertTyp env t = +let rec convertTyp env ?bitwidth t = match t with | C.TVoid a -> Tvoid | C.TInt(ik, a) -> @@ -623,7 +558,7 @@ let rec convertTyp env t = | Some tl -> convertParams env tl end, convertTyp env tres, - convertCallconv va (targs = None) a) + convertCallconv tres targs va a) | C.TNamed _ -> convertTyp env (Cutil.unroll env t) | C.TStruct(id, a) -> @@ -631,7 +566,21 @@ let rec convertTyp env t = | C.TUnion(id, a) -> Tunion(intern_string id.name, convertAttr a) | C.TEnum(id, a) -> - convertIkind Cutil.enum_ikind (convertAttr a) + let ik = + match bitwidth with + | None -> Cutil.enum_ikind + | Some w -> + let info = Env.find_enum env id in + let representable sg = + List.for_all (fun (_, v, _) -> Cutil.int_representable v w sg) + info.Env.ei_members in + if representable false then + Cutil.unsigned_ikind_of Cutil.enum_ikind + else if representable true then + Cutil.signed_ikind_of Cutil.enum_ikind + else + Cutil.enum_ikind in + convertIkind ik (convertAttr a) and convertParams env = function | [] -> Tnil @@ -667,9 +616,16 @@ let rec convertTypAnnotArgs env = function convertTypAnnotArgs env el) let convertField env f = - if f.fld_bitfield <> None then - unsupported "bit field in struct or union (consider adding option [-fbitfields])"; - (intern_string f.fld_name, convertTyp env f.fld_typ) + let id = intern_string f.fld_name + and ty = convertTyp env ?bitwidth: f.fld_bitfield f.fld_typ in + match f.fld_bitfield with + | None -> Member_plain(id, ty) + | Some w -> + match ty with + | Tint(sz, sg, attr) -> + Member_bitfield(id, sz, sg, attr, Z.of_uint w, f.fld_name = "") + | _ -> + fatal_error "bitfield must have type int" let convertCompositedef env su id attr members = if Cutil.find_custom_attributes ["packed";"__packed__"] attr <> [] then @@ -772,6 +728,11 @@ let convertFloat f kind = (** Expressions *) +let check_volatile_bitfield env e = + if Cutil.is_bitfield env e + && List.mem AVolatile (Cutil.attributes_of_type env e.etyp) then + warning Diagnostics.Unnamed "access to a volatile bit field, the 'volatile' qualifier is ignored" + let ezero = Eval(Vint(coqint_of_camlint 0l), type_int32s) let ewrap = function @@ -786,6 +747,7 @@ let rec convertExpr env e = | C.EUnop((C.Oderef|C.Odot _|C.Oarrow _), _) | C.EBinop(C.Oindex, _, _, _) -> let l = convertLvalue env e in + check_volatile_bitfield env e; ewrap (Ctyping.evalof l) | C.EConst(C.CInt(i, k, _)) -> @@ -855,6 +817,7 @@ let rec convertExpr env e = if Cutil.is_composite_type env e2.etyp && List.mem AVolatile (Cutil.attributes_of_type env e2.etyp) then warning Diagnostics.Unnamed "assignment of a value of volatile composite type, the 'volatile' qualifier is ignored"; + check_volatile_bitfield env e1; ewrap (Ctyping.eassign e1' e2') | C.EBinop((C.Oadd_assign|C.Osub_assign|C.Omul_assign|C.Odiv_assign| C.Omod_assign|C.Oand_assign|C.Oor_assign|C.Oxor_assign| @@ -875,6 +838,7 @@ let rec convertExpr env e = | _ -> assert false in let e1' = convertLvalue env e1 in let e2' = convertExpr env e2 in + check_volatile_bitfield env e1; ewrap (Ctyping.eassignop op' e1' e2') | C.EBinop(C.Ocomma, e1, e2, _) -> ewrap (Ctyping.ecomma (convertExpr env e1) (convertExpr env e2)) @@ -983,13 +947,16 @@ let rec convertExpr env e = ewrap (Ctyping.eselection (convertExpr env arg1) (convertExpr env arg2) (convertExpr env arg3)) + | C.ECall({edesc = C.EVar {name = "__builtin_expect"}}, [arg1; arg2]) -> + convertExpr env arg1 + | C.ECall({edesc = C.EVar {name = "printf"}}, args) when !Clflags.option_interp -> let targs = convertTypArgs env [] args and tres = convertTyp env e.etyp in let sg = signature_of_type targs tres - { AST.cc_vararg = true; cc_unproto = false; cc_structret = false} in + { AST.cc_vararg = Some (coqint_of_camlint 1l); cc_unproto = false; cc_structret = false} in Ebuiltin( AST.EF_external(coqstring_of_camlstring "printf", sg), targs, convertExprList env args, tres) @@ -1256,7 +1223,8 @@ let convertFundef loc env fd = a_loc = loc }; (id', AST.Gfun(Ctypes.Internal {fn_return = ret; - fn_callconv = convertCallconv fd.fd_vararg false fd.fd_attrib; + fn_callconv = convertCallconv fd.fd_ret (Some fd.fd_params) + fd.fd_vararg fd.fd_attrib; fn_params = params; fn_vars = vars; fn_body = body'})) @@ -1264,7 +1232,6 @@ let convertFundef loc env fd = (** External function declaration *) let re_builtin = Str.regexp "__builtin_" -let re_runtime = Str.regexp "__compcert_i64_" let convertFundecl env (sto, id, ty, optinit) = let (args, res, cconv) = @@ -1277,7 +1244,6 @@ let convertFundecl env (sto, id, ty, optinit) = let ef = if id.name = "malloc" then AST.EF_malloc else if id.name = "free" then AST.EF_free else - if Str.string_match re_runtime id.name 0 then AST.EF_runtime(id'', sg) else if Str.string_match re_builtin id.name 0 && List.mem_assoc id.name builtins.builtin_functions then AST.EF_builtin(id'', sg) @@ -1326,8 +1292,13 @@ let convertGlobvar loc env (sto, id, ty, optinit) = if sto = C.Storage_extern then [] else [AST.Init_space sz] | Some i -> convertInitializer env ty i in + let initialized = + if optinit = None then Sections.Uninit else + if List.exists (function AST.Init_addrof _ -> true | _ -> false) init' + then Sections.Init_reloc + else Sections.Init in let (section, access) = - Sections.for_variable env loc id' ty (optinit <> None) in + Sections.for_variable env loc id' ty initialized in if Z.gt sz (Z.of_uint64 0xFFFF_FFFFL) then error "'%s' is too big (%s bytes)" id.name (Z.to_string sz); @@ -1394,6 +1365,81 @@ let rec convertCompositedefs env res gl = | _ -> convertCompositedefs env res gl' +(** Add declarations for the helper functions + (for varargs and for int64 arithmetic) *) + +let helper_functions () = [ + "__compcert_va_int32", + Tint(I32, Unsigned, noattr), + [Tpointer(Tvoid, noattr)]; + "__compcert_va_int64", + Tlong(Unsigned, noattr), + [Tpointer(Tvoid, noattr)]; + "__compcert_va_float64", + Tfloat(F64, noattr), + [Tpointer(Tvoid, noattr)]; + "__compcert_va_composite", + Tpointer(Tvoid, noattr), + [Tpointer(Tvoid, noattr); convertIkind (Cutil.size_t_ikind()) noattr]; + "__compcert_i64_dtos", + Tlong(Signed, noattr), + [Tfloat(F64, noattr)]; + "__compcert_i64_dtou", + Tlong(Unsigned, noattr), + [Tfloat(F64, noattr)]; + "__compcert_i64_stod", + Tfloat(F64, noattr), + [Tlong(Signed, noattr)]; + "__compcert_i64_utod", + Tfloat(F64, noattr), + [Tlong(Unsigned, noattr)]; + "__compcert_i64_stof", + Tfloat(F32, noattr), + [Tlong(Signed, noattr)]; + "__compcert_i64_utof", + Tfloat(F32, noattr), + [Tlong(Unsigned, noattr)]; + "__compcert_i64_sdiv", + Tlong(Signed, noattr), + [Tlong(Signed, noattr); Tlong(Signed, noattr)]; + "__compcert_i64_udiv", + Tlong(Unsigned, noattr), + [Tlong(Unsigned, noattr); Tlong(Unsigned, noattr)]; + "__compcert_i64_smod", + Tlong(Signed, noattr), + [Tlong(Signed, noattr); Tlong(Signed, noattr)]; + "__compcert_i64_umod", + Tlong(Unsigned, noattr), + [Tlong(Unsigned, noattr); Tlong(Unsigned, noattr)]; + "__compcert_i64_shl", + Tlong(Signed, noattr), + [Tlong(Signed, noattr); Tint(I32, Signed, noattr)]; + "__compcert_i64_shr", + Tlong(Unsigned, noattr), + [Tlong(Unsigned, noattr); Tint(I32, Signed, noattr)]; + "__compcert_i64_sar", + Tlong(Signed, noattr), + [Tlong(Signed, noattr); Tint(I32, Signed, noattr)]; + "__compcert_i64_smulh", + Tlong(Signed, noattr), + [Tlong(Signed, noattr); Tlong(Signed, noattr)]; + "__compcert_i64_umulh", + Tlong(Unsigned, noattr), + [Tlong(Unsigned, noattr); Tlong(Unsigned, noattr)] +] + +let helper_function_declaration (name, tyres, tyargs) = + let tyargs = + List.fold_right (fun t tl -> Tcons(t, tl)) tyargs Tnil in + let ef = + AST.EF_runtime(coqstring_of_camlstring name, + signature_of_type tyargs tyres AST.cc_default) in + (intern_string name, + AST.Gfun (Ctypes.External(ef, tyargs, tyres, AST.cc_default))) + +let add_helper_functions globs = + List.map helper_function_declaration (helper_functions()) @ globs + (** Build environment of typedefs, structs, unions and enums *) let rec translEnv env = function @@ -1491,10 +1537,11 @@ let convertProgram p = comp_env := ce; let gl1 = convertGlobdecls env [] p in let gl2 = globals_for_strings gl1 in + let gl3 = add_helper_functions gl2 in comp_env := Maps.PTree.empty; let p' = - { prog_defs = gl2; - prog_public = public_globals gl2; + { prog_defs = gl3; + prog_public = public_globals gl3; prog_main = intern_string !Clflags.main_function_name; prog_types = typs; prog_comp_env = ce } in diff --git a/cfrontend/CPragmas.ml b/cfrontend/CPragmas.ml index 22ab2b5a..08d0aa6c 100644 --- a/cfrontend/CPragmas.ml +++ b/cfrontend/CPragmas.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cfrontend/Cexec.v b/cfrontend/Cexec.v index b08c3ad7..52037ac0 100644 --- a/cfrontend/Cexec.v +++ b/cfrontend/Cexec.v @@ -37,6 +37,10 @@ Notation "'do' X , Y , Z <- A ; B" := (match A with Some (X, Y, Z) => B | None = (at level 200, X ident, Y ident, Z ident, A at level 100, B at level 200) : option_monad_scope. +Notation "'do' X , Y , Z , W <- A ; B" := (match A with Some (X, Y, Z, W) => B | None => None end) + (at level 200, X ident, Y ident, Z ident, W ident, A at level 100, B at level 200) + : option_monad_scope. + Notation " 'check' A ; B" := (if A then B else None) (at level 200, A at level 100, B at level 200) : option_monad_scope. @@ -61,14 +65,14 @@ Proof. intros until ty. destruct a; simpl; congruence. Qed. -Definition is_loc (a: expr) : option (block * ptrofs * type) := +Definition is_loc (a: expr) : option (block * ptrofs * bitfield * type) := match a with - | Eloc b ofs ty => Some(b, ofs, ty) + | Eloc b ofs bf ty => Some(b, ofs, bf, ty) | _ => None end. Lemma is_loc_inv: - forall a b ofs ty, is_loc a = Some(b, ofs, ty) -> a = Eloc b ofs ty. + forall a b ofs bf ty, is_loc a = Some(b, ofs, bf, ty) -> a = Eloc b ofs bf ty. Proof. intros until ty. destruct a; simpl; congruence. Qed. @@ -209,15 +213,15 @@ Definition do_volatile_load (w: world) (chunk: memory_chunk) (m: mem) (b: block) Some(w, E0, v). Definition do_volatile_store (w: world) (chunk: memory_chunk) (m: mem) (b: block) (ofs: ptrofs) (v: val) - : option (world * trace * mem) := + : option (world * trace * mem * val) := if Genv.block_is_volatile ge b then do id <- Genv.invert_symbol ge b; do ev <- eventval_of_val (Val.load_result chunk v) (type_of_chunk chunk); do w' <- nextworld_vstore w chunk id ofs ev; - Some(w', Event_vstore chunk id ofs ev :: nil, m) + Some(w', Event_vstore chunk id ofs ev :: nil, m, v) else do m' <- Mem.store chunk m b (Ptrofs.unsigned ofs) v; - Some(w, E0, m'). + Some(w, E0, m', v). Lemma do_volatile_load_sound: forall w chunk m b ofs w' t v, @@ -244,21 +248,21 @@ Proof. Qed. Lemma do_volatile_store_sound: - forall w chunk m b ofs v w' t m', - do_volatile_store w chunk m b ofs v = Some(w', t, m') -> - volatile_store ge chunk m b ofs v t m' /\ possible_trace w t w'. + forall w chunk m b ofs v w' t m' v', + do_volatile_store w chunk m b ofs v = Some(w', t, m', v') -> + volatile_store ge chunk m b ofs v t m' /\ possible_trace w t w' /\ v' = v. Proof. - intros until m'. unfold do_volatile_store. mydestr. + intros until v'. unfold do_volatile_store. mydestr. split. constructor; auto. apply Genv.invert_find_symbol; auto. apply eventval_of_val_sound; auto. - econstructor. constructor; eauto. constructor. - split. constructor; auto. constructor. + split. econstructor. constructor; eauto. constructor. auto. + split. constructor; auto. split. constructor. auto. Qed. Lemma do_volatile_store_complete: forall w chunk m b ofs v w' t m', volatile_store ge chunk m b ofs v t m' -> possible_trace w t w' -> - do_volatile_store w chunk m b ofs v = Some(w', t, m'). + do_volatile_store w chunk m b ofs v = Some(w', t, m', v). Proof. unfold do_volatile_store; intros. inv H; simpl in *. rewrite H1. rewrite (Genv.find_invert_symbol _ _ H2). @@ -269,16 +273,31 @@ Qed. (** Accessing locations *) -Definition do_deref_loc (w: world) (ty: type) (m: mem) (b: block) (ofs: ptrofs) : option (world * trace * val) := - match access_mode ty with - | By_value chunk => +Definition do_deref_loc (w: world) (ty: type) (m: mem) (b: block) (ofs: ptrofs) (bf: bitfield) : option (world * trace * val) := + match bf with + | Full => + match access_mode ty with + | By_value chunk => match type_is_volatile ty with | false => do v <- Mem.loadv chunk m (Vptr b ofs); Some(w, E0, v) | true => do_volatile_load w chunk m b ofs end - | By_reference => Some(w, E0, Vptr b ofs) - | By_copy => Some(w, E0, Vptr b ofs) - | _ => None + | By_reference => Some(w, E0, Vptr b ofs) + | By_copy => Some(w, E0, Vptr b ofs) + | _ => None + end + | Bits sz sg pos width => + match ty with + | Tint sz1 sg1 _ => + check (intsize_eq sz1 sz && + signedness_eq sg1 (if zlt width (bitsize_intsize sz) then Signed else sg) && + zle 0 pos && zlt 0 width && zle width (bitsize_intsize sz) && zle (pos + width) (bitsize_carrier sz)); + match Mem.loadv (chunk_for_carrier sz) m (Vptr b ofs) with + | Some (Vint c) => Some (w, E0, Vint (bitfield_extract sz sg pos width c)) + | _ => None + end + | _ => None + end end. Definition assign_copy_ok (ty: type) (b: block) (ofs: ptrofs) (b': block) (ofs': ptrofs) : Prop := @@ -290,7 +309,7 @@ Definition assign_copy_ok (ty: type) (b: block) (ofs: ptrofs) (b': block) (ofs': Remark check_assign_copy: forall (ty: type) (b: block) (ofs: ptrofs) (b': block) (ofs': ptrofs), { assign_copy_ok ty b ofs b' ofs' } + {~ assign_copy_ok ty b ofs b' ofs' }. -Proof with try (right; intuition omega). +Proof with try (right; intuition lia). intros. unfold assign_copy_ok. destruct (Zdivide_dec (alignof_blockcopy ge ty) (Ptrofs.unsigned ofs')); auto... destruct (Zdivide_dec (alignof_blockcopy ge ty) (Ptrofs.unsigned ofs)); auto... @@ -306,79 +325,107 @@ Proof with try (right; intuition omega). destruct (zeq (Ptrofs.unsigned ofs') (Ptrofs.unsigned ofs)); auto. destruct (zle (Ptrofs.unsigned ofs' + sizeof ge ty) (Ptrofs.unsigned ofs)); auto. destruct (zle (Ptrofs.unsigned ofs + sizeof ge ty) (Ptrofs.unsigned ofs')); auto. - right; intuition omega. - destruct Y... left; intuition omega. + right; intuition lia. + destruct Y... left; intuition lia. Defined. -Definition do_assign_loc (w: world) (ty: type) (m: mem) (b: block) (ofs: ptrofs) (v: val): option (world * trace * mem) := - match access_mode ty with - | By_value chunk => - match type_is_volatile ty with - | false => do m' <- Mem.storev chunk m (Vptr b ofs) v; Some(w, E0, m') - | true => do_volatile_store w chunk m b ofs v - end - | By_copy => - match v with - | Vptr b' ofs' => - if check_assign_copy ty b ofs b' ofs' then - do bytes <- Mem.loadbytes m b' (Ptrofs.unsigned ofs') (sizeof ge ty); - do m' <- Mem.storebytes m b (Ptrofs.unsigned ofs) bytes; - Some(w, E0, m') - else None - | _ => None - end - | _ => None +Definition do_assign_loc (w: world) (ty: type) (m: mem) (b: block) (ofs: ptrofs) (bf: bitfield) (v: val): option (world * trace * mem * val) := + match bf with + | Full => + match access_mode ty with + | By_value chunk => + match type_is_volatile ty with + | false => do m' <- Mem.storev chunk m (Vptr b ofs) v; Some(w, E0, m', v) + | true => do_volatile_store w chunk m b ofs v + end + | By_copy => + match v with + | Vptr b' ofs' => + if check_assign_copy ty b ofs b' ofs' then + do bytes <- Mem.loadbytes m b' (Ptrofs.unsigned ofs') (sizeof ge ty); + do m' <- Mem.storebytes m b (Ptrofs.unsigned ofs) bytes; + Some(w, E0, m', v) + else None + | _ => None + end + | _ => None + end + | Bits sz sg pos width => + check (zle 0 pos && zlt 0 width && zle width (bitsize_intsize sz) && zle (pos + width) (bitsize_carrier sz)); + match ty, v, Mem.loadv (chunk_for_carrier sz) m (Vptr b ofs) with + | Tint sz1 sg1 _, Vint n, Some (Vint c) => + check (intsize_eq sz1 sz && + signedness_eq sg1 (if zlt width (bitsize_intsize sz) then Signed else sg)); + do m' <- Mem.storev (chunk_for_carrier sz) m (Vptr b ofs) + (Vint ((Int.bitfield_insert (first_bit sz pos width) width c n))); + Some (w, E0, m', Vint (bitfield_normalize sz sg width n)) + | _, _, _ => None + end end. Lemma do_deref_loc_sound: - forall w ty m b ofs w' t v, - do_deref_loc w ty m b ofs = Some(w', t, v) -> - deref_loc ge ty m b ofs t v /\ possible_trace w t w'. + forall w ty m b ofs bf w' t v, + do_deref_loc w ty m b ofs bf = Some(w', t, v) -> + deref_loc ge ty m b ofs bf t v /\ possible_trace w t w'. Proof. unfold do_deref_loc; intros until v. - destruct (access_mode ty) eqn:?; mydestr. + destruct bf. +- destruct (access_mode ty) eqn:?; mydestr. intros. exploit do_volatile_load_sound; eauto. intuition. eapply deref_loc_volatile; eauto. split. eapply deref_loc_value; eauto. constructor. split. eapply deref_loc_reference; eauto. constructor. split. eapply deref_loc_copy; eauto. constructor. +- mydestr. destruct ty; mydestr. InvBooleans. subst i. destruct v0; mydestr. + split. eapply deref_loc_bitfield; eauto. econstructor; eauto. constructor. Qed. Lemma do_deref_loc_complete: - forall w ty m b ofs w' t v, - deref_loc ge ty m b ofs t v -> possible_trace w t w' -> - do_deref_loc w ty m b ofs = Some(w', t, v). + forall w ty m b ofs bf w' t v, + deref_loc ge ty m b ofs bf t v -> possible_trace w t w' -> + do_deref_loc w ty m b ofs bf = Some(w', t, v). Proof. unfold do_deref_loc; intros. inv H. - inv H0. rewrite H1; rewrite H2; rewrite H3; auto. - rewrite H1; rewrite H2. apply do_volatile_load_complete; auto. - inv H0. rewrite H1. auto. - inv H0. rewrite H1. auto. +- inv H0. rewrite H1; rewrite H2; rewrite H3; auto. +- rewrite H1; rewrite H2. apply do_volatile_load_complete; auto. +- inv H0. rewrite H1. auto. +- inv H0. rewrite H1. auto. +- inv H0. inv H1. + unfold proj_sumbool; rewrite ! dec_eq_true, ! zle_true, ! zlt_true by lia. cbn. + cbn in H4; rewrite H4. auto. Qed. Lemma do_assign_loc_sound: - forall w ty m b ofs v w' t m', - do_assign_loc w ty m b ofs v = Some(w', t, m') -> - assign_loc ge ty m b ofs v t m' /\ possible_trace w t w'. + forall w ty m b ofs bf v w' t m' v', + do_assign_loc w ty m b ofs bf v = Some(w', t, m', v') -> + assign_loc ge ty m b ofs bf v t m' v' /\ possible_trace w t w'. Proof. - unfold do_assign_loc; intros until m'. - destruct (access_mode ty) eqn:?; mydestr. - intros. exploit do_volatile_store_sound; eauto. intuition. eapply assign_loc_volatile; eauto. + unfold do_assign_loc; intros until v'. + destruct bf. +- destruct (access_mode ty) eqn:?; mydestr. + intros. exploit do_volatile_store_sound; eauto. intros (P & Q & R). subst v'. intuition. eapply assign_loc_volatile; eauto. split. eapply assign_loc_value; eauto. constructor. destruct v; mydestr. destruct a as [P [Q R]]. split. eapply assign_loc_copy; eauto. constructor. +- mydestr. InvBooleans. + destruct ty; mydestr. destruct v; mydestr. destruct v; mydestr. InvBooleans. subst s i. + split. eapply assign_loc_bitfield; eauto. econstructor; eauto. constructor. Qed. Lemma do_assign_loc_complete: - forall w ty m b ofs v w' t m', - assign_loc ge ty m b ofs v t m' -> possible_trace w t w' -> - do_assign_loc w ty m b ofs v = Some(w', t, m'). + forall w ty m b ofs bf v w' t m' v', + assign_loc ge ty m b ofs bf v t m' v' -> possible_trace w t w' -> + do_assign_loc w ty m b ofs bf v = Some(w', t, m', v'). Proof. unfold do_assign_loc; intros. inv H. - inv H0. rewrite H1; rewrite H2; rewrite H3; auto. - rewrite H1; rewrite H2. apply do_volatile_store_complete; auto. - rewrite H1. destruct (check_assign_copy ty b ofs b' ofs'). +- inv H0. rewrite H1; rewrite H2; rewrite H3; auto. +- rewrite H1; rewrite H2. apply do_volatile_store_complete; auto. +- rewrite H1. destruct (check_assign_copy ty b ofs b' ofs'). inv H0. rewrite H5; rewrite H6; auto. elim n. red; tauto. +- inv H0. inv H1. + unfold proj_sumbool; rewrite ! zle_true, ! zlt_true by lia. cbn. + rewrite ! dec_eq_true. + cbn in H4; rewrite H4. cbn in H5; rewrite H5. auto. Qed. (** External calls *) @@ -421,7 +468,7 @@ Definition do_ef_volatile_load (chunk: memory_chunk) Definition do_ef_volatile_store (chunk: memory_chunk) (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := match vargs with - | Vptr b ofs :: v :: nil => do w',t,m' <- do_volatile_store w chunk m b ofs v; Some(w',t,Vundef,m') + | Vptr b ofs :: v :: nil => do w',t,m',v' <- do_volatile_store w chunk m b ofs v; Some(w',t,Vundef,m') | _ => None end. @@ -564,7 +611,7 @@ Proof with try congruence. exploit do_volatile_load_sound; eauto. intuition. econstructor; eauto. - (* EF_vstore *) unfold do_ef_volatile_store. destruct vargs... destruct v... destruct vargs... destruct vargs... - mydestr. destruct p as [[w'' t''] m'']. mydestr. + mydestr. destruct p as [[[w'' t''] m''] v'']. mydestr. exploit do_volatile_store_sound; eauto. intuition. econstructor; eauto. - (* EF_malloc *) unfold do_ef_malloc. destruct vargs... destruct vargs... mydestr. @@ -579,7 +626,7 @@ Proof with try congruence. replace (Vlong Int64.zero) with Vnullptr. split; constructor. unfold Vnullptr; rewrite H0; auto. + destruct vargs... mydestr. - split. apply SIZE in Heqo0. econstructor; eauto. congruence. omega. + split. apply SIZE in Heqo0. econstructor; eauto. congruence. lia. constructor. - (* EF_memcpy *) unfold do_ef_memcpy. destruct vargs... destruct v... destruct vargs... @@ -636,7 +683,7 @@ Proof. inv H0. erewrite SIZE by eauto. rewrite H1, H2. auto. - (* EF_free *) inv H; unfold do_ef_free. -+ inv H0. rewrite H1. erewrite SIZE by eauto. rewrite zlt_true. rewrite H3. auto. omega. ++ inv H0. rewrite H1. erewrite SIZE by eauto. rewrite zlt_true. rewrite H3. auto. lia. + inv H0. unfold Vnullptr; destruct Archi.ptr64; auto. - (* EF_memcpy *) inv H; unfold do_ef_memcpy. @@ -710,6 +757,10 @@ Notation "'do' X , Y , Z <- A ; B" := (match A with Some (X, Y, Z) => B | None = (at level 200, X ident, Y ident, Z ident, A at level 100, B at level 200) : reducts_monad_scope. +Notation "'do' X , Y , Z , W <- A ; B" := (match A with Some (X, Y, Z, W) => B | None => stuck end) + (at level 200, X ident, Y ident, Z ident, W ident, A at level 100, B at level 200) + : reducts_monad_scope. + Notation " 'check' A ; B" := (if A then B else stuck) (at level 200, A at level 100, B at level 200) : reducts_monad_scope. @@ -718,21 +769,21 @@ Local Open Scope reducts_monad_scope. Fixpoint step_expr (k: kind) (a: expr) (m: mem): reducts expr := match k, a with - | LV, Eloc b ofs ty => + | LV, Eloc b ofs bf ty => nil | LV, Evar x ty => match e!x with | Some(b, ty') => check type_eq ty ty'; - topred (Lred "red_var_local" (Eloc b Ptrofs.zero ty) m) + topred (Lred "red_var_local" (Eloc b Ptrofs.zero Full ty) m) | None => do b <- Genv.find_symbol ge x; - topred (Lred "red_var_global" (Eloc b Ptrofs.zero ty) m) + topred (Lred "red_var_global" (Eloc b Ptrofs.zero Full ty) m) end | LV, Ederef r ty => match is_val r with | Some(Vptr b ofs, ty') => - topred (Lred "red_deref" (Eloc b ofs ty) m) + topred (Lred "red_deref" (Eloc b ofs Full ty) m) | Some _ => stuck | None => @@ -746,11 +797,14 @@ Fixpoint step_expr (k: kind) (a: expr) (m: mem): reducts expr := do co <- ge.(genv_cenv)!id; match field_offset ge f (co_members co) with | Error _ => stuck - | OK delta => topred (Lred "red_field_struct" (Eloc b (Ptrofs.add ofs (Ptrofs.repr delta)) ty) m) + | OK (delta, bf) => topred (Lred "red_field_struct" (Eloc b (Ptrofs.add ofs (Ptrofs.repr delta)) bf ty) m) end | Tunion id _ => do co <- ge.(genv_cenv)!id; - topred (Lred "red_field_union" (Eloc b ofs ty) m) + match union_field_offset ge f (co_members co) with + | Error _ => stuck + | OK (delta, bf) => topred (Lred "red_field_union" (Eloc b (Ptrofs.add ofs (Ptrofs.repr delta)) bf ty) m) + end | _ => stuck end | Some _ => @@ -762,16 +816,19 @@ Fixpoint step_expr (k: kind) (a: expr) (m: mem): reducts expr := nil | RV, Evalof l ty => match is_loc l with - | Some(b, ofs, ty') => + | Some(b, ofs, bf, ty') => check type_eq ty ty'; - do w',t,v <- do_deref_loc w ty m b ofs; + do w',t,v <- do_deref_loc w ty m b ofs bf; topred (Rred "red_rvalof" (Eval v ty) m t) | None => incontext (fun x => Evalof x ty) (step_expr LV l m) end | RV, Eaddrof l ty => match is_loc l with - | Some(b, ofs, ty') => topred (Rred "red_addrof" (Eval (Vptr b ofs) ty) m E0) + | Some(b, ofs, bf, ty') => + match bf with Full => topred (Rred "red_addrof" (Eval (Vptr b ofs) ty) m E0) + | Bits _ _ _ _ => stuck + end | None => incontext (fun x => Eaddrof x ty) (step_expr LV l m) end | RV, Eunop op r1 ty => @@ -831,21 +888,21 @@ Fixpoint step_expr (k: kind) (a: expr) (m: mem): reducts expr := topred (Rred "red_alignof" (Eval (Vptrofs (Ptrofs.repr (alignof ge ty'))) ty) m E0) | RV, Eassign l1 r2 ty => match is_loc l1, is_val r2 with - | Some(b, ofs, ty1), Some(v2, ty2) => + | Some(b, ofs, bf, ty1), Some(v2, ty2) => check type_eq ty1 ty; do v <- sem_cast v2 ty2 ty1 m; - do w',t,m' <- do_assign_loc w ty1 m b ofs v; - topred (Rred "red_assign" (Eval v ty) m' t) + do w',t,m',v' <- do_assign_loc w ty1 m b ofs bf v; + topred (Rred "red_assign" (Eval v' ty) m' t) | _, _ => incontext2 (fun x => Eassign x r2 ty) (step_expr LV l1 m) (fun x => Eassign l1 x ty) (step_expr RV r2 m) end | RV, Eassignop op l1 r2 tyres ty => match is_loc l1, is_val r2 with - | Some(b, ofs, ty1), Some(v2, ty2) => + | Some(b, ofs, bf, ty1), Some(v2, ty2) => check type_eq ty1 ty; - do w',t,v1 <- do_deref_loc w ty1 m b ofs; - let r' := Eassign (Eloc b ofs ty1) + do w',t,v1 <- do_deref_loc w ty1 m b ofs bf; + let r' := Eassign (Eloc b ofs bf ty1) (Ebinop op (Eval v1 ty1) (Eval v2 ty2) tyres) ty1 in topred (Rred "red_assignop" r' m t) | _, _ => @@ -854,12 +911,12 @@ Fixpoint step_expr (k: kind) (a: expr) (m: mem): reducts expr := end | RV, Epostincr id l ty => match is_loc l with - | Some(b, ofs, ty1) => + | Some(b, ofs, bf, ty1) => check type_eq ty1 ty; - do w',t, v1 <- do_deref_loc w ty m b ofs; + do w',t, v1 <- do_deref_loc w ty m b ofs bf; let op := match id with Incr => Oadd | Decr => Osub end in let r' := - Ecomma (Eassign (Eloc b ofs ty) + Ecomma (Eassign (Eloc b ofs bf ty) (Ebinop op (Eval v1 ty) (Eval (Vint Int.one) type_int32s) (incrdecr_type ty)) ty) (Eval v1 ty) ty in @@ -926,8 +983,8 @@ with step_exprlist (rl: exprlist) (m: mem): reducts exprlist := Inductive imm_safe_t: kind -> expr -> mem -> Prop := | imm_safe_t_val: forall v ty m, imm_safe_t RV (Eval v ty) m - | imm_safe_t_loc: forall b ofs ty m, - imm_safe_t LV (Eloc b ofs ty) m + | imm_safe_t_loc: forall b ofs ty bf m, + imm_safe_t LV (Eloc b ofs bf ty) m | imm_safe_t_lred: forall to C l m l' m', lred ge e l m l' m' -> context LV to C -> @@ -961,23 +1018,25 @@ Fixpoint exprlist_all_values (rl: exprlist) : Prop := Definition invert_expr_prop (a: expr) (m: mem) : Prop := match a with - | Eloc b ofs ty => False + | Eloc b ofs bf ty => False | Evar x ty => exists b, e!x = Some(b, ty) \/ (e!x = None /\ Genv.find_symbol ge x = Some b) | Ederef (Eval v ty1) ty => exists b, exists ofs, v = Vptr b ofs + | Eaddrof (Eloc b ofs bf ty1) ty => + bf = Full | Efield (Eval v ty1) f ty => exists b, exists ofs, v = Vptr b ofs /\ match ty1 with - | Tstruct id _ => exists co delta, ge.(genv_cenv)!id = Some co /\ field_offset ge f (co_members co) = OK delta - | Tunion id _ => exists co, ge.(genv_cenv)!id = Some co + | Tstruct id _ => exists co delta bf, ge.(genv_cenv)!id = Some co /\ field_offset ge f (co_members co) = OK (delta, bf) + | Tunion id _ => exists co delta bf, ge.(genv_cenv)!id = Some co /\ union_field_offset ge f (co_members co) = OK (delta, bf) | _ => False end | Eval v ty => False - | Evalof (Eloc b ofs ty') ty => - ty' = ty /\ exists t, exists v, exists w', deref_loc ge ty m b ofs t v /\ possible_trace w t w' + | Evalof (Eloc b ofs bf ty') ty => + ty' = ty /\ exists t, exists v, exists w', deref_loc ge ty m b ofs bf t v /\ possible_trace w t w' | Eunop op (Eval v1 ty1) ty => exists v, sem_unary_operation op v1 ty1 m = Some v | Ebinop op (Eval v1 ty1) (Eval v2 ty2) ty => @@ -990,15 +1049,15 @@ Definition invert_expr_prop (a: expr) (m: mem) : Prop := exists b, bool_val v1 ty1 m = Some b | Econdition (Eval v1 ty1) r1 r2 ty => exists b, bool_val v1 ty1 m = Some b - | Eassign (Eloc b ofs ty1) (Eval v2 ty2) ty => - exists v, exists m', exists t, exists w', - ty = ty1 /\ sem_cast v2 ty2 ty1 m = Some v /\ assign_loc ge ty1 m b ofs v t m' /\ possible_trace w t w' - | Eassignop op (Eloc b ofs ty1) (Eval v2 ty2) tyres ty => + | Eassign (Eloc b ofs bf ty1) (Eval v2 ty2) ty => + exists v, exists m', exists v', exists t, exists w', + ty = ty1 /\ sem_cast v2 ty2 ty1 m = Some v /\ assign_loc ge ty1 m b ofs bf v t m' v' /\ possible_trace w t w' + | Eassignop op (Eloc b ofs bf ty1) (Eval v2 ty2) tyres ty => exists t, exists v1, exists w', - ty = ty1 /\ deref_loc ge ty1 m b ofs t v1 /\ possible_trace w t w' - | Epostincr id (Eloc b ofs ty1) ty => + ty = ty1 /\ deref_loc ge ty1 m b ofs bf t v1 /\ possible_trace w t w' + | Epostincr id (Eloc b ofs bf ty1) ty => exists t, exists v1, exists w', - ty = ty1 /\ deref_loc ge ty m b ofs t v1 /\ possible_trace w t w' + ty = ty1 /\ deref_loc ge ty m b ofs bf t v1 /\ possible_trace w t w' | Ecomma (Eval v ty1) r2 ty => typeof r2 = ty | Eparen (Eval v1 ty1) tycast ty => @@ -1026,8 +1085,8 @@ Proof. exists b; auto. exists b; auto. exists b; exists ofs; auto. - exists b; exists ofs; split; auto. exists co, delta; auto. - exists b; exists ofs; split; auto. exists co; auto. + exists b; exists ofs; split; auto. exists co, delta, bf; auto. + exists b; exists ofs; split; auto. exists co, delta, bf; auto. Qed. Lemma rred_invert: @@ -1041,7 +1100,7 @@ Proof. exists true; auto. exists false; auto. exists true; auto. exists false; auto. exists b; auto. - exists v; exists m'; exists t; exists w'; auto. + exists v; exists m'; exists v'; exists t; exists w'; auto. exists t; exists v1; exists w'; auto. exists t; exists v1; exists w'; auto. exists v; auto. @@ -1076,7 +1135,7 @@ Proof. destruct (C a); auto; contradiction. destruct (C a); auto; contradiction. destruct (C a); auto; contradiction. - auto. + destruct (C a); auto; contradiction. destruct (C a); auto; contradiction. destruct (C a); auto; contradiction. destruct e1; auto; destruct (C a); auto; contradiction. @@ -1102,7 +1161,7 @@ Lemma imm_safe_t_inv: forall k a m, imm_safe_t k a m -> match a with - | Eloc _ _ _ => True + | Eloc _ _ _ _ => True | Eval _ _ => True | _ => invert_expr_prop a m end. @@ -1228,7 +1287,7 @@ Qed. Lemma not_invert_ok: forall k a m, match a with - | Eloc _ _ _ => False + | Eloc _ _ _ _ => False | Eval _ _ => False | _ => invert_expr_prop a m -> False end -> @@ -1369,18 +1428,19 @@ Proof with (try (apply not_invert_ok; simpl; intro; myinv; intuition congruence; destruct ty'... (* top struct *) destruct (ge.(genv_cenv)!i0) as [co|] eqn:?... - destruct (field_offset ge f (co_members co)) as [delta|] eqn:?... + destruct (field_offset ge f (co_members co)) as [[delta bf]|] eqn:?... apply topred_ok; auto. eapply red_field_struct; eauto. (* top union *) destruct (ge.(genv_cenv)!i0) as [co|] eqn:?... + destruct (union_field_offset ge f (co_members co)) as [[delta bf]|] eqn:?... apply topred_ok; auto. eapply red_field_union; eauto. (* in depth *) eapply incontext_ok; eauto. (* Evalof *) - destruct (is_loc a) as [[[b ofs] ty'] | ] eqn:?. rewrite (is_loc_inv _ _ _ _ Heqo). + destruct (is_loc a) as [[[[b ofs] bf] ty'] | ] eqn:?. rewrite (is_loc_inv _ _ _ _ _ Heqo). (* top *) destruct (type_eq ty ty')... subst ty'. - destruct (do_deref_loc w ty m b ofs) as [[[w' t] v] | ] eqn:?. + destruct (do_deref_loc w ty m b ofs bf) as [[[w' t] v] | ] eqn:?. exploit do_deref_loc_sound; eauto. intros [A B]. apply topred_ok; auto. red. split. apply red_rvalof; auto. exists w'; auto. apply not_invert_ok; simpl; intros; myinv. exploit do_deref_loc_complete; eauto. congruence. @@ -1393,8 +1453,9 @@ Proof with (try (apply not_invert_ok; simpl; intro; myinv; intuition congruence; (* depth *) eapply incontext_ok; eauto. (* Eaddrof *) - destruct (is_loc a) as [[[b ofs] ty'] | ] eqn:?. rewrite (is_loc_inv _ _ _ _ Heqo). + destruct (is_loc a) as [[[[b ofs] bf ] ty'] | ] eqn:?. rewrite (is_loc_inv _ _ _ _ _ Heqo). (* top *) + destruct bf... apply topred_ok; auto. split. apply red_addrof; auto. exists w; constructor. (* depth *) eapply incontext_ok; eauto. @@ -1450,26 +1511,26 @@ Proof with (try (apply not_invert_ok; simpl; intro; myinv; intuition congruence; (* alignof *) apply topred_ok; auto. split. apply red_alignof. exists w; constructor. (* assign *) - destruct (is_loc a1) as [[[b ofs] ty1] | ] eqn:?. + destruct (is_loc a1) as [[[[b ofs] bf] ty1] | ] eqn:?. destruct (is_val a2) as [[v2 ty2] | ] eqn:?. - rewrite (is_loc_inv _ _ _ _ Heqo). rewrite (is_val_inv _ _ _ Heqo0). + rewrite (is_loc_inv _ _ _ _ _ Heqo). rewrite (is_val_inv _ _ _ Heqo0). (* top *) destruct (type_eq ty1 ty)... subst ty1. destruct (sem_cast v2 ty2 ty m) as [v|] eqn:?... - destruct (do_assign_loc w ty m b ofs v) as [[[w' t] m']|] eqn:?. + destruct (do_assign_loc w ty m b ofs bf v) as [[[[w' t] m'] v']|] eqn:?. exploit do_assign_loc_sound; eauto. intros [P Q]. - apply topred_ok; auto. split. apply red_assign; auto. exists w'; auto. + apply topred_ok; auto. split. eapply red_assign; eauto. exists w'; auto. apply not_invert_ok; simpl; intros; myinv. exploit do_assign_loc_complete; eauto. congruence. (* depth *) eapply incontext2_ok; eauto. eapply incontext2_ok; eauto. (* assignop *) - destruct (is_loc a1) as [[[b ofs] ty1] | ] eqn:?. + destruct (is_loc a1) as [[[[b ofs] bf] ty1] | ] eqn:?. destruct (is_val a2) as [[v2 ty2] | ] eqn:?. - rewrite (is_loc_inv _ _ _ _ Heqo). rewrite (is_val_inv _ _ _ Heqo0). + rewrite (is_loc_inv _ _ _ _ _ Heqo). rewrite (is_val_inv _ _ _ Heqo0). (* top *) destruct (type_eq ty1 ty)... subst ty1. - destruct (do_deref_loc w ty m b ofs) as [[[w' t] v] | ] eqn:?. + destruct (do_deref_loc w ty m b ofs bf) as [[[w' t] v] | ] eqn:?. exploit do_deref_loc_sound; eauto. intros [A B]. apply topred_ok; auto. red. split. apply red_assignop; auto. exists w'; auto. apply not_invert_ok; simpl; intros; myinv. exploit do_deref_loc_complete; eauto. congruence. @@ -1477,10 +1538,10 @@ Proof with (try (apply not_invert_ok; simpl; intro; myinv; intuition congruence; eapply incontext2_ok; eauto. eapply incontext2_ok; eauto. (* postincr *) - destruct (is_loc a) as [[[b ofs] ty'] | ] eqn:?. rewrite (is_loc_inv _ _ _ _ Heqo). + destruct (is_loc a) as [[[[b ofs] bf] ty'] | ] eqn:?. rewrite (is_loc_inv _ _ _ _ _ Heqo). (* top *) destruct (type_eq ty' ty)... subst ty'. - destruct (do_deref_loc w ty m b ofs) as [[[w' t] v] | ] eqn:?. + destruct (do_deref_loc w ty m b ofs bf) as [[[w' t] v] | ] eqn:?. exploit do_deref_loc_sound; eauto. intros [A B]. apply topred_ok; auto. red. split. apply red_postincr; auto. exists w'; auto. apply not_invert_ok; simpl; intros; myinv. exploit do_deref_loc_complete; eauto. congruence. @@ -1576,7 +1637,7 @@ Proof. (* field struct *) rewrite H, H0; econstructor; eauto. (* field union *) - rewrite H; econstructor; eauto. + rewrite H, H0; econstructor; eauto. Qed. Lemma rred_topred: @@ -1587,7 +1648,7 @@ Proof. induction 1; simpl; intros. (* valof *) rewrite dec_eq_true. - rewrite (do_deref_loc_complete _ _ _ _ _ _ _ _ H H0). econstructor; eauto. + rewrite (do_deref_loc_complete _ _ _ _ _ _ _ _ _ H H0). econstructor; eauto. (* addrof *) inv H. econstructor; eauto. (* unop *) @@ -1609,13 +1670,13 @@ Proof. (* alignof *) inv H. econstructor; eauto. (* assign *) - rewrite dec_eq_true. rewrite H. rewrite (do_assign_loc_complete _ _ _ _ _ _ _ _ _ H0 H1). + rewrite dec_eq_true. rewrite H. rewrite (do_assign_loc_complete _ _ _ _ _ _ _ _ _ _ _ H0 H1). econstructor; eauto. (* assignop *) - rewrite dec_eq_true. rewrite (do_deref_loc_complete _ _ _ _ _ _ _ _ H H0). + rewrite dec_eq_true. rewrite (do_deref_loc_complete _ _ _ _ _ _ _ _ _ H H0). econstructor; eauto. (* postincr *) - rewrite dec_eq_true. subst. rewrite (do_deref_loc_complete _ _ _ _ _ _ _ _ H H1). + rewrite dec_eq_true. subst. rewrite (do_deref_loc_complete _ _ _ _ _ _ _ _ _ H H1). econstructor; eauto. (* comma *) inv H0. rewrite dec_eq_true. econstructor; eauto. @@ -1664,10 +1725,10 @@ Proof. Qed. Lemma reducts_incl_loc: - forall (A: Type) a m b ofs ty (C: expr -> A) res, - is_loc a = Some(b, ofs, ty) -> reducts_incl C (step_expr LV a m) res. + forall (A: Type) a m b ofs ty bf (C: expr -> A) res, + is_loc a = Some(b, ofs, bf, ty) -> reducts_incl C (step_expr LV a m) res. Proof. - intros. rewrite (is_loc_inv _ _ _ _ H). apply reducts_incl_nil. + intros. rewrite (is_loc_inv _ _ _ _ _ H). apply reducts_incl_nil. Qed. Lemma reducts_incl_listval: @@ -1732,10 +1793,10 @@ Proof. destruct (is_val (C a)) as [[v ty']|] eqn:?; eauto. (* valof *) eapply reducts_incl_trans with (C' := fun x => Evalof x ty); eauto. - destruct (is_loc (C a)) as [[[b ofs] ty']|] eqn:?; eauto. + destruct (is_loc (C a)) as [[[[b ofs] bf] ty']|] eqn:?; eauto. (* addrof *) eapply reducts_incl_trans with (C' := fun x => Eaddrof x ty); eauto. - destruct (is_loc (C a)) as [[[b ofs] ty']|] eqn:?; eauto. + destruct (is_loc (C a)) as [[[[b ofs] bf] ty']|] eqn:?; eauto. (* unop *) eapply reducts_incl_trans with (C' := fun x => Eunop op x ty); eauto. destruct (is_val (C a)) as [[v ty']|] eqn:?; eauto. @@ -1760,21 +1821,21 @@ Proof. destruct (is_val (C a)) as [[v ty']|] eqn:?; eauto. (* assign left *) eapply reducts_incl_trans with (C' := fun x => Eassign x e2 ty); eauto. - destruct (is_loc (C a)) as [[[b ofs] ty']|] eqn:?; eauto. + destruct (is_loc (C a)) as [[[[b ofs] bf] ty']|] eqn:?; eauto. (* assign right *) eapply reducts_incl_trans with (C' := fun x => Eassign e1 x ty); eauto. - destruct (is_loc e1) as [[[b ofs] ty1]|] eqn:?; eauto. + destruct (is_loc e1) as [[[[b ofs] bf] ty1]|] eqn:?; eauto. destruct (is_val (C a)) as [[v2 ty2]|] eqn:?; eauto. (* assignop left *) eapply reducts_incl_trans with (C' := fun x => Eassignop op x e2 tyres ty); eauto. - destruct (is_loc (C a)) as [[[b ofs] ty']|] eqn:?; eauto. + destruct (is_loc (C a)) as [[[[b ofs] bf] ty']|] eqn:?; eauto. (* assignop right *) eapply reducts_incl_trans with (C' := fun x => Eassignop op e1 x tyres ty); eauto. - destruct (is_loc e1) as [[[b ofs] ty1]|] eqn:?; eauto. + destruct (is_loc e1) as [[[[b ofs] bf] ty1]|] eqn:?; eauto. destruct (is_val (C a)) as [[v2 ty2]|] eqn:?; eauto. (* postincr *) eapply reducts_incl_trans with (C' := fun x => Epostincr id x ty); eauto. - destruct (is_loc (C a)) as [[[b ofs] ty']|] eqn:?; eauto. + destruct (is_loc (C a)) as [[[[b ofs] bf] ty']|] eqn:?; eauto. (* call left *) eapply reducts_incl_trans with (C' := fun x => Ecall x el ty); eauto. destruct (is_val (C a)) as [[v ty']|] eqn:?; eauto. @@ -1915,7 +1976,7 @@ Function sem_bind_parameters (w: world) (e: env) (m: mem) (l: list (ident * type match PTree.get id e with | Some (b, ty') => check (type_eq ty ty'); - do w', t, m1 <- do_assign_loc w ty m b Ptrofs.zero v1; + do w', t, m1, v' <- do_assign_loc w ty m b Ptrofs.zero Full v1; match t with nil => sem_bind_parameters w e m1 params lv | _ => None end | None => None end @@ -1935,10 +1996,11 @@ Lemma sem_bind_parameters_complete : forall w e m l lv m', bind_parameters ge e m l lv m' -> sem_bind_parameters w e m l lv = Some m'. Proof. +Local Opaque do_assign_loc. induction 1; simpl; auto. rewrite H. rewrite dec_eq_true. assert (possible_trace w E0 w) by constructor. - rewrite (do_assign_loc_complete _ _ _ _ _ _ _ _ _ H0 H2). + rewrite (do_assign_loc_complete _ _ _ _ _ _ _ _ _ _ _ H0 H2). simpl. auto. Qed. diff --git a/cfrontend/Clight.v b/cfrontend/Clight.v index 8ab29fe9..d15bc90a 100644 --- a/cfrontend/Clight.v +++ b/cfrontend/Clight.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -196,36 +197,42 @@ Definition empty_env: env := (PTree.empty (block * type)). Definition temp_env := PTree.t val. -(** [deref_loc ty m b ofs v] computes the value of a datum - of type [ty] residing in memory [m] at block [b], offset [ofs]. +(** [deref_loc ty m b ofs bf v] computes the value of a datum + of type [ty] residing in memory [m] at block [b], offset [ofs], + and bitfield designation [bf]. If the type [ty] indicates an access by value, the corresponding memory load is performed. If the type [ty] indicates an access by reference or by copy, the pointer [Vptr b ofs] is returned. *) -Inductive deref_loc (ty: type) (m: mem) (b: block) (ofs: ptrofs) : val -> Prop := +Inductive deref_loc (ty: type) (m: mem) (b: block) (ofs: ptrofs) : + bitfield -> val -> Prop := | deref_loc_value: forall chunk v, access_mode ty = By_value chunk -> Mem.loadv chunk m (Vptr b ofs) = Some v -> - deref_loc ty m b ofs v + deref_loc ty m b ofs Full v | deref_loc_reference: access_mode ty = By_reference -> - deref_loc ty m b ofs (Vptr b ofs) + deref_loc ty m b ofs Full (Vptr b ofs) | deref_loc_copy: access_mode ty = By_copy -> - deref_loc ty m b ofs (Vptr b ofs). + deref_loc ty m b ofs Full (Vptr b ofs) + | deref_loc_bitfield: forall sz sg pos width v, + load_bitfield ty sz sg pos width m (Vptr b ofs) v -> + deref_loc ty m b ofs (Bits sz sg pos width) v. -(** Symmetrically, [assign_loc ty m b ofs v m'] returns the +(** Symmetrically, [assign_loc ty m b ofs bf v m'] returns the memory state after storing the value [v] in the datum - of type [ty] residing in memory [m] at block [b], offset [ofs]. + of type [ty] residing in memory [m] at block [b], offset [ofs], + bitfield designation [bf]. This is allowed only if [ty] indicates an access by value or by copy. [m'] is the updated memory state. *) Inductive assign_loc (ce: composite_env) (ty: type) (m: mem) (b: block) (ofs: ptrofs): - val -> mem -> Prop := + bitfield -> val -> mem -> Prop := | assign_loc_value: forall v chunk m', access_mode ty = By_value chunk -> Mem.storev chunk m (Vptr b ofs) v = Some m' -> - assign_loc ce ty m b ofs v m' + assign_loc ce ty m b ofs Full v m' | assign_loc_copy: forall b' ofs' bytes m', access_mode ty = By_copy -> (sizeof ce ty > 0 -> (alignof_blockcopy ce ty | Ptrofs.unsigned ofs')) -> @@ -235,7 +242,10 @@ Inductive assign_loc (ce: composite_env) (ty: type) (m: mem) (b: block) (ofs: pt \/ Ptrofs.unsigned ofs + sizeof ce ty <= Ptrofs.unsigned ofs' -> Mem.loadbytes m b' (Ptrofs.unsigned ofs') (sizeof ce ty) = Some bytes -> Mem.storebytes m b (Ptrofs.unsigned ofs) bytes = Some m' -> - assign_loc ce ty m b ofs (Vptr b' ofs') m'. + assign_loc ce ty m b ofs Full (Vptr b' ofs') m' + | assign_loc_bitfield: forall sz sg pos width v m' v', + store_bitfield ty sz sg pos width m (Vptr b ofs) v m' v' -> + assign_loc ce ty m b ofs (Bits sz sg pos width) v m'. Section SEMANTICS. @@ -274,7 +284,7 @@ Inductive bind_parameters (e: env): | bind_parameters_cons: forall m id ty params v1 vl b m1 m2, PTree.get id e = Some(b, ty) -> - assign_loc ge ty m b Ptrofs.zero v1 m1 -> + assign_loc ge ty m b Ptrofs.zero Full v1 m1 -> bind_parameters e m1 params vl m2 -> bind_parameters e m ((id, ty) :: params) (v1 :: vl) m2. @@ -368,7 +378,7 @@ Inductive eval_expr: expr -> val -> Prop := le!id = Some v -> eval_expr (Etempvar id ty) v | eval_Eaddrof: forall a ty loc ofs, - eval_lvalue a loc ofs -> + eval_lvalue a loc ofs Full -> eval_expr (Eaddrof a ty) (Vptr loc ofs) | eval_Eunop: forall op a ty v1 v, eval_expr a v1 -> @@ -387,37 +397,39 @@ Inductive eval_expr: expr -> val -> Prop := eval_expr (Esizeof ty1 ty) (Vptrofs (Ptrofs.repr (sizeof ge ty1))) | eval_Ealignof: forall ty1 ty, eval_expr (Ealignof ty1 ty) (Vptrofs (Ptrofs.repr (alignof ge ty1))) - | eval_Elvalue: forall a loc ofs v, - eval_lvalue a loc ofs -> - deref_loc (typeof a) m loc ofs v -> + | eval_Elvalue: forall a loc ofs bf v, + eval_lvalue a loc ofs bf -> + deref_loc (typeof a) m loc ofs bf v -> eval_expr a v (** [eval_lvalue ge e m a b ofs] defines the evaluation of expression [a] in l-value position. The result is the memory location [b, ofs] - that contains the value of the expression [a]. *) + that contains the value of the expression [a], and the bitfield [bf] + designation. *) -with eval_lvalue: expr -> block -> ptrofs -> Prop := +with eval_lvalue: expr -> block -> ptrofs -> bitfield -> Prop := | eval_Evar_local: forall id l ty, e!id = Some(l, ty) -> - eval_lvalue (Evar id ty) l Ptrofs.zero + eval_lvalue (Evar id ty) l Ptrofs.zero Full | eval_Evar_global: forall id l ty, e!id = None -> Genv.find_symbol ge id = Some l -> - eval_lvalue (Evar id ty) l Ptrofs.zero + eval_lvalue (Evar id ty) l Ptrofs.zero Full | eval_Ederef: forall a ty l ofs, eval_expr a (Vptr l ofs) -> - eval_lvalue (Ederef a ty) l ofs - | eval_Efield_struct: forall a i ty l ofs id co att delta, + eval_lvalue (Ederef a ty) l ofs Full + | eval_Efield_struct: forall a i ty l ofs id co att delta bf, eval_expr a (Vptr l ofs) -> typeof a = Tstruct id att -> ge.(genv_cenv)!id = Some co -> - field_offset ge i (co_members co) = OK delta -> - eval_lvalue (Efield a i ty) l (Ptrofs.add ofs (Ptrofs.repr delta)) - | eval_Efield_union: forall a i ty l ofs id co att, + field_offset ge i (co_members co) = OK (delta, bf) -> + eval_lvalue (Efield a i ty) l (Ptrofs.add ofs (Ptrofs.repr delta)) bf + | eval_Efield_union: forall a i ty l ofs id co att delta bf, eval_expr a (Vptr l ofs) -> typeof a = Tunion id att -> ge.(genv_cenv)!id = Some co -> - eval_lvalue (Efield a i ty) l ofs. + union_field_offset ge i (co_members co) = OK (delta, bf) -> + eval_lvalue (Efield a i ty) l (Ptrofs.add ofs (Ptrofs.repr delta)) bf. Scheme eval_expr_ind2 := Minimality for eval_expr Sort Prop with eval_lvalue_ind2 := Minimality for eval_lvalue Sort Prop. @@ -546,11 +558,11 @@ Variable function_entry: function -> list val -> mem -> env -> temp_env -> mem - Inductive step: state -> trace -> state -> Prop := - | step_assign: forall f a1 a2 k e le m loc ofs v2 v m', - eval_lvalue e le m a1 loc ofs -> + | step_assign: forall f a1 a2 k e le m loc ofs bf v2 v m', + eval_lvalue e le m a1 loc ofs bf -> eval_expr e le m a2 v2 -> sem_cast v2 (typeof a2) (typeof a1) m = Some v -> - assign_loc ge (typeof a1) m loc ofs v m' -> + assign_loc ge (typeof a1) m loc ofs bf v m' -> step (State f (Sassign a1 a2) k e le m) E0 (State f Sskip k e le m') @@ -739,7 +751,7 @@ Proof. exploit external_call_receptive; eauto. intros [vres2 [m2 EC2]]. exists (Returnstate vres2 k m2). econstructor; eauto. (* trace length *) - red; simpl; intros. inv H; simpl; try omega. + red; simpl; intros. inv H; simpl; try lia. eapply external_call_trace_length; eauto. eapply external_call_trace_length; eauto. Qed. diff --git a/cfrontend/ClightBigstep.v b/cfrontend/ClightBigstep.v index 92457586..51487fa2 100644 --- a/cfrontend/ClightBigstep.v +++ b/cfrontend/ClightBigstep.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -78,11 +79,11 @@ Inductive exec_stmt: env -> temp_env -> mem -> statement -> trace -> temp_env -> | exec_Sskip: forall e le m, exec_stmt e le m Sskip E0 le m Out_normal - | exec_Sassign: forall e le m a1 a2 loc ofs v2 v m', - eval_lvalue ge e le m a1 loc ofs -> + | exec_Sassign: forall e le m a1 a2 loc ofs bf v2 v m', + eval_lvalue ge e le m a1 loc ofs bf -> eval_expr ge e le m a2 v2 -> sem_cast v2 (typeof a2) (typeof a1) m = Some v -> - assign_loc ge (typeof a1) m loc ofs v m' -> + assign_loc ge (typeof a1) m loc ofs bf v m' -> exec_stmt e le m (Sassign a1 a2) E0 le m' Out_normal | exec_Sset: forall e le m id a v, diff --git a/cfrontend/Cminorgen.v b/cfrontend/Cminorgen.v index 45c21f96..1b031866 100644 --- a/cfrontend/Cminorgen.v +++ b/cfrontend/Cminorgen.v @@ -240,7 +240,7 @@ Module VarOrder <: TotalLeBool. Theorem leb_total: forall v1 v2, leb v1 v2 = true \/ leb v2 v1 = true. Proof. unfold leb; intros. - assert (snd v1 <= snd v2 \/ snd v2 <= snd v1) by omega. + assert (snd v1 <= snd v2 \/ snd v2 <= snd v1) by lia. unfold proj_sumbool. destruct H; [left|right]; apply zle_true; auto. Qed. End VarOrder. diff --git a/cfrontend/Cminorgenproof.v b/cfrontend/Cminorgenproof.v index 5acb996d..bc1c92ca 100644 --- a/cfrontend/Cminorgenproof.v +++ b/cfrontend/Cminorgenproof.v @@ -287,7 +287,7 @@ Lemma match_env_external_call: Proof. intros. apply match_env_invariant with f1; auto. intros. eapply inject_incr_separated_same'; eauto. - intros. eapply inject_incr_separated_same; eauto. red. destruct H. xomega. + intros. eapply inject_incr_separated_same; eauto. red. destruct H. extlia. Qed. (** [match_env] and allocations *) @@ -317,18 +317,18 @@ Proof. constructor; eauto. constructor. (* low-high *) - rewrite NEXTBLOCK; xomega. + rewrite NEXTBLOCK; extlia. (* bounded *) intros. rewrite PTree.gsspec in H. destruct (peq id0 id). - inv H. rewrite NEXTBLOCK; xomega. - exploit me_bounded0; eauto. rewrite NEXTBLOCK; xomega. + inv H. rewrite NEXTBLOCK; extlia. + exploit me_bounded0; eauto. rewrite NEXTBLOCK; extlia. (* inv *) intros. destruct (eq_block b (Mem.nextblock m1)). subst b. rewrite SAME in H; inv H. exists id; exists sz. apply PTree.gss. rewrite OTHER in H; auto. exploit me_inv0; eauto. intros [id1 [sz1 EQ]]. exists id1; exists sz1. rewrite PTree.gso; auto. congruence. (* incr *) - intros. rewrite OTHER in H. eauto. unfold block in *; xomega. + intros. rewrite OTHER in H. eauto. unfold block in *; extlia. Qed. (** The sizes of blocks appearing in [e] are respected. *) @@ -512,23 +512,23 @@ Proof. (* base case *) econstructor; eauto. inv H. constructor; intros; eauto. - eapply IMAGE; eauto. eapply H6; eauto. xomega. + eapply IMAGE; eauto. eapply H6; eauto. extlia. (* inductive case *) assert (Ple lo hi) by (eapply me_low_high; eauto). econstructor; eauto. eapply match_temps_invariant; eauto. eapply match_env_invariant; eauto. - intros. apply H3. xomega. + intros. apply H3. extlia. eapply match_bounds_invariant; eauto. intros. eapply H1; eauto. - exploit me_bounded; eauto. xomega. + exploit me_bounded; eauto. extlia. eapply padding_freeable_invariant; eauto. - intros. apply H3. xomega. + intros. apply H3. extlia. eapply IHmatch_callstack; eauto. - intros. eapply H1; eauto. xomega. - intros. eapply H2; eauto. xomega. - intros. eapply H3; eauto. xomega. - intros. eapply H4; eauto. xomega. + intros. eapply H1; eauto. extlia. + intros. eapply H2; eauto. extlia. + intros. eapply H3; eauto. extlia. + intros. eapply H4; eauto. extlia. Qed. Lemma match_callstack_incr_bound: @@ -538,8 +538,8 @@ Lemma match_callstack_incr_bound: match_callstack f m tm cs bound' tbound'. Proof. intros. inv H. - econstructor; eauto. xomega. xomega. - constructor; auto. xomega. xomega. + econstructor; eauto. extlia. extlia. + constructor; auto. extlia. extlia. Qed. (** Assigning a temporary variable. *) @@ -596,17 +596,17 @@ Proof. auto. inv A. assert (Mem.range_perm m b 0 sz Cur Freeable). eapply free_list_freeable; eauto. eapply in_blocks_of_env; eauto. - replace ofs with ((ofs - delta) + delta) by omega. - eapply Mem.perm_inject; eauto. apply H3. omega. + replace ofs with ((ofs - delta) + delta) by lia. + eapply Mem.perm_inject; eauto. apply H3. lia. destruct X as [tm' FREE]. exploit nextblock_freelist; eauto. intro NEXT. exploit Mem.nextblock_free; eauto. intro NEXT'. exists tm'. split. auto. split. rewrite NEXT; rewrite NEXT'. - apply match_callstack_incr_bound with lo sp; try omega. + apply match_callstack_incr_bound with lo sp; try lia. apply match_callstack_invariant with f m tm; auto. intros. eapply perm_freelist; eauto. - intros. eapply Mem.perm_free_1; eauto. left; unfold block; xomega. xomega. xomega. + intros. eapply Mem.perm_free_1; eauto. left; unfold block; extlia. extlia. extlia. eapply Mem.free_inject; eauto. intros. exploit me_inv0; eauto. intros [id [sz A]]. exists 0; exists sz; split. @@ -636,21 +636,21 @@ Proof. inv H. constructor; auto. intros. case_eq (f1 b1). intros [b2' delta'] EQ. rewrite (INCR _ _ _ EQ) in H. inv H. eauto. - intro EQ. exploit SEPARATED; eauto. intros [A B]. elim B. red. xomega. + intro EQ. exploit SEPARATED; eauto. intros [A B]. elim B. red. extlia. (* inductive case *) constructor. auto. auto. eapply match_temps_invariant; eauto. eapply match_env_invariant; eauto. red in SEPARATED. intros. destruct (f1 b) as [[b' delta']|] eqn:?. exploit INCR; eauto. congruence. - exploit SEPARATED; eauto. intros [A B]. elim B. red. xomega. + exploit SEPARATED; eauto. intros [A B]. elim B. red. extlia. intros. assert (Ple lo hi) by (eapply me_low_high; eauto). destruct (f1 b) as [[b' delta']|] eqn:?. apply INCR; auto. destruct (f2 b) as [[b' delta']|] eqn:?; auto. - exploit SEPARATED; eauto. intros [A B]. elim A. red. xomega. + exploit SEPARATED; eauto. intros [A B]. elim A. red. extlia. eapply match_bounds_invariant; eauto. - intros. eapply MAXPERMS; eauto. red. exploit me_bounded; eauto. xomega. + intros. eapply MAXPERMS; eauto. red. exploit me_bounded; eauto. extlia. (* padding-freeable *) red; intros. destruct (is_reachable_from_env_dec f1 e sp ofs). @@ -660,10 +660,10 @@ Proof. red; intros; red; intros. elim H3. exploit me_inv; eauto. intros [id [lv B]]. exploit BOUND0; eauto. intros C. - apply is_reachable_intro with id b0 lv delta; auto; omega. + apply is_reachable_intro with id b0 lv delta; auto; lia. eauto with mem. (* induction *) - eapply IHmatch_callstack; eauto. inv MENV; xomega. xomega. + eapply IHmatch_callstack; eauto. inv MENV; extlia. extlia. Qed. (** [match_callstack] and allocations *) @@ -683,12 +683,12 @@ Proof. exploit Mem.nextblock_alloc; eauto. intros NEXTBLOCK. exploit Mem.alloc_result; eauto. intros RES. constructor. - xomega. - unfold block in *; xomega. + extlia. + unfold block in *; extlia. auto. constructor; intros. rewrite H3. rewrite PTree.gempty. constructor. - xomega. + extlia. rewrite PTree.gempty in H4; discriminate. eelim Mem.fresh_block_alloc; eauto. eapply Mem.valid_block_inject_2; eauto. rewrite RES. change (Mem.valid_block tm tb). eapply Mem.valid_block_inject_2; eauto. @@ -719,23 +719,23 @@ Proof. exploit Mem.alloc_result; eauto. intros RES. assert (LO: Ple lo (Mem.nextblock m1)) by (eapply me_low_high; eauto). constructor. - xomega. + extlia. auto. eapply match_temps_invariant; eauto. eapply match_env_alloc; eauto. red; intros. rewrite PTree.gsspec in H. destruct (peq id0 id). inversion H. subst b0 sz0 id0. eapply Mem.perm_alloc_3; eauto. eapply BOUND0; eauto. eapply Mem.perm_alloc_4; eauto. - exploit me_bounded; eauto. unfold block in *; xomega. + exploit me_bounded; eauto. unfold block in *; extlia. red; intros. exploit PERM; eauto. intros [A|A]. auto. right. inv A. apply is_reachable_intro with id0 b0 sz0 delta; auto. rewrite PTree.gso. auto. congruence. eapply match_callstack_invariant with (m1 := m1); eauto. intros. eapply Mem.perm_alloc_4; eauto. - unfold block in *; xomega. - intros. apply H4. unfold block in *; xomega. + unfold block in *; extlia. + intros. apply H4. unfold block in *; extlia. intros. destruct (eq_block b0 b). - subst b0. rewrite H3 in H. inv H. xomegaContradiction. + subst b0. rewrite H3 in H. inv H. extlia. rewrite H4 in H; auto. Qed. @@ -828,11 +828,11 @@ Proof. eexact MINJ. eexact H. eexact VALID. - instantiate (1 := ofs). zify. omega. - intros. exploit STKSIZE; eauto. omega. - intros. apply STKPERMS. zify. omega. - replace (sz - 0) with sz by omega. auto. - intros. eapply SEP2. eauto with coqlib. eexact CENV. eauto. eauto. omega. + instantiate (1 := ofs). zify. lia. + intros. exploit STKSIZE; eauto. lia. + intros. apply STKPERMS. zify. lia. + replace (sz - 0) with sz by lia. auto. + intros. eapply SEP2. eauto with coqlib. eexact CENV. eauto. eauto. lia. intros [f2 [A [B [C D]]]]. exploit (IHalloc_variables f2); eauto. red; intros. eapply COMPAT. auto with coqlib. @@ -841,7 +841,7 @@ Proof. subst b. rewrite C in H5; inv H5. exploit SEP1. eapply in_eq. eapply in_cons; eauto. eauto. eauto. red; intros; subst id0. elim H3. change id with (fst (id, sz0)). apply in_map; auto. - omega. + lia. eapply SEP2. apply in_cons; eauto. eauto. rewrite D in H5; eauto. eauto. auto. intros. rewrite PTree.gso. eapply UNBOUND; eauto with coqlib. @@ -890,9 +890,9 @@ Remark block_alignment_pos: forall sz, block_alignment sz > 0. Proof. unfold block_alignment; intros. - destruct (zlt sz 2). omega. - destruct (zlt sz 4). omega. - destruct (zlt sz 8); omega. + destruct (zlt sz 2). lia. + destruct (zlt sz 4). lia. + destruct (zlt sz 8); lia. Qed. Remark assign_variable_incr: @@ -901,8 +901,8 @@ Remark assign_variable_incr: Proof. simpl; intros. inv H. generalize (align_le stksz (block_alignment sz) (block_alignment_pos sz)). - assert (0 <= Z.max 0 sz). apply Zmax_bound_l. omega. - omega. + assert (0 <= Z.max 0 sz). apply Zmax_bound_l. lia. + lia. Qed. Remark assign_variables_incr: @@ -910,7 +910,7 @@ Remark assign_variables_incr: assign_variables (cenv, sz) vars = (cenv', sz') -> sz <= sz'. Proof. induction vars; intros until sz'. - simpl; intros. inv H. omega. + simpl; intros. inv H. lia. Opaque assign_variable. destruct a as [id s]. simpl. intros. destruct (assign_variable (cenv, sz) (id, s)) as [cenv1 sz1] eqn:?. @@ -931,11 +931,11 @@ Proof. assert (2 | 8). exists 4; auto. assert (4 | 8). exists 2; auto. destruct (zlt sz 2). - destruct chunk; simpl in *; auto; omegaContradiction. + destruct chunk; simpl in *; auto; extlia. destruct (zlt sz 4). - destruct chunk; simpl in *; auto; omegaContradiction. + destruct chunk; simpl in *; auto; extlia. destruct (zlt sz 8). - destruct chunk; simpl in *; auto; omegaContradiction. + destruct chunk; simpl in *; auto; extlia. destruct chunk; simpl; auto. apply align_divides. apply block_alignment_pos. Qed. @@ -948,7 +948,7 @@ Proof. replace (block_alignment sz) with (block_alignment (Z.max 0 sz)). apply inj_offset_aligned_block. rewrite Zmax_spec. destruct (zlt sz 0); auto. - transitivity 1. reflexivity. unfold block_alignment. rewrite zlt_true. auto. omega. + transitivity 1. reflexivity. unfold block_alignment. rewrite zlt_true. auto. lia. Qed. Lemma assign_variable_sound: @@ -976,23 +976,23 @@ Proof. exploit COMPAT; eauto. intros [ofs [A [B [C D]]]]. exists ofs. split. rewrite PTree.gso; auto. - split. auto. split. auto. zify; omega. + split. auto. split. auto. zify; lia. inv P. exists (align sz1 (block_alignment sz)). split. apply PTree.gss. split. apply inj_offset_aligned_block. - split. omega. - omega. + split. lia. + lia. apply EITHER in H; apply EITHER in H0. destruct H as [[P Q] | P]; destruct H0 as [[R S] | R]. rewrite PTree.gso in *; auto. eapply SEP; eauto. inv R. rewrite PTree.gso in H1; auto. rewrite PTree.gss in H2; inv H2. exploit COMPAT; eauto. intros [ofs [A [B [C D]]]]. assert (ofs = ofs1) by congruence. subst ofs. - left. zify; omega. + left. zify; lia. inv P. rewrite PTree.gso in H2; auto. rewrite PTree.gss in H1; inv H1. exploit COMPAT; eauto. intros [ofs [A [B [C D]]]]. assert (ofs = ofs2) by congruence. subst ofs. - right. zify; omega. + right. zify; lia. congruence. Qed. @@ -1023,7 +1023,7 @@ Proof. split. rewrite map_app. apply list_norepet_append_commut. simpl. constructor; auto. rewrite map_app. simpl. red; intros. rewrite in_app in H4. destruct H4. eauto. simpl in H4. destruct H4. subst y. red; intros; subst x. tauto. tauto. - generalize (assign_variable_incr _ _ _ _ _ _ Heqp). omega. + generalize (assign_variable_incr _ _ _ _ _ _ Heqp). lia. auto. auto. rewrite app_ass. auto. Qed. @@ -1054,7 +1054,7 @@ Proof. eexact H. simpl. rewrite app_nil_r. apply permutation_norepet with (map fst vars1); auto. apply Permutation_map. auto. - omega. + lia. red; intros. contradiction. red; intros. contradiction. destruct H1 as [A B]. split. @@ -1680,11 +1680,11 @@ Lemma switch_table_default: /\ snd (switch_table sl base) = (n + base)%nat. Proof. induction sl; simpl; intros. -- exists O; split. constructor. omega. +- exists O; split. constructor. lia. - destruct o. + destruct (IHsl (S base)) as (n & P & Q). exists (S n); split. constructor; auto. - destruct (switch_table sl (S base)) as [tbl dfl]; simpl in *. omega. + destruct (switch_table sl (S base)) as [tbl dfl]; simpl in *. lia. + exists O; split. constructor. destruct (switch_table sl (S base)) as [tbl dfl]; simpl in *. auto. Qed. @@ -1708,11 +1708,11 @@ Proof. exists O; split; auto. constructor. specialize (IHsl (S base) dfl). rewrite ST in IHsl. simpl in *. destruct (select_switch_case i sl). - destruct IHsl as (x & P & Q). exists (S x); split. constructor; auto. omega. + destruct IHsl as (x & P & Q). exists (S x); split. constructor; auto. lia. auto. specialize (IHsl (S base) dfl). rewrite ST in IHsl. simpl in *. destruct (select_switch_case i sl). - destruct IHsl as (x & P & Q). exists (S x); split. constructor; auto. omega. + destruct IHsl as (x & P & Q). exists (S x); split. constructor; auto. lia. auto. Qed. @@ -1725,10 +1725,10 @@ Proof. unfold select_switch; intros. generalize (switch_table_case i sl O (snd (switch_table sl O))). destruct (select_switch_case i sl) as [sl'|]. - intros (n & P & Q). replace (n + O)%nat with n in Q by omega. congruence. + intros (n & P & Q). replace (n + O)%nat with n in Q by lia. congruence. intros E; rewrite E. destruct (switch_table_default sl O) as (n & P & Q). - replace (n + O)%nat with n in Q by omega. congruence. + replace (n + O)%nat with n in Q by lia. congruence. Qed. Inductive transl_lblstmt_cont(cenv: compilenv) (xenv: exit_env): lbl_stmt -> cont -> cont -> Prop := @@ -2039,7 +2039,7 @@ Proof. apply match_callstack_incr_bound with (Mem.nextblock m) (Mem.nextblock tm). eapply match_callstack_external_call; eauto. intros. eapply external_call_max_perm; eauto. - xomega. xomega. + extlia. extlia. eapply external_call_nextblock; eauto. eapply external_call_nextblock; eauto. econstructor; eauto. @@ -2191,7 +2191,7 @@ Opaque PTree.set. apply match_callstack_incr_bound with (Mem.nextblock m) (Mem.nextblock tm). eapply match_callstack_external_call; eauto. intros. eapply external_call_max_perm; eauto. - xomega. xomega. + extlia. extlia. eapply external_call_nextblock; eauto. eapply external_call_nextblock; eauto. @@ -2235,7 +2235,7 @@ Proof. eapply match_callstate with (f := Mem.flat_inj (Mem.nextblock m0)) (cs := @nil frame) (cenv := PTree.empty Z). auto. eapply Genv.initmem_inject; eauto. - apply mcs_nil with (Mem.nextblock m0). apply match_globalenvs_init; auto. xomega. xomega. + apply mcs_nil with (Mem.nextblock m0). apply match_globalenvs_init; auto. extlia. extlia. constructor. red; auto. constructor. Qed. diff --git a/cfrontend/Cop.v b/cfrontend/Cop.v index 143e87a3..0d7bcc3a 100644 --- a/cfrontend/Cop.v +++ b/cfrontend/Cop.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -1083,6 +1084,60 @@ Definition incrdecr_type (ty: type) := | _ => Tvoid end. +(** ** Accessing bit fields *) + +Definition chunk_for_carrier (sz: intsize) : memory_chunk := + match sz with + | I8 | IBool => Mint8unsigned + | I16 => Mint16unsigned + | I32 => Mint32 + end. + +(** For bitfield accesses, bits are numbered differently on + little-endian and on big-endian machines: bit 0 is the least + significant bit in little-endian, and the most significant bit in + big-endian. *) + +Definition bitsize_carrier (sz: intsize) : Z := + match sz with + | I8 | IBool => 8 + | I16 => 16 + | I32 => 32 + end. + +Definition first_bit (sz: intsize) (pos width: Z) : Z := + if Archi.big_endian + then bitsize_carrier sz - pos - width + else pos. + +Definition bitfield_extract (sz: intsize) (sg: signedness) (pos width: Z) (c: int) : int := + if intsize_eq sz IBool || signedness_eq sg Unsigned + then Int.unsigned_bitfield_extract (first_bit sz pos width) width c + else Int.signed_bitfield_extract (first_bit sz pos width) width c. + +Definition bitfield_normalize (sz: intsize) (sg: signedness) (width: Z) (n: int) : int := + if intsize_eq sz IBool || signedness_eq sg Unsigned + then Int.zero_ext width n + else Int.sign_ext width n. + +Inductive load_bitfield: type -> intsize -> signedness -> Z -> Z -> mem -> val -> val -> Prop := + | load_bitfield_intro: forall sz sg1 attr sg pos width m addr c, + 0 <= pos -> 0 < width <= bitsize_intsize sz -> pos + width <= bitsize_carrier sz -> + sg1 = (if zlt width (bitsize_intsize sz) then Signed else sg) -> + Mem.loadv (chunk_for_carrier sz) m addr = Some (Vint c) -> + load_bitfield (Tint sz sg1 attr) sz sg pos width m addr + (Vint (bitfield_extract sz sg pos width c)). + +Inductive store_bitfield: type -> intsize -> signedness -> Z -> Z -> mem -> val -> val -> mem -> val -> Prop := + | store_bitfield_intro: forall sz sg1 attr sg pos width m addr c n m', + 0 <= pos -> 0 < width <= bitsize_intsize sz -> pos + width <= bitsize_carrier sz -> + sg1 = (if zlt width (bitsize_intsize sz) then Signed else sg) -> + Mem.loadv (chunk_for_carrier sz) m addr = Some (Vint c) -> + Mem.storev (chunk_for_carrier sz) m addr + (Vint (Int.bitfield_insert (first_bit sz pos width) width c n)) = Some m' -> + store_bitfield (Tint sz sg1 attr) sz sg pos width m addr (Vint n) + m' (Vint (bitfield_normalize sz sg width n)). + (** * Compatibility with extensions and injections *) Section GENERIC_INJECTION. diff --git a/cfrontend/Csem.v b/cfrontend/Csem.v index 6d2b470f..6698c56f 100644 --- a/cfrontend/Csem.v +++ b/cfrontend/Csem.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -45,49 +46,59 @@ Section SEMANTICS. Variable ge: genv. -(** [deref_loc ty m b ofs t v] computes the value of a datum - of type [ty] residing in memory [m] at block [b], offset [ofs]. +(** [deref_loc ty m b ofs bf t v] computes the value of a datum + of type [ty] residing in memory [m] at block [b], offset [ofs], + and bitfield designation [bf]. If the type [ty] indicates an access by value, the corresponding memory load is performed. If the type [ty] indicates an access by reference, the pointer [Vptr b ofs] is returned. [v] is the value returned, and [t] the trace of observables (nonempty if this is a volatile access). *) -Inductive deref_loc (ty: type) (m: mem) (b: block) (ofs: ptrofs) : trace -> val -> Prop := +Inductive deref_loc (ty: type) (m: mem) (b: block) (ofs: ptrofs) : + bitfield -> trace -> val -> Prop := | deref_loc_value: forall chunk v, access_mode ty = By_value chunk -> type_is_volatile ty = false -> Mem.loadv chunk m (Vptr b ofs) = Some v -> - deref_loc ty m b ofs E0 v + deref_loc ty m b ofs Full E0 v | deref_loc_volatile: forall chunk t v, access_mode ty = By_value chunk -> type_is_volatile ty = true -> volatile_load ge chunk m b ofs t v -> - deref_loc ty m b ofs t v + deref_loc ty m b ofs Full t v | deref_loc_reference: access_mode ty = By_reference -> - deref_loc ty m b ofs E0 (Vptr b ofs) + deref_loc ty m b ofs Full E0 (Vptr b ofs) | deref_loc_copy: access_mode ty = By_copy -> - deref_loc ty m b ofs E0 (Vptr b ofs). + deref_loc ty m b ofs Full E0 (Vptr b ofs) + | deref_loc_bitfield: forall sz sg pos width v, + load_bitfield ty sz sg pos width m (Vptr b ofs) v -> + deref_loc ty m b ofs (Bits sz sg pos width) E0 v. -(** Symmetrically, [assign_loc ty m b ofs v t m'] returns the +(** Symmetrically, [assign_loc ty m b ofs bf v t m' v'] returns the memory state after storing the value [v] in the datum - of type [ty] residing in memory [m] at block [b], offset [ofs]. + of type [ty] residing in memory [m] at block [b], offset [ofs], + and bitfield designation [bf]. This is allowed only if [ty] indicates an access by value or by copy. [m'] is the updated memory state and [t] the trace of observables - (nonempty if this is a volatile store). *) + (nonempty if this is a volatile store). + [v'] is the result value of the assignment. It is equal to [v] + if [bf] is [Full], and to [v] normalized to the width and signedness + of the bitfield [bf] otherwise. +*) Inductive assign_loc (ty: type) (m: mem) (b: block) (ofs: ptrofs): - val -> trace -> mem -> Prop := + bitfield -> val -> trace -> mem -> val -> Prop := | assign_loc_value: forall v chunk m', access_mode ty = By_value chunk -> type_is_volatile ty = false -> Mem.storev chunk m (Vptr b ofs) v = Some m' -> - assign_loc ty m b ofs v E0 m' + assign_loc ty m b ofs Full v E0 m' v | assign_loc_volatile: forall v chunk t m', access_mode ty = By_value chunk -> type_is_volatile ty = true -> volatile_store ge chunk m b ofs v t m' -> - assign_loc ty m b ofs v t m' + assign_loc ty m b ofs Full v t m' v | assign_loc_copy: forall b' ofs' bytes m', access_mode ty = By_copy -> (alignof_blockcopy ge ty | Ptrofs.unsigned ofs') -> @@ -97,7 +108,10 @@ Inductive assign_loc (ty: type) (m: mem) (b: block) (ofs: ptrofs): \/ Ptrofs.unsigned ofs + sizeof ge ty <= Ptrofs.unsigned ofs' -> Mem.loadbytes m b' (Ptrofs.unsigned ofs') (sizeof ge ty) = Some bytes -> Mem.storebytes m b (Ptrofs.unsigned ofs) bytes = Some m' -> - assign_loc ty m b ofs (Vptr b' ofs') E0 m'. + assign_loc ty m b ofs Full (Vptr b' ofs') E0 m' (Vptr b' ofs') + | assign_loc_bitfield: forall sz sg pos width v m' v', + store_bitfield ty sz sg pos width m (Vptr b ofs) v m' v' -> + assign_loc ty m b ofs (Bits sz sg pos width) v E0 m' v'. (** Allocation of function-local variables. [alloc_variables e1 m1 vars e2 m2] allocates one memory block @@ -130,9 +144,9 @@ Inductive bind_parameters (e: env): forall m, bind_parameters e m nil nil m | bind_parameters_cons: - forall m id ty params v1 vl b m1 m2, + forall m id ty params v1 vl v1' b m1 m2, PTree.get id e = Some(b, ty) -> - assign_loc ty m b Ptrofs.zero v1 E0 m1 -> + assign_loc ty m b Ptrofs.zero Full v1 E0 m1 v1' -> bind_parameters e m1 params vl m2 -> bind_parameters e m ((id, ty) :: params) (v1 :: vl) m2. @@ -201,34 +215,35 @@ Inductive lred: expr -> mem -> expr -> mem -> Prop := | red_var_local: forall x ty m b, e!x = Some(b, ty) -> lred (Evar x ty) m - (Eloc b Ptrofs.zero ty) m + (Eloc b Ptrofs.zero Full ty) m | red_var_global: forall x ty m b, e!x = None -> Genv.find_symbol ge x = Some b -> lred (Evar x ty) m - (Eloc b Ptrofs.zero ty) m + (Eloc b Ptrofs.zero Full ty) m | red_deref: forall b ofs ty1 ty m, lred (Ederef (Eval (Vptr b ofs) ty1) ty) m - (Eloc b ofs ty) m - | red_field_struct: forall b ofs id co a f ty m delta, + (Eloc b ofs Full ty) m + | red_field_struct: forall b ofs id co a f ty m delta bf, ge.(genv_cenv)!id = Some co -> - field_offset ge f (co_members co) = OK delta -> + field_offset ge f (co_members co) = OK (delta, bf) -> lred (Efield (Eval (Vptr b ofs) (Tstruct id a)) f ty) m - (Eloc b (Ptrofs.add ofs (Ptrofs.repr delta)) ty) m - | red_field_union: forall b ofs id co a f ty m, + (Eloc b (Ptrofs.add ofs (Ptrofs.repr delta)) bf ty) m + | red_field_union: forall b ofs id co a f ty m delta bf, ge.(genv_cenv)!id = Some co -> + union_field_offset ge f (co_members co) = OK (delta, bf) -> lred (Efield (Eval (Vptr b ofs) (Tunion id a)) f ty) m - (Eloc b ofs ty) m. + (Eloc b (Ptrofs.add ofs (Ptrofs.repr delta)) bf ty) m. (** Head reductions for r-values *) Inductive rred: expr -> mem -> trace -> expr -> mem -> Prop := - | red_rvalof: forall b ofs ty m t v, - deref_loc ty m b ofs t v -> - rred (Evalof (Eloc b ofs ty) ty) m + | red_rvalof: forall b ofs bf ty m t v, + deref_loc ty m b ofs bf t v -> + rred (Evalof (Eloc b ofs bf ty) ty) m t (Eval v ty) m | red_addrof: forall b ofs ty1 ty m, - rred (Eaddrof (Eloc b ofs ty1) ty) m + rred (Eaddrof (Eloc b ofs Full ty1) ty) m E0 (Eval (Vptr b ofs) ty) m | red_unop: forall op v1 ty1 ty m v, sem_unary_operation op v1 ty1 m = Some v -> @@ -268,21 +283,21 @@ Inductive rred: expr -> mem -> trace -> expr -> mem -> Prop := | red_alignof: forall ty1 ty m, rred (Ealignof ty1 ty) m E0 (Eval (Vptrofs (Ptrofs.repr (alignof ge ty1))) ty) m - | red_assign: forall b ofs ty1 v2 ty2 m v t m', + | red_assign: forall b ofs ty1 bf v2 ty2 m v t m' v', sem_cast v2 ty2 ty1 m = Some v -> - assign_loc ty1 m b ofs v t m' -> - rred (Eassign (Eloc b ofs ty1) (Eval v2 ty2) ty1) m - t (Eval v ty1) m' - | red_assignop: forall op b ofs ty1 v2 ty2 tyres m t v1, - deref_loc ty1 m b ofs t v1 -> - rred (Eassignop op (Eloc b ofs ty1) (Eval v2 ty2) tyres ty1) m - t (Eassign (Eloc b ofs ty1) + assign_loc ty1 m b ofs bf v t m' v' -> + rred (Eassign (Eloc b ofs bf ty1) (Eval v2 ty2) ty1) m + t (Eval v' ty1) m' + | red_assignop: forall op b ofs ty1 bf v2 ty2 tyres m t v1, + deref_loc ty1 m b ofs bf t v1 -> + rred (Eassignop op (Eloc b ofs bf ty1) (Eval v2 ty2) tyres ty1) m + t (Eassign (Eloc b ofs bf ty1) (Ebinop op (Eval v1 ty1) (Eval v2 ty2) tyres) ty1) m - | red_postincr: forall id b ofs ty m t v1 op, - deref_loc ty m b ofs t v1 -> + | red_postincr: forall id b ofs ty bf m t v1 op, + deref_loc ty m b ofs bf t v1 -> op = match id with Incr => Oadd | Decr => Osub end -> - rred (Epostincr id (Eloc b ofs ty) ty) m - t (Ecomma (Eassign (Eloc b ofs ty) + rred (Epostincr id (Eloc b ofs bf ty) ty) m + t (Ecomma (Eassign (Eloc b ofs bf ty) (Ebinop op (Eval v1 ty) (Eval (Vint Int.one) type_int32s) (incrdecr_type ty)) @@ -408,8 +423,8 @@ with contextlist: kind -> (expr -> exprlist) -> Prop := Inductive imm_safe: kind -> expr -> mem -> Prop := | imm_safe_val: forall v ty m, imm_safe RV (Eval v ty) m - | imm_safe_loc: forall b ofs ty m, - imm_safe LV (Eloc b ofs ty) m + | imm_safe_loc: forall b ofs bf ty m, + imm_safe LV (Eloc b ofs bf ty) m | imm_safe_lred: forall to C e m e' m', lred e m e' m' -> context LV to C -> @@ -838,12 +853,12 @@ Lemma semantics_single_events: Proof. unfold semantics; intros; red; simpl; intros. set (ge := globalenv p) in *. - assert (DEREF: forall chunk m b ofs t v, deref_loc ge chunk m b ofs t v -> (length t <= 1)%nat). - intros. inv H0; simpl; try omega. inv H3; simpl; try omega. - assert (ASSIGN: forall chunk m b ofs t v m', assign_loc ge chunk m b ofs v t m' -> (length t <= 1)%nat). - intros. inv H0; simpl; try omega. inv H3; simpl; try omega. + assert (DEREF: forall chunk m b ofs bf t v, deref_loc ge chunk m b ofs bf t v -> (length t <= 1)%nat). + { intros. inv H0; simpl; try lia. inv H3; simpl; try lia. } + assert (ASSIGN: forall chunk m b ofs bf t v m' v', assign_loc ge chunk m b ofs bf v t m' v' -> (length t <= 1)%nat). + { intros. inv H0; simpl; try lia. inv H3; simpl; try lia. } destruct H. - inv H; simpl; try omega. inv H0; eauto; simpl; try omega. + inv H; simpl; try lia. inv H0; eauto; simpl; try lia. eapply external_call_trace_length; eauto. - inv H; simpl; try omega. eapply external_call_trace_length; eauto. + inv H; simpl; try lia. eapply external_call_trace_length; eauto. Qed. diff --git a/cfrontend/Cshmgen.v b/cfrontend/Cshmgen.v index 5bd12d00..9e804176 100644 --- a/cfrontend/Cshmgen.v +++ b/cfrontend/Cshmgen.v @@ -372,19 +372,56 @@ Definition make_cmp (c: comparison) (e1: expr) (ty1: type) (e2: expr) (ty2: type e1 ty1 e2 ty2 end. +(** Auxiliary for translating bitfield accesses *) + +Definition make_extract_bitfield (sz: intsize) (sg: signedness) (pos width: Z) + (addr: expr) : res expr := + if zle 0 pos && zlt 0 width && zle (pos + width) (bitsize_carrier sz) then + let amount1 := Int.repr (Int.zwordsize - first_bit sz pos width - width) in + let amount2 := Int.repr (Int.zwordsize - width) in + let e1 := Eload (chunk_for_carrier sz) addr in + let e2 := Ebinop Oshl e1 (make_intconst amount1) in + let e3 := Ebinop (if intsize_eq sz IBool + || signedness_eq sg Unsigned then Oshru else Oshr) + e2 (make_intconst amount2) in + OK e3 + else + Error(msg "Cshmgen.extract_bitfield"). + (** [make_load addr ty_res] loads a value of type [ty_res] from - the memory location denoted by the Csharpminor expression [addr]. + the memory location denoted by the Csharpminor expression [addr] + and the bitfield designator [bf]. If [ty_res] is an array or function type, returns [addr] instead, as consistent with C semantics. *) -Definition make_load (addr: expr) (ty_res: type) := - match (access_mode ty_res) with - | By_value chunk => OK (Eload chunk addr) - | By_reference => OK addr - | By_copy => OK addr - | By_nothing => Error (msg "Cshmgen.make_load") - end. +Definition make_load (addr: expr) (ty_res: type) (bf: bitfield) := + match bf with + | Full => + match access_mode ty_res with + | By_value chunk => OK (Eload chunk addr) + | By_reference => OK addr + | By_copy => OK addr + | By_nothing => Error (msg "Cshmgen.make_load") + end + | Bits sz sg pos width => + make_extract_bitfield sz sg pos width addr + end. + +(** Auxiliary for translating bitfield updates *) + +Definition make_store_bitfield (sz: intsize) (sg: signedness) (pos width: Z) + (addr val: expr) : res stmt := + if zle 0 pos && zlt 0 width && zle (pos + width) (bitsize_carrier sz) then + let amount := first_bit sz pos width in + let mask := Int.shl (Int.repr (two_p width - 1)) (Int.repr amount) in + let e1 := Eload (chunk_for_carrier sz) addr in + let e2 := Ebinop Oshl val (make_intconst (Int.repr amount)) in + let e3 := Ebinop Oor (Ebinop Oand e2 (make_intconst mask)) + (Ebinop Oand e1 (make_intconst (Int.not mask))) in + OK (Sstore (chunk_for_carrier sz) addr e3) + else + Error(msg "Cshmgen.make_store_bitfield"). (** [make_memcpy dst src ty] returns a [memcpy] builtin appropriate for by-copy assignment of a value of Clight type [ty]. *) @@ -394,16 +431,21 @@ Definition make_memcpy (ce: composite_env) (dst src: expr) (ty: type) := OK (Sbuiltin None (EF_memcpy sz (Ctypes.alignof_blockcopy ce ty)) (dst :: src :: nil)). -(** [make_store addr ty rhs] stores the value of the +(** [make_store addr ty bf rhs] stores the value of the Csharpminor expression [rhs] into the memory location denoted by the Csharpminor expression [addr]. - [ty] is the type of the memory location. *) - -Definition make_store (ce: composite_env) (addr: expr) (ty: type) (rhs: expr) := - match access_mode ty with - | By_value chunk => OK (Sstore chunk addr rhs) - | By_copy => make_memcpy ce addr rhs ty - | _ => Error (msg "Cshmgen.make_store") + [ty] is the type of the memory location and [bf] a bitfield designator. *) + +Definition make_store (ce: composite_env) (addr: expr) (ty: type) (bf: bitfield) (rhs: expr) := + match bf with + | Full => + match access_mode ty with + | By_value chunk => OK (Sstore chunk addr rhs) + | By_copy => make_memcpy ce addr rhs ty + | _ => Error (msg "Cshmgen.make_store") + end + | Bits sz sg pos width => + make_store_bitfield sz sg pos width addr rhs end. (** ** Translation of operators *) @@ -441,23 +483,27 @@ Definition transl_binop (ce: composite_env) (** ** Translation of field accesses *) -Definition make_field_access (ce: composite_env) (ty: type) (f: ident) (a: expr) : res expr := - match ty with - | Tstruct id _ => - match ce!id with - | None => - Error (MSG "Undefined struct " :: CTX id :: nil) - | Some co => - do ofs <- field_offset ce f (co_members co); - OK (if Archi.ptr64 - then Ebinop Oaddl a (make_longconst (Int64.repr ofs)) - else Ebinop Oadd a (make_intconst (Int.repr ofs))) - end - | Tunion id _ => - OK a - | _ => - Error(msg "Cshmgen.make_field_access") - end. +Definition make_field_access (ce: composite_env) (ty: type) (f: ident) (a: expr) : res (expr * bitfield) := + do (ofs, bf) <- + match ty with + | Tstruct id _ => + match ce!id with + | None => Error (MSG "Undefined struct " :: CTX id :: nil) + | Some co => field_offset ce f (co_members co) + end + | Tunion id _ => + match ce!id with + | None => Error (MSG "Undefined union " :: CTX id :: nil) + | Some co => union_field_offset ce f (co_members co) + end + | _ => + Error(msg "Cshmgen.make_field_access") + end; + let a' := + if Archi.ptr64 + then Ebinop Oaddl a (make_longconst (Int64.repr ofs)) + else Ebinop Oadd a (make_intconst (Int.repr ofs)) in + OK (a', bf). (** * Translation of expressions *) @@ -476,14 +522,18 @@ Fixpoint transl_expr (ce: composite_env) (a: Clight.expr) {struct a} : res expr | Clight.Econst_long n _ => OK(make_longconst n) | Clight.Evar id ty => - make_load (Eaddrof id) ty + make_load (Eaddrof id) ty Full | Clight.Etempvar id ty => OK(Evar id) | Clight.Ederef b ty => do tb <- transl_expr ce b; - make_load tb ty + make_load tb ty Full | Clight.Eaddrof b _ => - transl_lvalue ce b + do (tb, bf) <- transl_lvalue ce b; + match bf with + | Full => OK tb + | Bits _ _ _ _ => Error (msg "Cshmgen.transl_expr: addrof bitfield") + end | Clight.Eunop op b _ => do tb <- transl_expr ce b; transl_unop op tb (typeof b) @@ -496,8 +546,8 @@ Fixpoint transl_expr (ce: composite_env) (a: Clight.expr) {struct a} : res expr make_cast (typeof b) ty tb | Clight.Efield b i ty => do tb <- transl_expr ce b; - do addr <- make_field_access ce (typeof b) i tb; - make_load addr ty + do (addr, bf) <- make_field_access ce (typeof b) i tb; + make_load addr ty bf | Clight.Esizeof ty' ty => do sz <- sizeof ce ty'; OK(make_ptrofsconst sz) | Clight.Ealignof ty' ty => @@ -506,15 +556,16 @@ Fixpoint transl_expr (ce: composite_env) (a: Clight.expr) {struct a} : res expr (** [transl_lvalue a] returns the Csharpminor code that evaluates [a] as a lvalue, that is, code that returns the memory address - where the value of [a] is stored. + where the value of [a] is stored. It also returns the bitfield to be + accessed at this address, if appropriate. *) -with transl_lvalue (ce: composite_env) (a: Clight.expr) {struct a} : res expr := +with transl_lvalue (ce: composite_env) (a: Clight.expr) {struct a} : res (expr * bitfield) := match a with | Clight.Evar id _ => - OK (Eaddrof id) + OK (Eaddrof id, Full) | Clight.Ederef b _ => - transl_expr ce b + do tb <- transl_expr ce b; OK (tb, Full) | Clight.Efield b i ty => do tb <- transl_expr ce b; make_field_access ce (typeof b) i tb @@ -618,10 +669,10 @@ Fixpoint transl_statement (ce: composite_env) (tyret: type) (nbrk ncnt: nat) | Clight.Sskip => OK Sskip | Clight.Sassign b c => - do tb <- transl_lvalue ce b; + do (tb, bf) <- transl_lvalue ce b; do tc <- transl_expr ce c; do tc' <- make_cast (typeof c) (typeof b) tc; - make_store ce tb (typeof b) tc' + make_store ce tb (typeof b) bf tc' | Clight.Sset x b => do tb <- transl_expr ce b; OK(Sset x tb) diff --git a/cfrontend/Cshmgenproof.v b/cfrontend/Cshmgenproof.v index 1ceb8e4d..8e396e2a 100644 --- a/cfrontend/Cshmgenproof.v +++ b/cfrontend/Cshmgenproof.v @@ -115,6 +115,21 @@ Proof. destruct (prog_comp_env cunit)!i as [co|] eqn:X; try discriminate; erewrite H1 by eauto; auto. Qed. +Lemma union_field_offset_stable: + forall (cunit prog: Clight.program) id co f, + linkorder cunit prog -> + cunit.(prog_comp_env)!id = Some co -> + prog.(prog_comp_env)!id = Some co /\ + union_field_offset prog.(prog_comp_env) f (co_members co) = union_field_offset cunit.(prog_comp_env) f (co_members co). +Proof. + intros. + assert (C: composite_consistent cunit.(prog_comp_env) co). + { apply build_composite_env_consistent with cunit.(prog_types) id; auto. + apply prog_comp_env_eq. } + destruct H as [_ A]. + split. auto. apply Ctypes.union_field_offset_stable; eauto using co_consistent_complete. +Qed. + Lemma field_offset_stable: forall (cunit prog: Clight.program) id co f, linkorder cunit prog -> @@ -127,38 +142,11 @@ Proof. { apply build_composite_env_consistent with cunit.(prog_types) id; auto. apply prog_comp_env_eq. } destruct H as [_ A]. - split. auto. generalize (co_consistent_complete _ _ C). - unfold field_offset. generalize 0. induction (co_members co) as [ | [f1 t1] m]; simpl; intros. -- auto. -- InvBooleans. - rewrite ! (alignof_stable _ _ A) by auto. - rewrite ! (sizeof_stable _ _ A) by auto. - destruct (ident_eq f f1); eauto. + split. auto. apply Ctypes.field_offset_stable; eauto using co_consistent_complete. Qed. (** * Properties of the translation functions *) -(** Transformation of expressions and statements. *) - -Lemma transl_expr_lvalue: - forall ge e le m a loc ofs ce ta, - Clight.eval_lvalue ge e le m a loc ofs -> - transl_expr ce a = OK ta -> - (exists tb, transl_lvalue ce a = OK tb /\ make_load tb (typeof a) = OK ta). -Proof. - intros until ta; intros EVAL TR. inv EVAL; simpl in TR. - (* var local *) - exists (Eaddrof id); auto. - (* var global *) - exists (Eaddrof id); auto. - (* deref *) - monadInv TR. exists x; auto. - (* field struct *) - monadInv TR. exists x0; split; auto. simpl; rewrite EQ; auto. - (* field union *) - monadInv TR. exists x0; split; auto. simpl; rewrite EQ; auto. -Qed. - (** Properties of labeled statements *) Lemma transl_lbl_stmt_1: @@ -689,32 +677,32 @@ Proof. destruct (zlt 0 sz); try discriminate. destruct (zle sz Ptrofs.max_signed); simpl in SEM; inv SEM. assert (E1: Ptrofs.signed (Ptrofs.repr sz) = sz). - { apply Ptrofs.signed_repr. generalize Ptrofs.min_signed_neg; omega. } + { apply Ptrofs.signed_repr. generalize Ptrofs.min_signed_neg; lia. } destruct Archi.ptr64 eqn:SF; inversion EQ0; clear EQ0; subst c. + assert (E: Int64.signed (Int64.repr sz) = sz). { apply Int64.signed_repr. replace Int64.max_signed with Ptrofs.max_signed. - generalize Int64.min_signed_neg; omega. + generalize Int64.min_signed_neg; lia. unfold Ptrofs.max_signed, Ptrofs.half_modulus; rewrite Ptrofs.modulus_eq64 by auto. reflexivity. } econstructor; eauto with cshm. rewrite SF, dec_eq_true. simpl. predSpec Int64.eq Int64.eq_spec (Int64.repr sz) Int64.zero. - rewrite H in E; rewrite Int64.signed_zero in E; omegaContradiction. + rewrite H in E; rewrite Int64.signed_zero in E; extlia. predSpec Int64.eq Int64.eq_spec (Int64.repr sz) Int64.mone. - rewrite H0 in E; rewrite Int64.signed_mone in E; omegaContradiction. + rewrite H0 in E; rewrite Int64.signed_mone in E; extlia. rewrite andb_false_r; simpl. unfold Vptrofs; rewrite SF. apply f_equal. apply f_equal. symmetry. auto with ptrofs. + assert (E: Int.signed (Int.repr sz) = sz). { apply Int.signed_repr. replace Int.max_signed with Ptrofs.max_signed. - generalize Int.min_signed_neg; omega. + generalize Int.min_signed_neg; lia. unfold Ptrofs.max_signed, Ptrofs.half_modulus, Ptrofs.modulus, Ptrofs.wordsize, Wordsize_Ptrofs.wordsize. rewrite SF. reflexivity. } econstructor; eauto with cshm. rewrite SF, dec_eq_true. simpl. predSpec Int.eq Int.eq_spec (Int.repr sz) Int.zero. - rewrite H in E; rewrite Int.signed_zero in E; omegaContradiction. + rewrite H in E; rewrite Int.signed_zero in E; extlia. predSpec Int.eq Int.eq_spec (Int.repr sz) Int.mone. - rewrite H0 in E; rewrite Int.signed_mone in E; omegaContradiction. + rewrite H0 in E; rewrite Int.signed_mone in E; extlia. rewrite andb_false_r; simpl. unfold Vptrofs; rewrite SF. apply f_equal. apply f_equal. symmetry. auto with ptrofs. - destruct Archi.ptr64 eqn:SF; inv EQ0; rewrite (transl_sizeof _ _ _ _ LINK EQ). @@ -772,7 +760,7 @@ Proof. assert (Int64.unsigned i = Int.unsigned (Int64.loword i)). { unfold Int64.loword. rewrite Int.unsigned_repr; auto. - comput Int.max_unsigned; omega. + comput Int.max_unsigned; lia. } split; auto. unfold Int.ltu. apply zlt_true. rewrite <- H0. tauto. Qed. @@ -786,7 +774,7 @@ Proof. assert (Int64.unsigned i = Int.unsigned (Int64.loword i)). { unfold Int64.loword. rewrite Int.unsigned_repr; auto. - comput Int.max_unsigned; omega. + comput Int.max_unsigned; lia. } unfold Int.ltu. apply zlt_true. rewrite <- H0. tauto. Qed. @@ -797,7 +785,7 @@ Lemma small_shift_amount_3: Int64.unsigned (Int64.repr (Int.unsigned i)) = Int.unsigned i. Proof. intros. apply Int.ltu_inv in H. comput (Int.unsigned Int64.iwordsize'). - apply Int64.unsigned_repr. comput Int64.max_unsigned; omega. + apply Int64.unsigned_repr. comput Int64.max_unsigned; lia. Qed. Lemma make_shl_correct: shift_constructor_correct make_shl sem_shl. @@ -940,28 +928,83 @@ Proof. eapply make_cmp_correct; eauto. Qed. +Remark int_ltu_true: + forall x, 0 <= x < Int.zwordsize -> Int.ltu (Int.repr x) Int.iwordsize = true. +Proof. + intros. unfold Int.ltu. rewrite Int.unsigned_repr_wordsize, Int.unsigned_repr, zlt_true by (generalize Int.wordsize_max_unsigned; lia). + auto. +Qed. + +Remark first_bit_range: forall sz pos width, + 0 <= pos -> 0 < width -> pos + width <= bitsize_carrier sz -> + 0 <= first_bit sz pos width < Int.zwordsize + /\ 0 <= Int.zwordsize - first_bit sz pos width - width < Int.zwordsize. +Proof. + intros. + assert (bitsize_carrier sz <= Int.zwordsize) by (destruct sz; compute; congruence). + unfold first_bit; destruct Archi.big_endian; lia. +Qed. + Lemma make_load_correct: - forall addr ty code b ofs v e le m, - make_load addr ty = OK code -> + forall addr ty bf code b ofs v e le m, + make_load addr ty bf = OK code -> eval_expr ge e le m addr (Vptr b ofs) -> - deref_loc ty m b ofs v -> + deref_loc ty m b ofs bf v -> eval_expr ge e le m code v. Proof. unfold make_load; intros until m; intros MKLOAD EVEXP DEREF. inv DEREF. - (* scalar *) +- (* scalar *) rewrite H in MKLOAD. inv MKLOAD. apply eval_Eload with (Vptr b ofs); auto. - (* by reference *) +- (* by reference *) rewrite H in MKLOAD. inv MKLOAD. auto. - (* by copy *) +- (* by copy *) rewrite H in MKLOAD. inv MKLOAD. auto. +- (* by bitfield *) + inv H. + unfold make_extract_bitfield in MKLOAD. unfold bitfield_extract. + exploit (first_bit_range sz pos width); eauto. lia. intros [A1 A2]. + set (amount1 := Int.repr (Int.zwordsize - first_bit sz pos width - width)) in MKLOAD. + set (amount2 := Int.repr (Int.zwordsize - width)) in MKLOAD. + destruct (zle 0 pos && zlt 0 width && zle (pos + width) (bitsize_carrier sz)); inv MKLOAD. + set (e1 := Eload (chunk_for_carrier sz) addr). + assert (E1: eval_expr ge e le m e1 (Vint c)) by (econstructor; eauto). + set (e2 := Ebinop Oshl e1 (make_intconst amount1)). + assert (E2: eval_expr ge e le m e2 (Vint (Int.shl c amount1))). + { econstructor; eauto using make_intconst_correct. cbn. + unfold amount1 at 1; rewrite int_ltu_true by lia. auto. } + econstructor; eauto using make_intconst_correct. + destruct (Ctypes.intsize_eq sz IBool || Ctypes.signedness_eq sg Unsigned); cbn. + + unfold amount2 at 1; rewrite int_ltu_true by lia. + rewrite Int.unsigned_bitfield_extract_by_shifts by lia. auto. + + unfold amount2 at 1; rewrite int_ltu_true by lia. + rewrite Int.signed_bitfield_extract_by_shifts by lia. auto. +Qed. + +Lemma make_store_bitfield_correct: + forall f sz sg pos width dst src ty k e le m b ofs v m' s, + eval_expr ge e le m dst (Vptr b ofs) -> + eval_expr ge e le m src v -> + assign_loc prog.(prog_comp_env) ty m b ofs (Bits sz sg pos width) v m' -> + make_store_bitfield sz sg pos width dst src = OK s -> + step ge (State f s k e le m) E0 (State f Sskip k e le m'). +Proof. + intros until s; intros DST SRC ASG MK. + inv ASG. inv H5. unfold make_store_bitfield in MK. + destruct (zle 0 pos && zlt 0 width && zle (pos + width) (bitsize_carrier sz)); inv MK. + econstructor; eauto. + exploit (first_bit_range sz pos width); eauto. lia. intros [A1 A2]. + rewrite Int.bitfield_insert_alternative by lia. + set (amount := first_bit sz pos width). + set (mask := Int.shl (Int.repr (two_p width - 1)) (Int.repr amount)). + repeat econstructor; eauto. cbn. rewrite int_ltu_true by lia. auto. Qed. Lemma make_memcpy_correct: forall f dst src ty k e le m b ofs v m' s, eval_expr ge e le m dst (Vptr b ofs) -> eval_expr ge e le m src v -> - assign_loc prog.(prog_comp_env) ty m b ofs v m' -> + assign_loc prog.(prog_comp_env) ty m b ofs Full v m' -> access_mode ty = By_copy -> make_memcpy cunit.(prog_comp_env) dst src ty = OK s -> step ge (State f s k e le m) E0 (State f Sskip k e le m'). @@ -979,21 +1022,23 @@ Proof. Qed. Lemma make_store_correct: - forall addr ty rhs code e le m b ofs v m' f k, - make_store cunit.(prog_comp_env) addr ty rhs = OK code -> + forall addr ty bf rhs code e le m b ofs v m' f k, + make_store cunit.(prog_comp_env) addr ty bf rhs = OK code -> eval_expr ge e le m addr (Vptr b ofs) -> eval_expr ge e le m rhs v -> - assign_loc prog.(prog_comp_env) ty m b ofs v m' -> + assign_loc prog.(prog_comp_env) ty m b ofs bf v m' -> step ge (State f code k e le m) E0 (State f Sskip k e le m'). Proof. unfold make_store. intros until k; intros MKSTORE EV1 EV2 ASSIGN. inversion ASSIGN; subst. - (* nonvolatile scalar *) +- (* nonvolatile scalar *) rewrite H in MKSTORE; inv MKSTORE. econstructor; eauto. - (* by copy *) +- (* by copy *) rewrite H in MKSTORE. eapply make_memcpy_correct with (b := b) (v := Vptr b' ofs'); eauto. +- (* bitfield *) + eapply make_store_bitfield_correct; eauto. Qed. Lemma make_normalization_correct: @@ -1212,15 +1257,51 @@ Variable m: mem. Variable te: Csharpminor.env. Hypothesis MENV: match_env e te. +Lemma transl_expr_lvalue: + forall a loc ofs bf ta, + Clight.eval_lvalue ge e le m a loc ofs bf -> + transl_expr cunit.(prog_comp_env) a = OK ta -> + exists tb, transl_lvalue cunit.(prog_comp_env) a = OK (tb, bf) + /\ make_load tb (typeof a) bf = OK ta. +Proof. + intros until ta; intros EVAL TR. inv EVAL; simpl in TR. +- (* var local *) + exists (Eaddrof id); auto. +- (* var global *) + exists (Eaddrof id); auto. +- (* deref *) + monadInv TR. cbn; rewrite EQ. exists x; auto. +- (* field struct *) + monadInv TR. + assert (x1 = bf). + { rewrite H0 in EQ1. unfold make_field_access in EQ1. + destruct ((prog_comp_env cunit)!id) as [co'|] eqn:E; try discriminate. + monadInv EQ1. + exploit field_offset_stable. eexact LINK. eauto. instantiate (1 := i). intros [A B]. + simpl in H1, H2. congruence. } + subst x1. + exists x0; split; auto. simpl; rewrite EQ; auto. +- (* field union *) + monadInv TR. + assert (x1 = bf). + { rewrite H0 in EQ1. unfold make_field_access in EQ1. + destruct ((prog_comp_env cunit)!id) as [co'|] eqn:E; try discriminate. + monadInv EQ1. + exploit union_field_offset_stable. eexact LINK. eauto. instantiate (1 := i). intros [A B]. + simpl in H1, H2. congruence. } + subst x1. + exists x0; split; auto. simpl; rewrite EQ; auto. +Qed. + Lemma transl_expr_lvalue_correct: (forall a v, Clight.eval_expr ge e le m a v -> forall ta (TR: transl_expr cunit.(prog_comp_env) a = OK ta) , Csharpminor.eval_expr tge te le m ta v) -/\(forall a b ofs, - Clight.eval_lvalue ge e le m a b ofs -> - forall ta (TR: transl_lvalue cunit.(prog_comp_env) a = OK ta), - Csharpminor.eval_expr tge te le m ta (Vptr b ofs)). +/\(forall a b ofs bf, + Clight.eval_lvalue ge e le m a b ofs bf -> + forall ta bf' (TR: transl_lvalue cunit.(prog_comp_env) a = OK (ta, bf')), + bf = bf' /\ Csharpminor.eval_expr tge te le m ta (Vptr b ofs)). Proof. apply eval_expr_lvalue_ind; intros; try (monadInv TR). - (* const int *) @@ -1234,7 +1315,7 @@ Proof. - (* temp var *) constructor; auto. - (* addrof *) - simpl in TR. auto. + destruct x0; inv EQ0. apply H0 in EQ. destruct EQ. auto. - (* unop *) eapply transl_unop_correct; eauto. - (* binop *) @@ -1247,31 +1328,43 @@ Proof. rewrite (transl_alignof _ _ _ _ LINK EQ). apply make_ptrofsconst_correct. - (* rvalue out of lvalue *) exploit transl_expr_lvalue; eauto. intros [tb [TRLVAL MKLOAD]]. + apply H0 in TRLVAL; destruct TRLVAL. eapply make_load_correct; eauto. - (* var local *) exploit (me_local _ _ MENV); eauto. intros EQ. - econstructor. eapply eval_var_addr_local. eauto. + split; auto. econstructor. eapply eval_var_addr_local. eauto. - (* var global *) - econstructor. eapply eval_var_addr_global. + split; auto. econstructor. eapply eval_var_addr_global. eapply match_env_globals; eauto. rewrite symbols_preserved. auto. - (* deref *) - simpl in TR. eauto. + eauto. - (* field struct *) unfold make_field_access in EQ0. rewrite H1 in EQ0. - destruct (prog_comp_env cunit)!id as [co'|] eqn:CO; monadInv EQ0. + destruct (prog_comp_env cunit)!id as [co'|] eqn:CO; try discriminate; monadInv EQ0. exploit field_offset_stable. eexact LINK. eauto. instantiate (1 := i). intros [A B]. - rewrite <- B in EQ1. + rewrite <- B in EQ1. assert (x0 = delta) by (unfold ge in *; simpl in *; congruence). - subst x0. + assert (bf' = bf) by (unfold ge in *; simpl in *; congruence). + subst x0 bf'. split; auto. destruct Archi.ptr64 eqn:SF. + eapply eval_Ebinop; eauto using make_longconst_correct. simpl. rewrite SF. apply f_equal. apply f_equal. apply f_equal. auto with ptrofs. + eapply eval_Ebinop; eauto using make_intconst_correct. simpl. rewrite SF. apply f_equal. apply f_equal. apply f_equal. auto with ptrofs. - (* field union *) - unfold make_field_access in EQ0; rewrite H1 in EQ0; monadInv EQ0. - auto. + unfold make_field_access in EQ0. rewrite H1 in EQ0. + destruct (prog_comp_env cunit)!id as [co'|] eqn:CO; try discriminate; monadInv EQ0. + exploit union_field_offset_stable. eexact LINK. eauto. instantiate (1 := i). intros [A B]. + rewrite <- B in EQ1. + assert (x0 = delta) by (unfold ge in *; simpl in *; congruence). + assert (bf' = bf) by (unfold ge in *; simpl in *; congruence). + subst x0 bf'. split; auto. + destruct Archi.ptr64 eqn:SF. ++ eapply eval_Ebinop; eauto using make_longconst_correct. + simpl. rewrite SF. apply f_equal. apply f_equal. apply f_equal. auto with ptrofs. ++ eapply eval_Ebinop; eauto using make_intconst_correct. + simpl. rewrite SF. apply f_equal. apply f_equal. apply f_equal. auto with ptrofs. Qed. Lemma transl_expr_correct: @@ -1282,10 +1375,10 @@ Lemma transl_expr_correct: Proof (proj1 transl_expr_lvalue_correct). Lemma transl_lvalue_correct: - forall a b ofs, - Clight.eval_lvalue ge e le m a b ofs -> - forall ta, transl_lvalue cunit.(prog_comp_env) a = OK ta -> - Csharpminor.eval_expr tge te le m ta (Vptr b ofs). + forall a b ofs bf, + Clight.eval_lvalue ge e le m a b ofs bf -> + forall ta bf', transl_lvalue cunit.(prog_comp_env) a = OK (ta, bf') -> + bf = bf' /\ Csharpminor.eval_expr tge te le m ta (Vptr b ofs). Proof (proj2 transl_expr_lvalue_correct). Lemma transl_arglist_correct: @@ -1468,7 +1561,11 @@ Proof. auto. - (* assign *) unfold make_store, make_memcpy in EQ3. + destruct x0. destruct (access_mode (typeof e)); monadInv EQ3; auto. + unfold make_store_bitfield in EQ3. + destruct (zle 0 pos && zlt 0 width && zle (pos + width) (bitsize_carrier sz)); + monadInv EQ3; auto. - (* set *) auto. - (* call *) @@ -1568,11 +1665,17 @@ Proof. assert (SAME: ts' = ts /\ tk' = tk). { inversion MTR. auto. subst ts. unfold make_store, make_memcpy in EQ3. - destruct (access_mode (typeof a1)); monadInv EQ3; auto. } + destruct x0. + destruct (access_mode (typeof a1)); monadInv EQ3; auto. + unfold make_store_bitfield in EQ3. + destruct (zle 0 pos && zlt 0 width && zle (pos + width) (bitsize_carrier sz)); + monadInv EQ3; auto. + } destruct SAME; subst ts' tk'. + exploit transl_lvalue_correct; eauto. intros [A B]; subst x0. econstructor; split. apply plus_one. eapply make_store_correct; eauto. - eapply transl_lvalue_correct; eauto. eapply make_cast_correct; eauto. + eapply make_cast_correct; eauto. eapply transl_expr_correct; eauto. eapply match_states_skip; eauto. diff --git a/cfrontend/Cstrategy.v b/cfrontend/Cstrategy.v index c235031f..ce965672 100644 --- a/cfrontend/Cstrategy.v +++ b/cfrontend/Cstrategy.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -48,7 +49,7 @@ Variable ge: genv. Fixpoint simple (a: expr) : bool := match a with - | Eloc _ _ _ => true + | Eloc _ _ _ _ => true | Evar _ _ => true | Ederef r _ => simple r | Efield r _ _ => simple r @@ -85,41 +86,42 @@ Section SIMPLE_EXPRS. Variable e: env. Variable m: mem. -Inductive eval_simple_lvalue: expr -> block -> ptrofs -> Prop := - | esl_loc: forall b ofs ty, - eval_simple_lvalue (Eloc b ofs ty) b ofs +Inductive eval_simple_lvalue: expr -> block -> ptrofs -> bitfield -> Prop := + | esl_loc: forall b ofs ty bf, + eval_simple_lvalue (Eloc b ofs bf ty) b ofs bf | esl_var_local: forall x ty b, e!x = Some(b, ty) -> - eval_simple_lvalue (Evar x ty) b Ptrofs.zero + eval_simple_lvalue (Evar x ty) b Ptrofs.zero Full | esl_var_global: forall x ty b, e!x = None -> Genv.find_symbol ge x = Some b -> - eval_simple_lvalue (Evar x ty) b Ptrofs.zero + eval_simple_lvalue (Evar x ty) b Ptrofs.zero Full | esl_deref: forall r ty b ofs, eval_simple_rvalue r (Vptr b ofs) -> - eval_simple_lvalue (Ederef r ty) b ofs - | esl_field_struct: forall r f ty b ofs id co a delta, + eval_simple_lvalue (Ederef r ty) b ofs Full + | esl_field_struct: forall r f ty b ofs id co a delta bf, eval_simple_rvalue r (Vptr b ofs) -> typeof r = Tstruct id a -> ge.(genv_cenv)!id = Some co -> - field_offset ge f (co_members co) = OK delta -> - eval_simple_lvalue (Efield r f ty) b (Ptrofs.add ofs (Ptrofs.repr delta)) - | esl_field_union: forall r f ty b ofs id co a, + field_offset ge f (co_members co) = OK (delta, bf) -> + eval_simple_lvalue (Efield r f ty) b (Ptrofs.add ofs (Ptrofs.repr delta)) bf + | esl_field_union: forall r f ty b ofs id co a delta bf, eval_simple_rvalue r (Vptr b ofs) -> typeof r = Tunion id a -> + union_field_offset ge f (co_members co) = OK (delta, bf) -> ge.(genv_cenv)!id = Some co -> - eval_simple_lvalue (Efield r f ty) b ofs + eval_simple_lvalue (Efield r f ty) b (Ptrofs.add ofs (Ptrofs.repr delta)) bf with eval_simple_rvalue: expr -> val -> Prop := | esr_val: forall v ty, eval_simple_rvalue (Eval v ty) v - | esr_rvalof: forall b ofs l ty v, - eval_simple_lvalue l b ofs -> + | esr_rvalof: forall b ofs bf l ty v, + eval_simple_lvalue l b ofs bf -> ty = typeof l -> type_is_volatile ty = false -> - deref_loc ge ty m b ofs E0 v -> + deref_loc ge ty m b ofs bf E0 v -> eval_simple_rvalue (Evalof l ty) v | esr_addrof: forall b ofs l ty, - eval_simple_lvalue l b ofs -> + eval_simple_lvalue l b ofs Full -> eval_simple_rvalue (Eaddrof l ty) (Vptr b ofs) | esr_unop: forall op r1 ty v1 v, eval_simple_rvalue r1 v1 -> @@ -239,10 +241,10 @@ Inductive estep: state -> trace -> state -> Prop := estep (ExprState f r k e m) E0 (ExprState f (Eval v ty) k e m) - | step_rvalof_volatile: forall f C l ty k e m b ofs t v, + | step_rvalof_volatile: forall f C l ty k e m b ofs bf t v, leftcontext RV RV C -> - eval_simple_lvalue e m l b ofs -> - deref_loc ge ty m b ofs t v -> + eval_simple_lvalue e m l b ofs bf -> + deref_loc ge ty m b ofs bf t v -> ty = typeof l -> type_is_volatile ty = true -> estep (ExprState f (C (Evalof l ty)) k e m) t (ExprState f (C (Eval v ty)) k e m) @@ -280,68 +282,68 @@ Inductive estep: state -> trace -> state -> Prop := estep (ExprState f (C (Econdition r1 r2 r3 ty)) k e m) E0 (ExprState f (C (Eparen (if b then r2 else r3) ty ty)) k e m) - | step_assign: forall f C l r ty k e m b ofs v v' t m', + | step_assign: forall f C l r ty k e m b ofs bf v v1 t m' v', leftcontext RV RV C -> - eval_simple_lvalue e m l b ofs -> + eval_simple_lvalue e m l b ofs bf -> eval_simple_rvalue e m r v -> - sem_cast v (typeof r) (typeof l) m = Some v' -> - assign_loc ge (typeof l) m b ofs v' t m' -> + sem_cast v (typeof r) (typeof l) m = Some v1 -> + assign_loc ge (typeof l) m b ofs bf v1 t m' v' -> ty = typeof l -> estep (ExprState f (C (Eassign l r ty)) k e m) t (ExprState f (C (Eval v' ty)) k e m') - | step_assignop: forall f C op l r tyres ty k e m b ofs v1 v2 v3 v4 t1 t2 m' t, + | step_assignop: forall f C op l r tyres ty k e m b ofs bf v1 v2 v3 v4 t1 t2 m' v' t, leftcontext RV RV C -> - eval_simple_lvalue e m l b ofs -> - deref_loc ge (typeof l) m b ofs t1 v1 -> + eval_simple_lvalue e m l b ofs bf -> + deref_loc ge (typeof l) m b ofs bf t1 v1 -> eval_simple_rvalue e m r v2 -> sem_binary_operation ge op v1 (typeof l) v2 (typeof r) m = Some v3 -> sem_cast v3 tyres (typeof l) m = Some v4 -> - assign_loc ge (typeof l) m b ofs v4 t2 m' -> + assign_loc ge (typeof l) m b ofs bf v4 t2 m' v' -> ty = typeof l -> t = t1 ** t2 -> estep (ExprState f (C (Eassignop op l r tyres ty)) k e m) - t (ExprState f (C (Eval v4 ty)) k e m') + t (ExprState f (C (Eval v' ty)) k e m') - | step_assignop_stuck: forall f C op l r tyres ty k e m b ofs v1 v2 t, + | step_assignop_stuck: forall f C op l r tyres ty k e m b ofs bf v1 v2 t, leftcontext RV RV C -> - eval_simple_lvalue e m l b ofs -> - deref_loc ge (typeof l) m b ofs t v1 -> + eval_simple_lvalue e m l b ofs bf -> + deref_loc ge (typeof l) m b ofs bf t v1 -> eval_simple_rvalue e m r v2 -> match sem_binary_operation ge op v1 (typeof l) v2 (typeof r) m with | None => True | Some v3 => match sem_cast v3 tyres (typeof l) m with | None => True - | Some v4 => forall t2 m', ~(assign_loc ge (typeof l) m b ofs v4 t2 m') + | Some v4 => forall t2 m' v', ~(assign_loc ge (typeof l) m b ofs bf v4 t2 m' v') end end -> ty = typeof l -> estep (ExprState f (C (Eassignop op l r tyres ty)) k e m) t Stuckstate - | step_postincr: forall f C id l ty k e m b ofs v1 v2 v3 t1 t2 m' t, + | step_postincr: forall f C id l ty k e m b ofs bf v1 v2 v3 t1 t2 m' v' t, leftcontext RV RV C -> - eval_simple_lvalue e m l b ofs -> - deref_loc ge ty m b ofs t1 v1 -> + eval_simple_lvalue e m l b ofs bf -> + deref_loc ge ty m b ofs bf t1 v1 -> sem_incrdecr ge id v1 ty m = Some v2 -> sem_cast v2 (incrdecr_type ty) ty m = Some v3 -> - assign_loc ge ty m b ofs v3 t2 m' -> + assign_loc ge ty m b ofs bf v3 t2 m' v' -> ty = typeof l -> t = t1 ** t2 -> estep (ExprState f (C (Epostincr id l ty)) k e m) t (ExprState f (C (Eval v1 ty)) k e m') - | step_postincr_stuck: forall f C id l ty k e m b ofs v1 t, + | step_postincr_stuck: forall f C id l ty k e m b ofs bf v1 t, leftcontext RV RV C -> - eval_simple_lvalue e m l b ofs -> - deref_loc ge ty m b ofs t v1 -> + eval_simple_lvalue e m l b ofs bf -> + deref_loc ge ty m b ofs bf t v1 -> match sem_incrdecr ge id v1 ty m with | None => True | Some v2 => match sem_cast v2 (incrdecr_type ty) ty m with | None => True - | Some v3 => forall t2 m', ~(assign_loc ge (typeof l) m b ofs v3 t2 m') + | Some v3 => forall t2 m' v', ~(assign_loc ge (typeof l) m b ofs bf v3 t2 m' v') end end -> ty = typeof l -> @@ -451,7 +453,7 @@ Qed. Definition expr_kind (a: expr) : kind := match a with - | Eloc _ _ _ => LV + | Eloc _ _ _ _ => LV | Evar _ _ => LV | Ederef _ _ => LV | Efield _ _ _ => LV @@ -517,23 +519,25 @@ Fixpoint exprlist_all_values (rl: exprlist) : Prop := Definition invert_expr_prop (a: expr) (m: mem) : Prop := match a with - | Eloc b ofs ty => False + | Eloc b ofs bf ty => False | Evar x ty => exists b, e!x = Some(b, ty) \/ (e!x = None /\ Genv.find_symbol ge x = Some b) | Ederef (Eval v ty1) ty => exists b, exists ofs, v = Vptr b ofs + | Eaddrof (Eloc b ofs bf ty) ty' => + bf = Full | Efield (Eval v ty1) f ty => exists b, exists ofs, v = Vptr b ofs /\ match ty1 with - | Tstruct id _ => exists co delta, ge.(genv_cenv)!id = Some co /\ field_offset ge f (co_members co) = Errors.OK delta - | Tunion id _ => exists co, ge.(genv_cenv)!id = Some co + | Tstruct id _ => exists co delta bf, ge.(genv_cenv)!id = Some co /\ field_offset ge f (co_members co) = Errors.OK (delta, bf) + | Tunion id _ => exists co delta bf, ge.(genv_cenv)!id = Some co /\ union_field_offset ge f (co_members co) = Errors.OK (delta, bf) | _ => False end | Eval v ty => False - | Evalof (Eloc b ofs ty') ty => - ty' = ty /\ exists t, exists v, deref_loc ge ty m b ofs t v + | Evalof (Eloc b ofs bf ty') ty => + ty' = ty /\ exists t, exists v, deref_loc ge ty m b ofs bf t v | Eunop op (Eval v1 ty1) ty => exists v, sem_unary_operation op v1 ty1 m = Some v | Ebinop op (Eval v1 ty1) (Eval v2 ty2) ty => @@ -546,17 +550,17 @@ Definition invert_expr_prop (a: expr) (m: mem) : Prop := exists b, bool_val v1 ty1 m = Some b | Econdition (Eval v1 ty1) r1 r2 ty => exists b, bool_val v1 ty1 m = Some b - | Eassign (Eloc b ofs ty1) (Eval v2 ty2) ty => - exists v, exists m', exists t, - ty = ty1 /\ sem_cast v2 ty2 ty1 m = Some v /\ assign_loc ge ty1 m b ofs v t m' - | Eassignop op (Eloc b ofs ty1) (Eval v2 ty2) tyres ty => - exists t, exists v1, + | Eassign (Eloc b ofs bf ty1) (Eval v2 ty2) ty => + exists v m' v' t, + ty = ty1 /\ sem_cast v2 ty2 ty1 m = Some v /\ assign_loc ge ty1 m b ofs bf v t m' v' + | Eassignop op (Eloc b ofs bf ty1) (Eval v2 ty2) tyres ty => + exists t v1, ty = ty1 - /\ deref_loc ge ty1 m b ofs t v1 - | Epostincr id (Eloc b ofs ty1) ty => - exists t, exists v1, + /\ deref_loc ge ty1 m b ofs bf t v1 + | Epostincr id (Eloc b ofs bf ty1) ty => + exists t v1, ty = ty1 - /\ deref_loc ge ty m b ofs t v1 + /\ deref_loc ge ty m b ofs bf t v1 | Ecomma (Eval v ty1) r2 ty => typeof r2 = ty | Eparen (Eval v1 ty1) ty2 ty => @@ -583,8 +587,8 @@ Proof. exists b; auto. exists b; auto. exists b; exists ofs; auto. - exists b; exists ofs; split; auto. exists co, delta; auto. - exists b; exists ofs; split; auto. exists co; auto. + exists b; exists ofs; split; auto. exists co, delta, bf; auto. + exists b; exists ofs; split; auto. exists co, delta, bf; auto. Qed. Lemma rred_invert: @@ -598,7 +602,7 @@ Proof. exists true; auto. exists false; auto. exists true; auto. exists false; auto. exists b; auto. - exists v; exists m'; exists t; auto. + exists v; exists m'; exists v'; exists t; auto. exists t; exists v1; auto. exists t; exists v1; auto. exists v; auto. @@ -633,7 +637,7 @@ Proof. destruct (C a); auto; contradiction. destruct (C a); auto; contradiction. destruct (C a); auto; contradiction. - auto. + destruct (C a); auto; contradiction. destruct (C a); auto; contradiction. destruct (C a); auto; contradiction. destruct e1; auto; destruct (C a); auto; contradiction. @@ -659,7 +663,7 @@ Lemma imm_safe_inv: forall k a m, imm_safe ge e k a m -> match a with - | Eloc _ _ _ => True + | Eloc _ _ _ _ => True | Eval _ _ => True | _ => invert_expr_prop a m end. @@ -684,7 +688,7 @@ Lemma safe_inv: safe (ExprState f (C a) K e m) -> context k RV C -> match a with - | Eloc _ _ _ => True + | Eloc _ _ _ _ => True | Eval _ _ => True | _ => invert_expr_prop a m end. @@ -708,10 +712,10 @@ Lemma eval_simple_steps: forall C, context RV RV C -> star Csem.step ge (ExprState f (C a) k e m) E0 (ExprState f (C (Eval v (typeof a))) k e m)) -/\ (forall a b ofs, eval_simple_lvalue e m a b ofs -> +/\ (forall a b ofs bf, eval_simple_lvalue e m a b ofs bf -> forall C, context LV RV C -> star Csem.step ge (ExprState f (C a) k e m) - E0 (ExprState f (C (Eloc b ofs (typeof a))) k e m)). + E0 (ExprState f (C (Eloc b ofs bf (typeof a))) k e m)). Proof. Ltac Steps REC C' := eapply star_trans; [apply (REC C'); eauto | idtac | simpl; reflexivity]. @@ -759,10 +763,10 @@ Lemma eval_simple_rvalue_steps: Proof (proj1 eval_simple_steps). Lemma eval_simple_lvalue_steps: - forall a b ofs, eval_simple_lvalue e m a b ofs -> + forall a b ofs bf, eval_simple_lvalue e m a b ofs bf -> forall C, context LV RV C -> star Csem.step ge (ExprState f (C a) k e m) - E0 (ExprState f (C (Eloc b ofs (typeof a))) k e m). + E0 (ExprState f (C (Eloc b ofs bf (typeof a))) k e m). Proof (proj2 eval_simple_steps). Corollary eval_simple_rvalue_safe: @@ -775,10 +779,10 @@ Proof. Qed. Corollary eval_simple_lvalue_safe: - forall C a b ofs, - eval_simple_lvalue e m a b ofs -> + forall C a b ofs bf, + eval_simple_lvalue e m a b ofs bf -> context LV RV C -> safe (ExprState f (C a) k e m) -> - safe (ExprState f (C (Eloc b ofs (typeof a))) k e m). + safe (ExprState f (C (Eloc b ofs bf (typeof a))) k e m). Proof. intros. eapply safe_steps; eauto. eapply eval_simple_lvalue_steps; eauto. Qed. @@ -787,15 +791,15 @@ Lemma simple_can_eval: forall a from C, simple a = true -> context from RV C -> safe (ExprState f (C a) k e m) -> match from with - | LV => exists b, exists ofs, eval_simple_lvalue e m a b ofs + | LV => exists b ofs bf, eval_simple_lvalue e m a b ofs bf | RV => exists v, eval_simple_rvalue e m a v end. Proof. Ltac StepL REC C' a := - let b := fresh "b" in let ofs := fresh "ofs" in + let b := fresh "b" in let ofs := fresh "ofs" in let bf := fresh "bf" in let E := fresh "E" in let S := fresh "SAFE" in - exploit (REC LV C'); eauto; intros [b [ofs E]]; - assert (S: safe (ExprState f (C' (Eloc b ofs (typeof a))) k e m)) by + exploit (REC LV C'); eauto; intros (b & ofs & bf & E); + assert (S: safe (ExprState f (C' (Eloc b ofs bf (typeof a))) k e m)) by (eapply (eval_simple_lvalue_safe C'); eauto); simpl in S. Ltac StepR REC C' a := @@ -808,51 +812,52 @@ Ltac StepR REC C' a := induction a; intros from C S CTX SAFE; generalize (safe_expr_kind _ _ _ _ _ _ _ CTX SAFE); intro K; subst; simpl in S; try discriminate; simpl. -(* val *) +- (* val *) exists v; constructor. -(* var *) +- (* var *) exploit safe_inv; eauto; simpl. intros [b A]. - exists b; exists Ptrofs.zero. + exists b, Ptrofs.zero, Full. intuition. apply esl_var_local; auto. apply esl_var_global; auto. -(* field *) +- (* field *) StepR IHa (fun x => C(Efield x f0 ty)) a. exploit safe_inv. eexact SAFE0. eauto. simpl. intros [b [ofs [EQ TY]]]. subst v. destruct (typeof a) eqn:?; try contradiction. - destruct TY as (co & delta & CE & OFS). exists b; exists (Ptrofs.add ofs (Ptrofs.repr delta)); econstructor; eauto. - destruct TY as (co & CE). exists b; exists ofs; econstructor; eauto. -(* valof *) + destruct TY as (co & delta & bf & CE & OFS). exists b, (Ptrofs.add ofs (Ptrofs.repr delta)), bf; eapply esl_field_struct; eauto. + destruct TY as (co & delta & bf & CE & OFS). exists b, (Ptrofs.add ofs (Ptrofs.repr delta)), bf; eapply esl_field_union; eauto. +- (* valof *) destruct (andb_prop _ _ S) as [S1 S2]. clear S. rewrite negb_true_iff in S2. StepL IHa (fun x => C(Evalof x ty)) a. exploit safe_inv. eexact SAFE0. eauto. simpl. intros [TY [t [v LOAD]]]. assert (t = E0). inv LOAD; auto. congruence. subst t. exists v; econstructor; eauto. congruence. -(* deref *) +- (* deref *) StepR IHa (fun x => C(Ederef x ty)) a. exploit safe_inv. eexact SAFE0. eauto. simpl. intros [b [ofs EQ]]. - subst v. exists b; exists ofs; econstructor; eauto. -(* addrof *) + subst v. exists b, ofs, Full; econstructor; eauto. +- (* addrof *) StepL IHa (fun x => C(Eaddrof x ty)) a. + exploit safe_inv. eexact SAFE0. eauto. simpl. intros EQ; subst bf. exists (Vptr b ofs); econstructor; eauto. -(* unop *) +- (* unop *) StepR IHa (fun x => C(Eunop op x ty)) a. exploit safe_inv. eexact SAFE0. eauto. simpl. intros [v' EQ]. exists v'; econstructor; eauto. -(* binop *) +- (* binop *) destruct (andb_prop _ _ S) as [S1 S2]; clear S. StepR IHa1 (fun x => C(Ebinop op x a2 ty)) a1. StepR IHa2 (fun x => C(Ebinop op (Eval v (typeof a1)) x ty)) a2. exploit safe_inv. eexact SAFE1. eauto. simpl. intros [v' EQ]. exists v'; econstructor; eauto. -(* cast *) +- (* cast *) StepR IHa (fun x => C(Ecast x ty)) a. exploit safe_inv. eexact SAFE0. eauto. simpl. intros [v' CAST]. exists v'; econstructor; eauto. -(* sizeof *) +- (* sizeof *) econstructor; econstructor. -(* alignof *) +- (* alignof *) econstructor; econstructor. -(* loc *) - exists b; exists ofs; constructor. +- (* loc *) + exists b, ofs, bf; constructor. Qed. Lemma simple_can_eval_rval: @@ -868,11 +873,11 @@ Qed. Lemma simple_can_eval_lval: forall l C, simple l = true -> context LV RV C -> safe (ExprState f (C l) k e m) -> - exists b, exists ofs, eval_simple_lvalue e m l b ofs - /\ safe (ExprState f (C (Eloc b ofs (typeof l))) k e m). + exists b ofs bf, eval_simple_lvalue e m l b ofs bf + /\ safe (ExprState f (C (Eloc b ofs bf (typeof l))) k e m). Proof. - intros. exploit (simple_can_eval l LV); eauto. intros [b [ofs A]]. - exists b; exists ofs; split; auto. eapply eval_simple_lvalue_safe; eauto. + intros. exploit (simple_can_eval l LV); eauto. intros (b & ofs & bf & A). + exists b, ofs, bf; split; auto. eapply eval_simple_lvalue_safe; eauto. Qed. Fixpoint rval_list (vl: list val) (rl: exprlist) : exprlist := @@ -1177,18 +1182,18 @@ Proof. eapply star_plus_trans. eapply eval_simple_lvalue_steps with (C := fun x => C(Eassign x r (typeof l))); eauto. eapply plus_right. - eapply eval_simple_rvalue_steps with (C := fun x => C(Eassign (Eloc b ofs (typeof l)) x (typeof l))); eauto. + eapply eval_simple_rvalue_steps with (C := fun x => C(Eassign (Eloc b ofs bf (typeof l)) x (typeof l))); eauto. left; apply step_rred; eauto. econstructor; eauto. reflexivity. auto. (* assignop *) eapply star_plus_trans. eapply eval_simple_lvalue_steps with (C := fun x => C(Eassignop op x r tyres (typeof l))); eauto. eapply star_plus_trans. - eapply eval_simple_rvalue_steps with (C := fun x => C(Eassignop op (Eloc b ofs (typeof l)) x tyres (typeof l))); eauto. + eapply eval_simple_rvalue_steps with (C := fun x => C(Eassignop op (Eloc b ofs bf (typeof l)) x tyres (typeof l))); eauto. eapply plus_left. left; apply step_rred; auto. econstructor; eauto. eapply star_left. - left; apply step_rred with (C := fun x => C(Eassign (Eloc b ofs (typeof l)) x (typeof l))); eauto. econstructor; eauto. + left; apply step_rred with (C := fun x => C(Eassign (Eloc b ofs bf (typeof l)) x (typeof l))); eauto. econstructor; eauto. apply star_one. left; apply step_rred; auto. econstructor; eauto. reflexivity. reflexivity. reflexivity. traceEq. @@ -1196,19 +1201,19 @@ Proof. eapply star_plus_trans. eapply eval_simple_lvalue_steps with (C := fun x => C(Eassignop op x r tyres (typeof l))); eauto. eapply star_plus_trans. - eapply eval_simple_rvalue_steps with (C := fun x => C(Eassignop op (Eloc b ofs (typeof l)) x tyres (typeof l))); eauto. + eapply eval_simple_rvalue_steps with (C := fun x => C(Eassignop op (Eloc b ofs bf (typeof l)) x tyres (typeof l))); eauto. eapply plus_left. left; apply step_rred; auto. econstructor; eauto. destruct (sem_binary_operation ge op v1 (typeof l) v2 (typeof r) m) as [v3|] eqn:?. eapply star_left. - left; apply step_rred with (C := fun x => C(Eassign (Eloc b ofs (typeof l)) x (typeof l))); eauto. econstructor; eauto. + left; apply step_rred with (C := fun x => C(Eassign (Eloc b ofs bf (typeof l)) x (typeof l))); eauto. econstructor; eauto. apply star_one. left; eapply step_stuck; eauto. - red; intros. exploit imm_safe_inv; eauto. simpl. intros [v4' [m' [t' [A [B D]]]]]. + red; intros. exploit imm_safe_inv; eauto. simpl. intros [v4' [m' [v' [t' [A [B D]]]]]]. rewrite B in H4. eelim H4; eauto. reflexivity. apply star_one. - left; eapply step_stuck with (C := fun x => C(Eassign (Eloc b ofs (typeof l)) x (typeof l))); eauto. + left; eapply step_stuck with (C := fun x => C(Eassign (Eloc b ofs bf (typeof l)) x (typeof l))); eauto. red; intros. exploit imm_safe_inv; eauto. simpl. intros [v3 A]. congruence. reflexivity. reflexivity. traceEq. @@ -1218,7 +1223,7 @@ Proof. eapply plus_left. left; apply step_rred; auto. econstructor; eauto. eapply star_left. - left; apply step_rred with (C := fun x => C (Ecomma (Eassign (Eloc b ofs (typeof l)) x (typeof l)) (Eval v1 (typeof l)) (typeof l))); eauto. + left; apply step_rred with (C := fun x => C (Ecomma (Eassign (Eloc b ofs bf (typeof l)) x (typeof l)) (Eval v1 (typeof l)) (typeof l))); eauto. econstructor. instantiate (1 := v2). destruct id; assumption. eapply star_left. left; apply step_rred with (C := fun x => C (Ecomma x (Eval v1 (typeof l)) (typeof l))); eauto. @@ -1237,15 +1242,15 @@ Proof. destruct id; auto. destruct (sem_incrdecr ge id v1 (typeof l) m) as [v2|]. eapply star_left. - left; apply step_rred with (C := fun x => C (Ecomma (Eassign (Eloc b ofs (typeof l)) x (typeof l)) (Eval v1 (typeof l)) (typeof l))); eauto. + left; apply step_rred with (C := fun x => C (Ecomma (Eassign (Eloc b ofs bf (typeof l)) x (typeof l)) (Eval v1 (typeof l)) (typeof l))); eauto. econstructor; eauto. apply star_one. left; eapply step_stuck with (C := fun x => C (Ecomma x (Eval v1 (typeof l)) (typeof l))); eauto. - red; intros. exploit imm_safe_inv; eauto. simpl. intros [v3 [m' [t' [A [B D]]]]]. + red; intros. exploit imm_safe_inv; eauto. simpl. intros [v3 [m' [v' [t' [A [B D]]]]]]. rewrite B in H3. eelim H3; eauto. reflexivity. apply star_one. - left; eapply step_stuck with (C := fun x => C (Ecomma (Eassign (Eloc b ofs (typeof l)) x (typeof l)) (Eval v1 (typeof l)) (typeof l))); eauto. + left; eapply step_stuck with (C := fun x => C (Ecomma (Eassign (Eloc b ofs bf (typeof l)) x (typeof l)) (Eval v1 (typeof l)) (typeof l))); eauto. red; intros. exploit imm_safe_inv; eauto. simpl. intros [v2 A]. congruence. reflexivity. traceEq. @@ -1290,7 +1295,7 @@ Proof. (* valof volatile *) destruct Q. exploit (simple_can_eval_lval f k e m b (fun x => C(Evalof x ty))); eauto. - intros [b1 [ofs [E1 S1]]]. + intros (b1 & ofs & bf & E1 & S1). exploit safe_inv. eexact S1. eauto. simpl. intros [A [t [v B]]]. econstructor; econstructor; eapply step_rvalof_volatile; eauto. congruence. (* seqand *) @@ -1315,40 +1320,40 @@ Proof. (* assign *) destruct Q. exploit (simple_can_eval_lval f k e m b1 (fun x => C(Eassign x b2 ty))); eauto. - intros [b [ofs [E1 S1]]]. - exploit (simple_can_eval_rval f k e m b2 (fun x => C(Eassign (Eloc b ofs (typeof b1)) x ty))); eauto. + intros (b & ofs & bf & E1 & S1). + exploit (simple_can_eval_rval f k e m b2 (fun x => C(Eassign (Eloc b ofs bf (typeof b1)) x ty))); eauto. intros [v [E2 S2]]. - exploit safe_inv. eexact S2. eauto. simpl. intros [v' [m' [t [A [B D]]]]]. + exploit safe_inv. eexact S2. eauto. simpl. intros [v1 [m' [v' [t [A [B D]]]]]]. econstructor; econstructor; eapply step_assign; eauto. (* assignop *) destruct Q. exploit (simple_can_eval_lval f k e m b1 (fun x => C(Eassignop op x b2 tyres ty))); eauto. - intros [b [ofs [E1 S1]]]. - exploit (simple_can_eval_rval f k e m b2 (fun x => C(Eassignop op (Eloc b ofs (typeof b1)) x tyres ty))); eauto. + intros (b & ofs & bf & E1 & S1). + exploit (simple_can_eval_rval f k e m b2 (fun x => C(Eassignop op (Eloc b ofs bf (typeof b1)) x tyres ty))); eauto. intros [v [E2 S2]]. exploit safe_inv. eexact S2. eauto. simpl. intros [t1 [v1 [A B]]]. destruct (sem_binary_operation ge op v1 (typeof b1) v (typeof b2) m) as [v3|] eqn:?. destruct (sem_cast v3 tyres (typeof b1) m) as [v4|] eqn:?. - destruct (classic (exists t2, exists m', assign_loc ge (typeof b1) m b ofs v4 t2 m')). - destruct H2 as [t2 [m' D]]. + destruct (classic (exists t2 m' v', assign_loc ge (typeof b1) m b ofs bf v4 t2 m' v')). + destruct H2 as [t2 [m' [v' D]]]. econstructor; econstructor; eapply step_assignop; eauto. econstructor; econstructor; eapply step_assignop_stuck; eauto. - rewrite Heqo. rewrite Heqo0. intros; red; intros. elim H2. exists t2; exists m'; auto. + rewrite Heqo. rewrite Heqo0. intros; red; intros. elim H2. exists t2, m', v'; auto. econstructor; econstructor; eapply step_assignop_stuck; eauto. rewrite Heqo. rewrite Heqo0. auto. econstructor; econstructor; eapply step_assignop_stuck; eauto. rewrite Heqo. auto. (* postincr *) exploit (simple_can_eval_lval f k e m b (fun x => C(Epostincr id x ty))); eauto. - intros [b1 [ofs [E1 S1]]]. + intros (b1 & ofs & bf & E1 & S1). exploit safe_inv. eexact S1. eauto. simpl. intros [t [v1 [A B]]]. destruct (sem_incrdecr ge id v1 ty m) as [v2|] eqn:?. destruct (sem_cast v2 (incrdecr_type ty) ty m) as [v3|] eqn:?. - destruct (classic (exists t2, exists m', assign_loc ge ty m b1 ofs v3 t2 m')). - destruct H0 as [t2 [m' D]]. + destruct (classic (exists t2 m' v', assign_loc ge ty m b1 ofs bf v3 t2 m' v')). + destruct H0 as [t2 [m' [v' D]]]. econstructor; econstructor; eapply step_postincr; eauto. econstructor; econstructor; eapply step_postincr_stuck; eauto. - rewrite Heqo. rewrite Heqo0. intros; red; intros. elim H0. exists t2; exists m'; congruence. + rewrite Heqo. rewrite Heqo0. intros; red; intros. elim H0. exists t2, m', v'; congruence. econstructor; econstructor; eapply step_postincr_stuck; eauto. rewrite Heqo. rewrite Heqo0. auto. econstructor; econstructor; eapply step_postincr_stuck; eauto. @@ -1439,18 +1444,18 @@ Definition semantics (p: program) := (** This semantics is receptive to changes in events. *) Remark deref_loc_trace: - forall ge ty m b ofs t v, - deref_loc ge ty m b ofs t v -> + forall ge ty m b ofs bf t v, + deref_loc ge ty m b ofs bf t v -> match t with nil => True | ev :: nil => True | _ => False end. Proof. intros. inv H; simpl; auto. inv H2; simpl; auto. Qed. Remark deref_loc_receptive: - forall ge ty m b ofs ev1 t1 v ev2, - deref_loc ge ty m b ofs (ev1 :: t1) v -> + forall ge ty m b ofs bf ev1 t1 v ev2, + deref_loc ge ty m b ofs bf (ev1 :: t1) v -> match_traces ge (ev1 :: nil) (ev2 :: nil) -> - t1 = nil /\ exists v', deref_loc ge ty m b ofs (ev2 :: nil) v'. + t1 = nil /\ exists v', deref_loc ge ty m b ofs bf (ev2 :: nil) v'. Proof. intros. assert (t1 = nil). exploit deref_loc_trace; eauto. destruct t1; simpl; tauto. @@ -1459,16 +1464,16 @@ Proof. Qed. Remark assign_loc_trace: - forall ge ty m b ofs t v m', - assign_loc ge ty m b ofs v t m' -> + forall ge ty m b ofs bf t v m' v', + assign_loc ge ty m b ofs bf v t m' v' -> match t with nil => True | ev :: nil => output_event ev | _ => False end. Proof. intros. inv H; simpl; auto. inv H2; simpl; auto. Qed. Remark assign_loc_receptive: - forall ge ty m b ofs ev1 t1 v m' ev2, - assign_loc ge ty m b ofs v (ev1 :: t1) m' -> + forall ge ty m b ofs bf ev1 t1 v m' v' ev2, + assign_loc ge ty m b ofs bf v (ev1 :: t1) m' v' -> match_traces ge (ev1 :: nil) (ev2 :: nil) -> ev1 :: t1 = ev2 :: nil. Proof. @@ -1498,11 +1503,11 @@ Proof. inv H10. exploit deref_loc_receptive; eauto. intros [EQ [v1' A]]. subst t0. destruct (sem_binary_operation ge op v1' (typeof l) v2 (typeof r) m) as [v3'|] eqn:?. destruct (sem_cast v3' tyres (typeof l) m) as [v4'|] eqn:?. - destruct (classic (exists t2', exists m'', assign_loc ge (typeof l) m b ofs v4' t2' m'')). - destruct H1 as [t2' [m'' P]]. + destruct (classic (exists t2' m'' v'', assign_loc ge (typeof l) m b ofs bf v4' t2' m'' v'')). + destruct H1 as [t2' [m'' [v'' P]]]. econstructor; econstructor. left; eapply step_assignop with (v1 := v1'); eauto. simpl; reflexivity. econstructor; econstructor. left; eapply step_assignop_stuck with (v1 := v1'); eauto. - rewrite Heqo; rewrite Heqo0. intros; red; intros; elim H1. exists t0; exists m'0; auto. + rewrite Heqo; rewrite Heqo0. intros; red; intros; elim H1. exists t0, m'0, v'0; auto. econstructor; econstructor. left; eapply step_assignop_stuck with (v1 := v1'); eauto. rewrite Heqo; rewrite Heqo0; auto. econstructor; econstructor. left; eapply step_assignop_stuck with (v1 := v1'); eauto. @@ -1511,11 +1516,11 @@ Proof. exploit deref_loc_receptive; eauto. intros [EQ [v1' A]]. subst t1. destruct (sem_binary_operation ge op v1' (typeof l) v2 (typeof r) m) as [v3'|] eqn:?. destruct (sem_cast v3' tyres (typeof l) m) as [v4'|] eqn:?. - destruct (classic (exists t2', exists m'', assign_loc ge (typeof l) m b ofs v4' t2' m'')). - destruct H1 as [t2' [m'' P]]. + destruct (classic (exists t2' m'' v'', assign_loc ge (typeof l) m b ofs bf v4' t2' m'' v'')). + destruct H1 as [t2' [m'' [v'' P]]]. econstructor; econstructor. left; eapply step_assignop with (v1 := v1'); eauto. simpl; reflexivity. econstructor; econstructor. left; eapply step_assignop_stuck with (v1 := v1'); eauto. - rewrite Heqo; rewrite Heqo0. intros; red; intros; elim H1. exists t2; exists m'; auto. + rewrite Heqo; rewrite Heqo0. intros; red; intros; elim H1. exists t2, m', v'; auto. econstructor; econstructor. left; eapply step_assignop_stuck with (v1 := v1'); eauto. rewrite Heqo; rewrite Heqo0; auto. econstructor; econstructor. left; eapply step_assignop_stuck with (v1 := v1'); eauto. @@ -1527,11 +1532,11 @@ Proof. inv H9. exploit deref_loc_receptive; eauto. intros [EQ [v1' A]]. subst t0. destruct (sem_incrdecr ge id v1' (typeof l) m) as [v2'|] eqn:?. destruct (sem_cast v2' (incrdecr_type (typeof l)) (typeof l) m) as [v3'|] eqn:?. - destruct (classic (exists t2', exists m'', assign_loc ge (typeof l) m b ofs v3' t2' m'')). - destruct H1 as [t2' [m'' P]]. + destruct (classic (exists t2' m'' v'', assign_loc ge (typeof l) m b ofs bf v3' t2' m'' v'')). + destruct H1 as [t2' [m'' [v'' P]]]. econstructor; econstructor. left; eapply step_postincr with (v1 := v1'); eauto. simpl; reflexivity. econstructor; econstructor. left; eapply step_postincr_stuck with (v1 := v1'); eauto. - rewrite Heqo; rewrite Heqo0. intros; red; intros; elim H1. exists t0; exists m'0; auto. + rewrite Heqo; rewrite Heqo0. intros; red; intros; elim H1. exists t0, m'0, v'0; auto. econstructor; econstructor. left; eapply step_postincr_stuck with (v1 := v1'); eauto. rewrite Heqo; rewrite Heqo0; auto. econstructor; econstructor. left; eapply step_postincr_stuck with (v1 := v1'); eauto. @@ -1540,11 +1545,11 @@ Proof. exploit deref_loc_receptive; eauto. intros [EQ [v1' A]]. subst t1. destruct (sem_incrdecr ge id v1' (typeof l) m) as [v2'|] eqn:?. destruct (sem_cast v2' (incrdecr_type (typeof l)) (typeof l) m) as [v3'|] eqn:?. - destruct (classic (exists t2', exists m'', assign_loc ge (typeof l) m b ofs v3' t2' m'')). - destruct H1 as [t2' [m'' P]]. + destruct (classic (exists t2' m'' v'', assign_loc ge (typeof l) m b ofs bf v3' t2' m'' v'')). + destruct H1 as [t2' [m'' [v'' P]]]. econstructor; econstructor. left; eapply step_postincr with (v1 := v1'); eauto. simpl; reflexivity. econstructor; econstructor. left; eapply step_postincr_stuck with (v1 := v1'); eauto. - rewrite Heqo; rewrite Heqo0. intros; red; intros; elim H1. exists t2; exists m'; auto. + rewrite Heqo; rewrite Heqo0. intros; red; intros; elim H1. exists t2, m', v'; auto. econstructor; econstructor. left; eapply step_postincr_stuck with (v1 := v1'); eauto. rewrite Heqo; rewrite Heqo0; auto. econstructor; econstructor. left; eapply step_postincr_stuck with (v1 := v1'); eauto. @@ -1553,13 +1558,13 @@ Proof. exploit external_call_trace_length; eauto. destruct t1; simpl; intros. exploit external_call_receptive; eauto. intros [vres2 [m2 EC2]]. econstructor; econstructor. left; eapply step_builtin; eauto. - omegaContradiction. + extlia. (* external calls *) inv H1. exploit external_call_trace_length; eauto. destruct t1; simpl; intros. exploit external_call_receptive; eauto. intros [vres2 [m2 EC2]]. exists (Returnstate vres2 k m2); exists E0; right; econstructor; eauto. - omegaContradiction. + extlia. (* well-behaved traces *) red; intros. inv H; inv H0; simpl; auto. (* valof volatile *) @@ -1582,10 +1587,10 @@ Proof. exploit deref_loc_trace; eauto. destruct t; auto. destruct t; tauto. (* builtins *) exploit external_call_trace_length; eauto. - destruct t; simpl; auto. destruct t; simpl; auto. intros; omegaContradiction. + destruct t; simpl; auto. destruct t; simpl; auto. intros; extlia. (* external calls *) exploit external_call_trace_length; eauto. - destruct t; simpl; auto. destruct t; simpl; auto. intros; omegaContradiction. + destruct t; simpl; auto. destruct t; simpl; auto. intros; extlia. Qed. (** The main simulation result. *) @@ -1670,11 +1675,11 @@ with eval_expr: env -> mem -> kind -> expr -> trace -> mem -> expr -> Prop := type_is_volatile (typeof a) = false -> eval_expr e m LV a t m' a' -> eval_expr e m RV (Evalof a ty) t m' (Evalof a' ty) - | eval_valof_volatile: forall e m a t1 m' a' ty b ofs t2 v, + | eval_valof_volatile: forall e m a t1 m' a' ty b ofs bf t2 v, type_is_volatile (typeof a) = true -> eval_expr e m LV a t1 m' a' -> - eval_simple_lvalue ge e m' a' b ofs -> - deref_loc ge (typeof a) m' b ofs t2 v -> + eval_simple_lvalue ge e m' a' b ofs bf -> + deref_loc ge (typeof a) m' b ofs bf t2 v -> ty = typeof a -> eval_expr e m RV (Evalof a ty) (t1 ** t2) m' (Eval v ty) | eval_deref: forall e m a t m' a' ty, @@ -1722,32 +1727,32 @@ with eval_expr: env -> mem -> kind -> expr -> trace -> mem -> expr -> Prop := eval_expr e m RV (Esizeof ty' ty) E0 m (Esizeof ty' ty) | eval_alignof: forall e m ty' ty, eval_expr e m RV (Ealignof ty' ty) E0 m (Ealignof ty' ty) - | eval_assign: forall e m l r ty t1 m1 l' t2 m2 r' b ofs v v' t3 m3, + | eval_assign: forall e m l r ty t1 m1 l' t2 m2 r' b ofs bf v v1 v' t3 m3, eval_expr e m LV l t1 m1 l' -> eval_expr e m1 RV r t2 m2 r' -> - eval_simple_lvalue ge e m2 l' b ofs -> + eval_simple_lvalue ge e m2 l' b ofs bf -> eval_simple_rvalue ge e m2 r' v -> - sem_cast v (typeof r) (typeof l) m2 = Some v' -> - assign_loc ge (typeof l) m2 b ofs v' t3 m3 -> + sem_cast v (typeof r) (typeof l) m2 = Some v1 -> + assign_loc ge (typeof l) m2 b ofs bf v1 t3 m3 v' -> ty = typeof l -> eval_expr e m RV (Eassign l r ty) (t1**t2**t3) m3 (Eval v' ty) - | eval_assignop: forall e m op l r tyres ty t1 m1 l' t2 m2 r' b ofs - v1 v2 v3 v4 t3 t4 m3, + | eval_assignop: forall e m op l r tyres ty t1 m1 l' t2 m2 r' b ofs bf + v1 v2 v3 v4 v' t3 t4 m3, eval_expr e m LV l t1 m1 l' -> eval_expr e m1 RV r t2 m2 r' -> - eval_simple_lvalue ge e m2 l' b ofs -> - deref_loc ge (typeof l) m2 b ofs t3 v1 -> + eval_simple_lvalue ge e m2 l' b ofs bf -> + deref_loc ge (typeof l) m2 b ofs bf t3 v1 -> eval_simple_rvalue ge e m2 r' v2 -> sem_binary_operation ge op v1 (typeof l) v2 (typeof r) m2 = Some v3 -> sem_cast v3 tyres (typeof l) m2 = Some v4 -> - assign_loc ge (typeof l) m2 b ofs v4 t4 m3 -> + assign_loc ge (typeof l) m2 b ofs bf v4 t4 m3 v' -> ty = typeof l -> - eval_expr e m RV (Eassignop op l r tyres ty) (t1**t2**t3**t4) m3 (Eval v4 ty) - | eval_postincr: forall e m id l ty t1 m1 l' b ofs v1 v2 v3 m2 t2 t3, + eval_expr e m RV (Eassignop op l r tyres ty) (t1**t2**t3**t4) m3 (Eval v' ty) + | eval_postincr: forall e m id l ty t1 m1 l' b ofs bf v1 v2 v3 v' m2 t2 t3, eval_expr e m LV l t1 m1 l' -> - eval_simple_lvalue ge e m1 l' b ofs -> - deref_loc ge ty m1 b ofs t2 v1 -> + eval_simple_lvalue ge e m1 l' b ofs bf -> + deref_loc ge ty m1 b ofs bf t2 v1 -> sem_incrdecr ge id v1 ty m1 = Some v2 -> sem_cast v2 (incrdecr_type ty) ty m1 = Some v3 -> - assign_loc ge ty m1 b ofs v3 t3 m2 -> + assign_loc ge ty m1 b ofs bf v3 t3 m2 v' -> ty = typeof l -> eval_expr e m RV (Epostincr id l ty) (t1**t2**t3) m2 (Eval v1 ty) | eval_comma: forall e m r1 r2 ty t1 m1 r1' v1 t2 m2 r2', @@ -2310,7 +2315,7 @@ Proof. simpl; intuition. eapply star_trans. eexact D. eapply star_right. eexact G. - left. eapply step_assign; eauto. congruence. rewrite B; eauto. congruence. + left. eapply step_assign with (v1 := v1); eauto. congruence. rewrite B; eauto. congruence. reflexivity. traceEq. (* assignop *) exploit (H0 (fun x => C(Eassignop op x r tyres ty))). @@ -2321,7 +2326,7 @@ Proof. eapply star_trans. eexact D. eapply star_right. eexact G. left. eapply step_assignop; eauto. - rewrite B; eauto. rewrite B; rewrite F; eauto. congruence. rewrite B; eauto. congruence. + rewrite B; eauto. rewrite B; rewrite F; eauto. rewrite B; eauto. rewrite B; eauto. congruence. reflexivity. traceEq. (* postincr *) exploit (H0 (fun x => C(Epostincr id x ty))). @@ -2655,7 +2660,7 @@ Proof (proj2 (proj2 (proj2 (proj2 bigstep_to_steps)))). Fixpoint esize (a: expr) : nat := match a with - | Eloc _ _ _ => 1%nat + | Eloc _ _ _ _ => 1%nat | Evar _ _ => 1%nat | Ederef r1 _ => S(esize r1) | Efield l1 _ _ => S(esize l1) @@ -2734,7 +2739,7 @@ Proof. cofix COEL. intros. inv H. (* cons left *) - eapply forever_N_star with (a2 := (esize a0)). apply star_refl. simpl; omega. + eapply forever_N_star with (a2 := (esize a0)). apply star_refl. simpl; lia. eapply COE with (C := fun x => C(Ecall a1 (exprlist_app al (Econs x al0)) ty)). eauto. eapply leftcontext_compose; eauto. constructor. auto. apply exprlist_app_leftcontext; auto. traceEq. @@ -2745,7 +2750,7 @@ Proof. eapply leftcontext_compose; eauto. repeat constructor. auto. apply exprlist_app_leftcontext; auto. eapply forever_N_star with (a2 := (esizelist al0)). - eexact R. simpl; omega. + eexact R. simpl; lia. change (Econs a1' al0) with (exprlist_app (Econs a1' Enil) al0). rewrite <- exprlist_app_assoc. eapply COEL. eauto. auto. auto. @@ -2754,42 +2759,42 @@ Proof. intros. inv H. (* field *) - eapply forever_N_star with (a2 := (esize a0)). apply star_refl. simpl; omega. + eapply forever_N_star with (a2 := (esize a0)). apply star_refl. simpl; lia. eapply COE with (C := fun x => C(Efield x f0 ty)). eauto. eapply leftcontext_compose; eauto. repeat constructor. traceEq. (* valof *) - eapply forever_N_star with (a2 := (esize a0)). apply star_refl. simpl; omega. + eapply forever_N_star with (a2 := (esize a0)). apply star_refl. simpl; lia. eapply COE with (C := fun x => C(Evalof x ty)). eauto. eapply leftcontext_compose; eauto. repeat constructor. traceEq. (* deref *) - eapply forever_N_star with (a2 := (esize a0)). apply star_refl. simpl; omega. + eapply forever_N_star with (a2 := (esize a0)). apply star_refl. simpl; lia. eapply COE with (C := fun x => C(Ederef x ty)). eauto. eapply leftcontext_compose; eauto. repeat constructor. traceEq. (* addrof *) - eapply forever_N_star with (a2 := (esize a0)). apply star_refl. simpl; omega. + eapply forever_N_star with (a2 := (esize a0)). apply star_refl. simpl; lia. eapply COE with (C := fun x => C(Eaddrof x ty)). eauto. eapply leftcontext_compose; eauto. repeat constructor. traceEq. (* unop *) - eapply forever_N_star with (a2 := (esize a0)). apply star_refl. simpl; omega. + eapply forever_N_star with (a2 := (esize a0)). apply star_refl. simpl; lia. eapply COE with (C := fun x => C(Eunop op x ty)). eauto. eapply leftcontext_compose; eauto. repeat constructor. traceEq. (* binop left *) - eapply forever_N_star with (a2 := (esize a1)). apply star_refl. simpl; omega. + eapply forever_N_star with (a2 := (esize a1)). apply star_refl. simpl; lia. eapply COE with (C := fun x => C(Ebinop op x a2 ty)). eauto. eapply leftcontext_compose; eauto. repeat constructor. traceEq. (* binop right *) destruct (eval_expr_to_steps _ _ _ _ _ _ _ H1 (fun x => C(Ebinop op x a2 ty)) f k) as [P [Q R]]. eapply leftcontext_compose; eauto. repeat constructor. - eapply forever_N_star with (a2 := (esize a2)). eexact R. simpl; omega. + eapply forever_N_star with (a2 := (esize a2)). eexact R. simpl; lia. eapply COE with (C := fun x => C(Ebinop op a1' x ty)). eauto. eapply leftcontext_compose; eauto. repeat constructor. auto. traceEq. (* cast *) - eapply forever_N_star with (a2 := (esize a0)). apply star_refl. simpl; omega. + eapply forever_N_star with (a2 := (esize a0)). apply star_refl. simpl; lia. eapply COE with (C := fun x => C(Ecast x ty)). eauto. eapply leftcontext_compose; eauto. repeat constructor. traceEq. (* seqand left *) - eapply forever_N_star with (a2 := (esize a1)). apply star_refl. simpl; omega. + eapply forever_N_star with (a2 := (esize a1)). apply star_refl. simpl; lia. eapply COE with (C := fun x => C(Eseqand x a2 ty)). eauto. eapply leftcontext_compose; eauto. repeat constructor. traceEq. (* seqand 2 *) @@ -2802,7 +2807,7 @@ Proof. eapply COE with (C := fun x => (C (Eparen x type_bool ty))). eauto. eapply leftcontext_compose; eauto. repeat constructor. traceEq. (* seqor left *) - eapply forever_N_star with (a2 := (esize a1)). apply star_refl. simpl; omega. + eapply forever_N_star with (a2 := (esize a1)). apply star_refl. simpl; lia. eapply COE with (C := fun x => C(Eseqor x a2 ty)). eauto. eapply leftcontext_compose; eauto. repeat constructor. traceEq. (* seqor 2 *) @@ -2815,7 +2820,7 @@ Proof. eapply COE with (C := fun x => (C (Eparen x type_bool ty))). eauto. eapply leftcontext_compose; eauto. repeat constructor. traceEq. (* condition top *) - eapply forever_N_star with (a2 := (esize a1)). apply star_refl. simpl; omega. + eapply forever_N_star with (a2 := (esize a1)). apply star_refl. simpl; lia. eapply COE with (C := fun x => C(Econdition x a2 a3 ty)). eauto. eapply leftcontext_compose; eauto. repeat constructor. traceEq. (* condition *) @@ -2828,33 +2833,33 @@ Proof. eapply COE with (C := fun x => (C (Eparen x ty ty))). eauto. eapply leftcontext_compose; eauto. repeat constructor. traceEq. (* assign left *) - eapply forever_N_star with (a2 := (esize a1)). apply star_refl. simpl; omega. + eapply forever_N_star with (a2 := (esize a1)). apply star_refl. simpl; lia. eapply COE with (C := fun x => C(Eassign x a2 ty)). eauto. eapply leftcontext_compose; eauto. repeat constructor. traceEq. (* assign right *) destruct (eval_expr_to_steps _ _ _ _ _ _ _ H1 (fun x => C(Eassign x a2 ty)) f k) as [P [Q R]]. eapply leftcontext_compose; eauto. repeat constructor. - eapply forever_N_star with (a2 := (esize a2)). eexact R. simpl; omega. + eapply forever_N_star with (a2 := (esize a2)). eexact R. simpl; lia. eapply COE with (C := fun x => C(Eassign a1' x ty)). eauto. eapply leftcontext_compose; eauto. repeat constructor. auto. traceEq. (* assignop left *) - eapply forever_N_star with (a2 := (esize a1)). apply star_refl. simpl; omega. + eapply forever_N_star with (a2 := (esize a1)). apply star_refl. simpl; lia. eapply COE with (C := fun x => C(Eassignop op x a2 tyres ty)). eauto. eapply leftcontext_compose; eauto. repeat constructor. traceEq. (* assignop right *) destruct (eval_expr_to_steps _ _ _ _ _ _ _ H1 (fun x => C(Eassignop op x a2 tyres ty)) f k) as [P [Q R]]. eapply leftcontext_compose; eauto. repeat constructor. - eapply forever_N_star with (a2 := (esize a2)). eexact R. simpl; omega. + eapply forever_N_star with (a2 := (esize a2)). eexact R. simpl; lia. eapply COE with (C := fun x => C(Eassignop op a1' x tyres ty)). eauto. eapply leftcontext_compose; eauto. repeat constructor. auto. traceEq. (* postincr *) - eapply forever_N_star with (a2 := (esize a0)). apply star_refl. simpl; omega. + eapply forever_N_star with (a2 := (esize a0)). apply star_refl. simpl; lia. eapply COE with (C := fun x => C(Epostincr id x ty)). eauto. eapply leftcontext_compose; eauto. repeat constructor. traceEq. (* comma left *) - eapply forever_N_star with (a2 := (esize a1)). apply star_refl. simpl; omega. + eapply forever_N_star with (a2 := (esize a1)). apply star_refl. simpl; lia. eapply COE with (C := fun x => C(Ecomma x a2 ty)). eauto. eapply leftcontext_compose; eauto. repeat constructor. traceEq. (* comma right *) @@ -2865,14 +2870,14 @@ Proof. left; eapply step_comma; eauto. reflexivity. eapply COE with (C := C); eauto. traceEq. (* call left *) - eapply forever_N_star with (a2 := (esize a1)). apply star_refl. simpl; omega. + eapply forever_N_star with (a2 := (esize a1)). apply star_refl. simpl; lia. eapply COE with (C := fun x => C(Ecall x a2 ty)). eauto. eapply leftcontext_compose; eauto. repeat constructor. traceEq. (* call right *) destruct (eval_expr_to_steps _ _ _ _ _ _ _ H1 (fun x => C(Ecall x a2 ty)) f k) as [P [Q R]]. eapply leftcontext_compose; eauto. repeat constructor. - eapply forever_N_star with (a2 := (esizelist a2)). eexact R. simpl; omega. + eapply forever_N_star with (a2 := (esizelist a2)). eexact R. simpl; lia. eapply COEL with (al := Enil). eauto. auto. auto. auto. traceEq. (* call *) destruct (eval_expr_to_steps _ _ _ _ _ _ _ H1 (fun x => C(Ecall x rargs ty)) f k) diff --git a/cfrontend/Csyntax.v b/cfrontend/Csyntax.v index e3e2c1e9..5b8a62be 100644 --- a/cfrontend/Csyntax.v +++ b/cfrontend/Csyntax.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -55,7 +56,7 @@ Inductive expr : Type := (**r function call [r1(rargs)] *) | Ebuiltin (ef: external_function) (tyargs: typelist) (rargs: exprlist) (ty: type) (**r builtin function call *) - | Eloc (b: block) (ofs: ptrofs) (ty: type) + | Eloc (b: block) (ofs: ptrofs) (bf: bitfield) (ty: type) (**r memory location, result of evaluating a l-value *) | Eparen (r: expr) (tycast: type) (ty: type) (**r marked subexpression *) @@ -116,7 +117,7 @@ Definition Eselection (r1 r2 r3: expr) (ty: type) := Definition typeof (a: expr) : type := match a with - | Eloc _ _ ty => ty + | Eloc _ _ _ ty => ty | Evar _ ty => ty | Ederef _ ty => ty | Efield _ _ ty => ty diff --git a/cfrontend/Ctypes.v b/cfrontend/Ctypes.v index 664a60c5..e3356510 100644 --- a/cfrontend/Ctypes.v +++ b/cfrontend/Ctypes.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -19,6 +20,10 @@ Require Import Axioms Coqlib Maps Errors. Require Import AST Linking. Require Archi. +Set Asymmetric Patterns. + +Local Open Scope error_monad_scope. + (** * Syntax of types *) (** Compcert C types are similar to those of C. They include numeric types, @@ -83,20 +88,28 @@ Proof. decide equality. Defined. +Lemma signedness_eq: forall (s1 s2: signedness), {s1=s2} + {s1<>s2}. +Proof. + decide equality. +Defined. + +Lemma attr_eq: forall (a1 a2: attr), {a1=a2} + {a1<>a2}. +Proof. + decide equality. decide equality. apply N.eq_dec. apply bool_dec. +Defined. + Lemma type_eq: forall (ty1 ty2: type), {ty1=ty2} + {ty1<>ty2} with typelist_eq: forall (tyl1 tyl2: typelist), {tyl1=tyl2} + {tyl1<>tyl2}. Proof. - assert (forall (x y: signedness), {x=y} + {x<>y}) by decide equality. assert (forall (x y: floatsize), {x=y} + {x<>y}) by decide equality. - assert (forall (x y: attr), {x=y} + {x<>y}). - { decide equality. decide equality. apply N.eq_dec. apply bool_dec. } - generalize ident_eq zeq bool_dec ident_eq intsize_eq; intros. + generalize ident_eq zeq bool_dec ident_eq intsize_eq signedness_eq attr_eq; intros. + decide equality. decide equality. decide equality. decide equality. Defined. -Opaque type_eq typelist_eq. +Global Opaque intsize_eq signedness_eq attr_eq type_eq typelist_eq. (** Extract the attributes of a type. *) @@ -148,17 +161,53 @@ Definition attr_union (a1 a2: attr) : attr := Definition merge_attributes (ty: type) (a: attr) : type := change_attributes (attr_union a) ty. +(** Maximal size in bits of a bitfield of type [sz]. *) + +Definition bitsize_intsize (sz: intsize) : Z := + match sz with + | I8 => 8 + | I16 => 16 + | I32 => 32 + | IBool => 1 + end. + (** Syntax for [struct] and [union] definitions. [struct] and [union] are collectively called "composites". Each compilation unit comes with a list of top-level definitions of composites. *) Inductive struct_or_union : Type := Struct | Union. -Definition members : Type := list (ident * type). +Inductive member : Type := + | Member_plain (id: ident) (t: type) + | Member_bitfield (id: ident) (sz: intsize) (sg: signedness) (a: attr) + (width: Z) (padding: bool). + +Definition members : Type := list member. Inductive composite_definition : Type := Composite (id: ident) (su: struct_or_union) (m: members) (a: attr). +Definition name_member (m: member) : ident := + match m with + | Member_plain id _ => id + | Member_bitfield id _ _ _ _ _ => id + end. + +Definition type_member (m: member) : type := + match m with + | Member_plain _ t => t + | Member_bitfield _ sz sg a w _ => + (* An unsigned bitfield of width < size of type reads with a signed type *) + let sg' := if zlt w (bitsize_intsize sz) then Signed else sg in + Tint sz sg' a + end. + +Definition member_is_padding (m: member) : bool := + match m with + | Member_plain _ _ => false + | Member_bitfield _ _ _ _ _ p => p + end. + Definition name_composite_def (c: composite_definition) : ident := match c with Composite id su m a => id end. @@ -166,7 +215,9 @@ Definition composite_def_eq (x y: composite_definition): {x=y} + {x<>y}. Proof. decide equality. - decide equality. decide equality. apply N.eq_dec. apply bool_dec. -- apply list_eq_dec. decide equality. apply type_eq. apply ident_eq. +- apply list_eq_dec. decide equality. + apply type_eq. apply ident_eq. + apply bool_dec. apply zeq. apply attr_eq. apply signedness_eq. apply intsize_eq. apply ident_eq. - decide equality. - apply ident_eq. Defined. @@ -192,6 +243,13 @@ Record composite : Type := { Definition composite_env : Type := PTree.t composite. +(** Access modes for members of structs or unions: either a plain field + or a bitfield *) + +Inductive bitfield : Type := + | Full + | Bits (sz: intsize) (sg: signedness) (pos: Z) (width: Z). + (** * Operations over types *) (** ** Conversions *) @@ -349,13 +407,16 @@ Fixpoint sizeof (env: composite_env) (t: type) : Z := Lemma sizeof_pos: forall env t, sizeof env t >= 0. Proof. - induction t; simpl; try omega. - destruct i; omega. - destruct f; omega. - destruct Archi.ptr64; omega. - change 0 with (0 * Z.max 0 z) at 2. apply Zmult_ge_compat_r. auto. xomega. - destruct (env!i). apply co_sizeof_pos. omega. - destruct (env!i). apply co_sizeof_pos. omega. + induction t; simpl. +- lia. +- destruct i; lia. +- lia. +- destruct f; lia. +- destruct Archi.ptr64; lia. +- change 0 with (0 * Z.max 0 z) at 2. apply Zmult_ge_compat_r. auto. lia. +- lia. +- destruct (env!i). apply co_sizeof_pos. lia. +- destruct (env!i). apply co_sizeof_pos. lia. Qed. (** The size of a type is an integral multiple of its alignment, @@ -384,41 +445,205 @@ Proof. - destruct (env!i). apply co_sizeof_alignof. apply Z.divide_0_r. Qed. +(** ** Layout of struct fields *) + +Section LAYOUT. + +Variable env: composite_env. + +Definition bitalignof (t: type) := alignof env t * 8. + +Definition bitsizeof (t: type) := sizeof env t * 8. + +Definition bitalignof_intsize (sz: intsize) : Z := + match sz with + | I8 | IBool => 8 + | I16 => 16 + | I32 => 32 + end. + +Definition next_field (pos: Z) (m: member) : Z := + match m with + | Member_plain _ t => + align pos (bitalignof t) + bitsizeof t + | Member_bitfield _ sz _ _ w _ => + let s := bitalignof_intsize sz in + if zle w 0 then + align pos s + else + let curr := floor pos s in + let next := curr + s in + if zle (pos + w) next then pos + w else next + w + end. + +Definition layout_field (pos: Z) (m: member) : res (Z * bitfield) := + match m with + | Member_plain _ t => + OK (align pos (bitalignof t) / 8, Full) + | Member_bitfield _ sz sg _ w _ => + if zle w 0 then Error (msg "accessing zero-width bitfield") + else if zlt (bitsize_intsize sz) w then Error (msg "bitfield too wide") + else + let s := bitalignof_intsize sz in + let start := floor pos s in + let next := start + s in + if zle (pos + w) next then + OK (start / 8, Bits sz sg (pos - start) w) + else + OK (next / 8, Bits sz sg 0 w) + end. + +(** Some properties *) + +Lemma bitalignof_intsize_pos: + forall sz, bitalignof_intsize sz > 0. +Proof. + destruct sz; simpl; lia. +Qed. + +Lemma next_field_incr: + forall pos m, pos <= next_field pos m. +Proof. + intros. unfold next_field. destruct m. +- set (al := bitalignof t). + assert (A: al > 0). + { unfold al, bitalignof. generalize (alignof_pos env t). lia. } + assert (pos <= align pos al) by (apply align_le; auto). + assert (bitsizeof t >= 0). + { unfold bitsizeof. generalize (sizeof_pos env t). lia. } + lia. +- set (s := bitalignof_intsize sz). + assert (A: s > 0) by (apply bitalignof_intsize_pos). + destruct (zle width 0). ++ apply align_le; auto. ++ generalize (floor_interval pos s A). + set (start := floor pos s). intros B. + destruct (zle (pos + width) (start + s)); lia. +Qed. + +Definition layout_start (p: Z) (bf: bitfield) := + p * 8 + match bf with Full => 0 | Bits sz sg pos w => pos end. + +Definition layout_width (t: type) (bf: bitfield) := + match bf with Full => bitsizeof t | Bits sz sg pos w => w end. + +Lemma layout_field_range: forall pos m ofs bf, + layout_field pos m = OK (ofs, bf) -> + pos <= layout_start ofs bf + /\ layout_start ofs bf + layout_width (type_member m) bf <= next_field pos m. +Proof. + intros until bf; intros L. unfold layout_start, layout_width. destruct m; simpl in L. +- inv L. simpl. + set (al := bitalignof t). + set (q := align pos al). + assert (A: al > 0). + { unfold al, bitalignof. generalize (alignof_pos env t). lia. } + assert (B: pos <= q) by (apply align_le; auto). + assert (C: (al | q)) by (apply align_divides; auto). + assert (D: (8 | q)). + { apply Z.divide_transitive with al; auto. apply Z.divide_factor_r. } + assert (E: q / 8 * 8 = q). + { destruct D as (n & E). rewrite E. rewrite Z.div_mul by lia. auto. } + rewrite E. lia. +- unfold next_field. + destruct (zle width 0); try discriminate. + destruct (zlt (bitsize_intsize sz) width); try discriminate. + set (s := bitalignof_intsize sz) in *. + assert (A: s > 0) by (apply bitalignof_intsize_pos). + generalize (floor_interval pos s A). set (p := floor pos s) in *. intros B. + assert (C: (s | p)) by (apply floor_divides; auto). + assert (D: (8 | s)). + { exists (s / 8). unfold s. destruct sz; reflexivity. } + assert (E: (8 | p)) by (apply Z.divide_transitive with s; auto). + assert (F: (8 | p + s)) by (apply Z.divide_add_r; auto). + assert (G: p / 8 * 8 = p). + { destruct E as (n & EQ). rewrite EQ. rewrite Z.div_mul by lia. auto. } + assert (H: (p + s) / 8 * 8 = p + s). + { destruct F as (n & EQ). rewrite EQ. rewrite Z.div_mul by lia. auto. } + destruct (zle (pos + width) (p + s)); inv L; lia. +Qed. + +Definition layout_alignment (t: type) (bf: bitfield) := + match bf with + | Full => alignof env t + | Bits sz _ _ _ => bitalignof_intsize sz / 8 + end. + +Lemma layout_field_alignment: forall pos m ofs bf, + layout_field pos m = OK (ofs, bf) -> + (layout_alignment (type_member m) bf | ofs). +Proof. + intros until bf; intros L. destruct m; simpl in L. +- inv L; simpl. + set (q := align pos (bitalignof t)). + assert (A: (bitalignof t | q)). + { apply align_divides. unfold bitalignof. generalize (alignof_pos env t). lia. } + destruct A as [n E]. exists n. rewrite E. unfold bitalignof. rewrite Z.mul_assoc, Z.div_mul by lia. auto. +- destruct (zle width 0); try discriminate. + destruct (zlt (bitsize_intsize sz) width); try discriminate. + set (s := bitalignof_intsize sz) in *. + assert (A: s > 0) by (apply bitalignof_intsize_pos). + set (p := floor pos s) in *. + assert (C: (s | p)) by (apply floor_divides; auto). + assert (D: (8 | s)). + { exists (s / 8). unfold s. destruct sz; reflexivity. } + assert (E: forall n, (s | n) -> (s / 8 | n / 8)). + { intros. destruct H as [n1 E1], D as [n2 E2]. rewrite E1, E2. + rewrite Z.mul_assoc, ! Z.div_mul by lia. exists n1; auto. } + destruct (zle (pos + width) (p + s)); inv L; simpl; fold s. + + apply E. auto. + + apply E. apply Z.divide_add_r; auto using Z.divide_refl. +Qed. + +End LAYOUT. + (** ** Size and alignment for composite definitions *) (** The alignment for a structure or union is the max of the alignment - of its members. *) + of its members. Padding bitfields are ignored. *) -Fixpoint alignof_composite (env: composite_env) (m: members) : Z := - match m with +Fixpoint alignof_composite (env: composite_env) (ms: members) : Z := + match ms with | nil => 1 - | (id, t) :: m' => Z.max (alignof env t) (alignof_composite env m') + | m :: ms => + if member_is_padding m + then alignof_composite env ms + else Z.max (alignof env (type_member m)) (alignof_composite env ms) end. (** The size of a structure corresponds to its layout: fields are laid out consecutively, and padding is inserted to align - each field to the alignment for its type. *) + each field to the alignment for its type. Bitfields are packed + as described above. *) -Fixpoint sizeof_struct (env: composite_env) (cur: Z) (m: members) : Z := - match m with +Fixpoint bitsizeof_struct (env: composite_env) (cur: Z) (ms: members) : Z := + match ms with | nil => cur - | (id, t) :: m' => sizeof_struct env (align cur (alignof env t) + sizeof env t) m' + | m :: ms => bitsizeof_struct env (next_field env cur m) ms end. +Definition bytes_of_bits (n: Z) := (n + 7) / 8. + +Definition sizeof_struct (env: composite_env) (m: members) : Z := + bytes_of_bits (bitsizeof_struct env 0 m). + (** The size of an union is the max of the sizes of its members. *) -Fixpoint sizeof_union (env: composite_env) (m: members) : Z := - match m with +Fixpoint sizeof_union (env: composite_env) (ms: members) : Z := + match ms with | nil => 0 - | (id, t) :: m' => Z.max (sizeof env t) (sizeof_union env m') + | m :: ms => Z.max (sizeof env (type_member m)) (sizeof_union env ms) end. +(** Some properties *) + Lemma alignof_composite_two_p: forall env m, exists n, alignof_composite env m = two_power_nat n. Proof. - induction m as [|[id t]]; simpl. + induction m; simpl. - exists 0%nat; auto. -- apply Z.max_case; auto. apply alignof_two_p. +- destruct (member_is_padding a); auto. + apply Z.max_case; auto. apply alignof_two_p. Qed. Lemma alignof_composite_pos: @@ -430,94 +655,113 @@ Proof. rewrite EQ; apply two_power_nat_pos. Qed. -Lemma sizeof_struct_incr: - forall env m cur, cur <= sizeof_struct env cur m. +Lemma bitsizeof_struct_incr: + forall env m cur, cur <= bitsizeof_struct env cur m. Proof. - induction m as [|[id t]]; simpl; intros. -- omega. -- apply Z.le_trans with (align cur (alignof env t)). - apply align_le. apply alignof_pos. - apply Z.le_trans with (align cur (alignof env t) + sizeof env t). - generalize (sizeof_pos env t); omega. - apply IHm. + induction m; simpl; intros. +- lia. +- apply Z.le_trans with (next_field env cur a). + apply next_field_incr. apply IHm. Qed. Lemma sizeof_union_pos: forall env m, 0 <= sizeof_union env m. Proof. - induction m as [|[id t]]; simpl; xomega. + induction m; simpl; extlia. Qed. -(** ** Byte offset for a field of a structure *) - -(** [field_offset env id fld] returns the byte offset for field [id] - in a structure whose members are [fld]. Fields are laid out - consecutively, and padding is inserted to align each field to the - alignment for its type. *) +(** ** Byte offset and bitfield designator for a field of a structure *) -Fixpoint field_offset_rec (env: composite_env) (id: ident) (fld: members) (pos: Z) - {struct fld} : res Z := - match fld with +Fixpoint field_type (id: ident) (ms: members) {struct ms} : res type := + match ms with | nil => Error (MSG "Unknown field " :: CTX id :: nil) - | (id', t) :: fld' => - if ident_eq id id' - then OK (align pos (alignof env t)) - else field_offset_rec env id fld' (align pos (alignof env t) + sizeof env t) + | m :: ms => if ident_eq id (name_member m) then OK (type_member m) else field_type id ms end. -Definition field_offset (env: composite_env) (id: ident) (fld: members) : res Z := - field_offset_rec env id fld 0. +(** [field_offset env id fld] returns the byte offset for field [id] + in a structure whose members are [fld]. It also returns a + bitfield designator, giving the location of the bits to access + within the storage unit for the bitfield. *) -Fixpoint field_type (id: ident) (fld: members) {struct fld} : res type := - match fld with +Fixpoint field_offset_rec (env: composite_env) (id: ident) (ms: members) (pos: Z) + {struct ms} : res (Z * bitfield) := + match ms with | nil => Error (MSG "Unknown field " :: CTX id :: nil) - | (id', t) :: fld' => if ident_eq id id' then OK t else field_type id fld' + | m :: ms => + if ident_eq id (name_member m) + then layout_field env pos m + else field_offset_rec env id ms (next_field env pos m) end. +Definition field_offset (env: composite_env) (id: ident) (ms: members) : res (Z * bitfield) := + field_offset_rec env id ms 0. + (** Some sanity checks about field offsets. First, field offsets are within the range of acceptable offsets. *) Remark field_offset_rec_in_range: - forall env id ofs ty fld pos, - field_offset_rec env id fld pos = OK ofs -> field_type id fld = OK ty -> - pos <= ofs /\ ofs + sizeof env ty <= sizeof_struct env pos fld. + forall env id ofs bf ty ms pos, + field_offset_rec env id ms pos = OK (ofs, bf) -> field_type id ms = OK ty -> + pos <= layout_start ofs bf + /\ layout_start ofs bf + layout_width env ty bf <= bitsizeof_struct env pos ms. Proof. - intros until ty. induction fld as [|[i t]]; simpl; intros. + induction ms as [ | m ms]; simpl; intros. - discriminate. -- destruct (ident_eq id i); intros. - inv H. inv H0. split. - apply align_le. apply alignof_pos. apply sizeof_struct_incr. - exploit IHfld; eauto. intros [A B]. split; auto. - eapply Z.le_trans; eauto. apply Z.le_trans with (align pos (alignof env t)). - apply align_le. apply alignof_pos. generalize (sizeof_pos env t). omega. +- destruct (ident_eq id (name_member m)). + + inv H0. + exploit layout_field_range; eauto. + generalize (bitsizeof_struct_incr env ms (next_field env pos m)). + lia. + + exploit IHms; eauto. + generalize (next_field_incr env pos m). + lia. Qed. -Lemma field_offset_in_range: - forall env fld id ofs ty, - field_offset env id fld = OK ofs -> field_type id fld = OK ty -> - 0 <= ofs /\ ofs + sizeof env ty <= sizeof_struct env 0 fld. +Lemma field_offset_in_range_gen: + forall env ms id ofs bf ty, + field_offset env id ms = OK (ofs, bf) -> field_type id ms = OK ty -> + 0 <= layout_start ofs bf + /\ layout_start ofs bf + layout_width env ty bf <= bitsizeof_struct env 0 ms. Proof. intros. eapply field_offset_rec_in_range; eauto. Qed. +Corollary field_offset_in_range: + forall env ms id ofs ty, + field_offset env id ms = OK (ofs, Full) -> field_type id ms = OK ty -> + 0 <= ofs /\ ofs + sizeof env ty <= sizeof_struct env ms. +Proof. + intros. exploit field_offset_in_range_gen; eauto. + unfold layout_start, layout_width, bitsizeof, sizeof_struct. intros [A B]. + assert (C: forall x y, x * 8 <= y -> x <= bytes_of_bits y). + { unfold bytes_of_bits; intros. + assert (P: 8 > 0) by lia. + generalize (Z_div_mod_eq (y + 7) 8 P) (Z_mod_lt (y + 7) 8 P). + lia. } + split. lia. apply C. lia. +Qed. + (** Second, two distinct fields do not overlap *) Lemma field_offset_no_overlap: - forall env id1 ofs1 ty1 id2 ofs2 ty2 fld, - field_offset env id1 fld = OK ofs1 -> field_type id1 fld = OK ty1 -> - field_offset env id2 fld = OK ofs2 -> field_type id2 fld = OK ty2 -> + forall env id1 ofs1 bf1 ty1 id2 ofs2 bf2 ty2 fld, + field_offset env id1 fld = OK (ofs1, bf1) -> field_type id1 fld = OK ty1 -> + field_offset env id2 fld = OK (ofs2, bf2) -> field_type id2 fld = OK ty2 -> id1 <> id2 -> - ofs1 + sizeof env ty1 <= ofs2 \/ ofs2 + sizeof env ty2 <= ofs1. + layout_start ofs1 bf1 + layout_width env ty1 bf1 <= layout_start ofs2 bf2 + \/ layout_start ofs2 bf2 + layout_width env ty2 bf2 <= layout_start ofs1 bf1. Proof. intros until fld. unfold field_offset. generalize 0 as pos. - induction fld as [|[i t]]; simpl; intros. + induction fld as [|m fld]; simpl; intros. - discriminate. -- destruct (ident_eq id1 i); destruct (ident_eq id2 i). +- destruct (ident_eq id1 (name_member m)); destruct (ident_eq id2 (name_member m)). + congruence. -+ subst i. inv H; inv H0. - exploit field_offset_rec_in_range. eexact H1. eauto. tauto. -+ subst i. inv H1; inv H2. - exploit field_offset_rec_in_range. eexact H. eauto. tauto. ++ inv H0. + exploit field_offset_rec_in_range; eauto. + exploit layout_field_range; eauto. lia. ++ inv H2. + exploit field_offset_rec_in_range; eauto. + exploit layout_field_range; eauto. lia. + eapply IHfld; eauto. Qed. @@ -525,31 +769,90 @@ Qed. are the same. *) Lemma field_offset_prefix: - forall env id ofs fld2 fld1, - field_offset env id fld1 = OK ofs -> - field_offset env id (fld1 ++ fld2) = OK ofs. + forall env id ofs bf fld2 fld1, + field_offset env id fld1 = OK (ofs, bf) -> + field_offset env id (fld1 ++ fld2) = OK (ofs, bf). Proof. intros until fld1. unfold field_offset. generalize 0 as pos. - induction fld1 as [|[i t]]; simpl; intros. + induction fld1 as [|m fld1]; simpl; intros. - discriminate. -- destruct (ident_eq id i); auto. +- destruct (ident_eq id (name_member m)); auto. Qed. (** Fourth, the position of each field respects its alignment. *) -Lemma field_offset_aligned: - forall env id fld ofs ty, - field_offset env id fld = OK ofs -> field_type id fld = OK ty -> - (alignof env ty | ofs). +Lemma field_offset_aligned_gen: + forall env id fld ofs bf ty, + field_offset env id fld = OK (ofs, bf) -> field_type id fld = OK ty -> + (layout_alignment env ty bf | ofs). Proof. intros until ty. unfold field_offset. generalize 0 as pos. revert fld. - induction fld as [|[i t]]; simpl; intros. + induction fld as [|m fld]; simpl; intros. - discriminate. -- destruct (ident_eq id i). -+ inv H; inv H0. apply align_divides. apply alignof_pos. +- destruct (ident_eq id (name_member m)). ++ inv H0. eapply layout_field_alignment; eauto. + eauto. Qed. +Corollary field_offset_aligned: + forall env id fld ofs ty, + field_offset env id fld = OK (ofs, Full) -> field_type id fld = OK ty -> + (alignof env ty | ofs). +Proof. + intros. exploit field_offset_aligned_gen; eauto. +Qed. + +(** [union_field_offset env id ms] returns the byte offset and + bitfield designator for accessing a member named [id] of a union + whose members are [ms]. The byte offset is always 0. *) + +Fixpoint union_field_offset (env: composite_env) (id: ident) (ms: members) + {struct ms} : res (Z * bitfield) := + match ms with + | nil => Error (MSG "Unknown field " :: CTX id :: nil) + | m :: ms => + if ident_eq id (name_member m) + then layout_field env 0 m + else union_field_offset env id ms + end. + +(** Some sanity checks about union field offsets. First, field offsets + fit within the size of the union. *) + +Lemma union_field_offset_in_range_gen: + forall env id ofs bf ty ms, + union_field_offset env id ms = OK (ofs, bf) -> field_type id ms = OK ty -> + ofs = 0 /\ 0 <= layout_start ofs bf /\ layout_start ofs bf + layout_width env ty bf <= sizeof_union env ms * 8. +Proof. + induction ms as [ | m ms]; simpl; intros. +- discriminate. +- destruct (ident_eq id (name_member m)). + + inv H0. set (ty := type_member m) in *. + destruct m; simpl in H. + * inv H. unfold layout_start, layout_width. + rewrite align_same. change (0 / 8) with 0. unfold bitsizeof. lia. + unfold bitalignof. generalize (alignof_pos env t). lia. + apply Z.divide_0_r. + * destruct (zle width 0); try discriminate. + destruct (zlt (bitsize_intsize sz) width); try discriminate. + assert (A: bitsize_intsize sz <= bitalignof_intsize sz <= sizeof env ty * 8). + { unfold ty, type_member; destruct sz; simpl; lia. } + rewrite zle_true in H by lia. inv H. + unfold layout_start, layout_width. + unfold floor; rewrite Z.div_0_l by lia. + lia. + + exploit IHms; eauto. lia. +Qed. + +Corollary union_field_offset_in_range: + forall env ms id ofs ty, + union_field_offset env id ms = OK (ofs, Full) -> field_type id ms = OK ty -> + ofs = 0 /\ sizeof env ty <= sizeof_union env ms. +Proof. + intros. exploit union_field_offset_in_range_gen; eauto. + unfold layout_start, layout_width, bitsizeof. lia. +Qed. + (** ** Access modes *) (** The [access_mode] function describes how a l-value of the given @@ -636,7 +939,7 @@ Proof. destruct n; auto. right; right; right. apply Z.min_l. rewrite two_power_nat_two_p. rewrite ! Nat2Z.inj_succ. - change 8 with (two_p 3). apply two_p_monotone. omega. + change 8 with (two_p 3). apply two_p_monotone. lia. } induction ty; simpl. auto. @@ -653,7 +956,7 @@ Qed. Lemma alignof_blockcopy_pos: forall env ty, alignof_blockcopy env ty > 0. Proof. - intros. generalize (alignof_blockcopy_1248 env ty). simpl. intuition omega. + intros. generalize (alignof_blockcopy_1248 env ty). simpl. intuition lia. Qed. Lemma sizeof_alignof_blockcopy_compat: @@ -669,8 +972,8 @@ Proof. apply Z.min_case. exists (two_p (Z.of_nat n)). change 8 with (two_p 3). - rewrite <- two_p_is_exp by omega. - rewrite two_power_nat_two_p. rewrite !Nat2Z.inj_succ. f_equal. omega. + rewrite <- two_p_is_exp by lia. + rewrite two_power_nat_two_p. rewrite !Nat2Z.inj_succ. f_equal. lia. apply Z.divide_refl. } induction ty; simpl. @@ -707,7 +1010,8 @@ Fixpoint rank_type (ce: composite_env) (t: type) : nat := Fixpoint rank_members (ce: composite_env) (m: members) : nat := match m with | nil => 0%nat - | (id, t) :: m => Init.Nat.max (rank_type ce t) (rank_members ce m) + | Member_plain _ t :: m => Init.Nat.max (rank_type ce t) (rank_members ce m) + | Member_bitfield _ _ _ _ _ _ :: m => rank_members ce m end. (** ** C types and back-end types *) @@ -761,7 +1065,7 @@ Definition signature_of_type (args: typelist) (res: type) (cc: calling_conventio Definition sizeof_composite (env: composite_env) (su: struct_or_union) (m: members) : Z := match su with - | Struct => sizeof_struct env 0 m + | Struct => sizeof_struct env m | Union => sizeof_union env m end. @@ -769,21 +1073,23 @@ Lemma sizeof_composite_pos: forall env su m, 0 <= sizeof_composite env su m. Proof. intros. destruct su; simpl. - apply sizeof_struct_incr. - apply sizeof_union_pos. +- unfold sizeof_struct, bytes_of_bits. + assert (0 <= bitsizeof_struct env 0 m) by apply bitsizeof_struct_incr. + change 0 with (0 / 8) at 1. apply Z.div_le_mono; lia. +- apply sizeof_union_pos. Qed. -Fixpoint complete_members (env: composite_env) (m: members) : bool := - match m with +Fixpoint complete_members (env: composite_env) (ms: members) : bool := + match ms with | nil => true - | (id, t) :: m' => complete_type env t && complete_members env m' + | m :: ms => complete_type env (type_member m) && complete_members env ms end. Lemma complete_member: - forall env id t m, - In (id, t) m -> complete_members env m = true -> complete_type env t = true. + forall env m ms, + In m ms -> complete_members env ms = true -> complete_type env (type_member m) = true. Proof. - induction m as [|[id1 t1] m]; simpl; intuition auto. + induction ms as [|m1 ms]; simpl; intuition auto. InvBooleans; inv H1; auto. InvBooleans; eauto. Qed. @@ -847,8 +1153,6 @@ Defined. must precede all uses of this composite, unless the use is under a pointer or function type. *) -Local Open Scope error_monad_scope. - Fixpoint add_composite_definitions (env: composite_env) (defs: list composite_definition) : res composite_env := match defs with | nil => OK env @@ -911,52 +1215,88 @@ Proof. Qed. Lemma alignof_composite_stable: - forall m, complete_members env m = true -> alignof_composite env' m = alignof_composite env m. + forall ms, complete_members env ms = true -> alignof_composite env' ms = alignof_composite env ms. Proof. - induction m as [|[id t]]; simpl; intros. + induction ms as [|m ms]; simpl; intros. auto. - InvBooleans. rewrite alignof_stable by auto. rewrite IHm by auto. auto. + InvBooleans. rewrite alignof_stable by auto. rewrite IHms by auto. auto. Qed. -Lemma sizeof_struct_stable: - forall m pos, complete_members env m = true -> sizeof_struct env' pos m = sizeof_struct env pos m. +Remark next_field_stable: forall pos m, + complete_type env (type_member m) = true -> next_field env' pos m = next_field env pos m. Proof. - induction m as [|[id t]]; simpl; intros. + destruct m; simpl; intros. +- unfold bitalignof, bitsizeof. rewrite alignof_stable, sizeof_stable by auto. auto. +- auto. +Qed. + +Lemma bitsizeof_struct_stable: + forall ms pos, complete_members env ms = true -> bitsizeof_struct env' pos ms = bitsizeof_struct env pos ms. +Proof. + induction ms as [|m ms]; simpl; intros. auto. - InvBooleans. rewrite alignof_stable by auto. rewrite sizeof_stable by auto. - rewrite IHm by auto. auto. + InvBooleans. rewrite next_field_stable by auto. apply IHms; auto. Qed. Lemma sizeof_union_stable: - forall m, complete_members env m = true -> sizeof_union env' m = sizeof_union env m. + forall ms, complete_members env ms = true -> sizeof_union env' ms = sizeof_union env ms. Proof. - induction m as [|[id t]]; simpl; intros. + induction ms as [|m ms]; simpl; intros. auto. - InvBooleans. rewrite sizeof_stable by auto. rewrite IHm by auto. auto. + InvBooleans. rewrite sizeof_stable by auto. rewrite IHms by auto. auto. Qed. Lemma sizeof_composite_stable: - forall su m, complete_members env m = true -> sizeof_composite env' su m = sizeof_composite env su m. + forall su ms, complete_members env ms = true -> sizeof_composite env' su ms = sizeof_composite env su ms. Proof. intros. destruct su; simpl. - apply sizeof_struct_stable; auto. + unfold sizeof_struct. f_equal. apply bitsizeof_struct_stable; auto. apply sizeof_union_stable; auto. Qed. Lemma complete_members_stable: - forall m, complete_members env m = true -> complete_members env' m = true. + forall ms, complete_members env ms = true -> complete_members env' ms = true. Proof. - induction m as [|[id t]]; simpl; intros. + induction ms as [|m ms]; simpl; intros. auto. - InvBooleans. rewrite complete_type_stable by auto. rewrite IHm by auto. auto. + InvBooleans. rewrite complete_type_stable by auto. rewrite IHms by auto. auto. Qed. Lemma rank_members_stable: - forall m, complete_members env m = true -> rank_members env' m = rank_members env m. + forall ms, complete_members env ms = true -> rank_members env' ms = rank_members env ms. Proof. - induction m as [|[id t]]; simpl; intros. + induction ms as [|m ms]; simpl; intros. auto. - InvBooleans. f_equal; auto. apply rank_type_stable; auto. + InvBooleans. destruct m; auto. f_equal; auto. apply rank_type_stable; auto. +Qed. + +Remark layout_field_stable: forall pos m, + complete_type env (type_member m) = true -> layout_field env' pos m = layout_field env pos m. +Proof. + destruct m; simpl; intros. +- unfold bitalignof. rewrite alignof_stable by auto. auto. +- auto. +Qed. + +Lemma field_offset_stable: + forall f ms, complete_members env ms = true -> field_offset env' f ms = field_offset env f ms. +Proof. + intros until ms. unfold field_offset. generalize 0. + induction ms as [|m ms]; simpl; intros. +- auto. +- InvBooleans. destruct (ident_eq f (name_member m)). + apply layout_field_stable; auto. + rewrite next_field_stable by auto. apply IHms; auto. +Qed. + +Lemma union_field_offset_stable: + forall f ms, complete_members env ms = true -> union_field_offset env' f ms = union_field_offset env f ms. +Proof. + induction ms as [|m ms]; simpl; intros. +- auto. +- InvBooleans. destruct (ident_eq f (name_member m)). + apply layout_field_stable; auto. + apply IHms; auto. Qed. End STABILITY. @@ -1086,37 +1426,41 @@ Qed. is strictly greater than the ranks of its member types. *) Remark rank_type_members: - forall ce id t m, In (id, t) m -> (rank_type ce t <= rank_members ce m)%nat. + forall ce m ms, In m ms -> (rank_type ce (type_member m) <= rank_members ce ms)%nat. Proof. - induction m; simpl; intros; intuition auto. - subst a. xomega. - xomega. + induction ms; simpl; intros. +- tauto. +- destruct a; destruct H; subst; simpl. + + lia. + + apply IHms in H. lia. + + lia. + + apply IHms; auto. Qed. Lemma rank_struct_member: - forall ce id a co id1 t1, + forall ce id a co m, composite_env_consistent ce -> ce!id = Some co -> - In (id1, t1) (co_members co) -> - (rank_type ce t1 < rank_type ce (Tstruct id a))%nat. + In m (co_members co) -> + (rank_type ce (type_member m) < rank_type ce (Tstruct id a))%nat. Proof. intros; simpl. rewrite H0. erewrite co_consistent_rank by eauto. exploit (rank_type_members ce); eauto. - omega. + lia. Qed. Lemma rank_union_member: - forall ce id a co id1 t1, + forall ce id a co m, composite_env_consistent ce -> ce!id = Some co -> - In (id1, t1) (co_members co) -> - (rank_type ce t1 < rank_type ce (Tunion id a))%nat. + In m (co_members co) -> + (rank_type ce (type_member m) < rank_type ce (Tunion id a))%nat. Proof. intros; simpl. rewrite H0. erewrite co_consistent_rank by eauto. exploit (rank_type_members ce); eauto. - omega. + lia. Qed. (** * Programs and compilation units *) @@ -1511,6 +1855,57 @@ Global Opaque Linker_program. (** ** Commutation between linking and program transformations *) +Section LINK_MATCH_PROGRAM_GEN. + +Context {F G: Type}. +Variable match_fundef: program F -> fundef F -> fundef G -> Prop. + +Hypothesis link_match_fundef: + forall ctx1 ctx2 f1 tf1 f2 tf2 f, + link f1 f2 = Some f -> + match_fundef ctx1 f1 tf1 -> match_fundef ctx2 f2 tf2 -> + exists tf, link tf1 tf2 = Some tf /\ (match_fundef ctx1 f tf \/ match_fundef ctx2 f tf). + +Let match_program (p: program F) (tp: program G) : Prop := + Linking.match_program_gen match_fundef eq p p tp + /\ prog_types tp = prog_types p. + +Theorem link_match_program_gen: + forall p1 p2 tp1 tp2 p, + link p1 p2 = Some p -> match_program p1 tp1 -> match_program p2 tp2 -> + exists tp, link tp1 tp2 = Some tp /\ match_program p tp. +Proof. + intros until p; intros L [M1 T1] [M2 T2]. + exploit link_linkorder; eauto. intros [LO1 LO2]. +Local Transparent Linker_program. + simpl in L; unfold link_program in L. + destruct (link (program_of_program p1) (program_of_program p2)) as [pp|] eqn:LP; try discriminate. + assert (A: exists tpp, + link (program_of_program tp1) (program_of_program tp2) = Some tpp + /\ Linking.match_program_gen match_fundef eq p pp tpp). + { eapply Linking.link_match_program; eauto. + - intros. + Local Transparent Linker_types. + simpl in *. destruct (type_eq v1 v2); inv H. exists v; rewrite dec_eq_true; auto. + } + destruct A as (tpp & TLP & MP). + simpl; unfold link_program. rewrite TLP. + destruct (lift_option (link (prog_types p1) (prog_types p2))) as [[typs EQ]|EQ]; try discriminate. + destruct (link_build_composite_env (prog_types p1) (prog_types p2) typs + (prog_comp_env p1) (prog_comp_env p2) (prog_comp_env_eq p1) + (prog_comp_env_eq p2) EQ) as (env & P & Q). + rewrite <- T1, <- T2 in EQ. + destruct (lift_option (link (prog_types tp1) (prog_types tp2))) as [[ttyps EQ']|EQ']; try congruence. + assert (ttyps = typs) by congruence. subst ttyps. + destruct (link_build_composite_env (prog_types tp1) (prog_types tp2) typs + (prog_comp_env tp1) (prog_comp_env tp2) (prog_comp_env_eq tp1) + (prog_comp_env_eq tp2) EQ') as (tenv & R & S). + assert (tenv = env) by congruence. subst tenv. + econstructor; split; eauto. inv L. split; auto. +Qed. + +End LINK_MATCH_PROGRAM_GEN. + Section LINK_MATCH_PROGRAM. Context {F G: Type}. @@ -1566,3 +1961,4 @@ Local Transparent Linker_program. Qed. End LINK_MATCH_PROGRAM. + diff --git a/cfrontend/Ctyping.v b/cfrontend/Ctyping.v index 00fcf8ab..c930a407 100644 --- a/cfrontend/Ctyping.v +++ b/cfrontend/Ctyping.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -170,7 +171,7 @@ Definition floatsize_eq: forall (x y: floatsize), {x=y} + {x<>y}. Proof. decide equality. Defined. Definition callconv_combine (cc1 cc2: calling_convention) : res calling_convention := - if bool_eq cc1.(cc_vararg) cc2.(cc_vararg) then + if option_eq Z.eq_dec cc1.(cc_vararg) cc2.(cc_vararg) then OK {| cc_vararg := cc1.(cc_vararg); cc_unproto := cc1.(cc_unproto) && cc2.(cc_unproto); cc_structret := cc1.(cc_structret) |} @@ -409,8 +410,8 @@ Inductive wt_rvalue : expr -> Prop := wt_rvalue (Eparen r tycast ty) with wt_lvalue : expr -> Prop := - | wt_Eloc: forall b ofs ty, - wt_lvalue (Eloc b ofs ty) + | wt_Eloc: forall b ofs bf ty, + wt_lvalue (Eloc b ofs bf ty) | wt_Evar: forall x ty, e!x = Some ty -> wt_lvalue (Evar x ty) @@ -439,7 +440,7 @@ Definition wt_expr_kind (k: kind) (a: expr) := Definition expr_kind (a: expr) : kind := match a with - | Eloc _ _ _ => LV + | Eloc _ _ _ _ => LV | Evar _ _ => LV | Ederef _ _ => LV | Efield _ _ _ => LV @@ -537,9 +538,9 @@ Inductive wt_program : program -> Prop := wt_fundef p.(prog_comp_env) e fd) -> wt_program p. -Hint Constructors wt_val wt_rvalue wt_lvalue wt_stmt wt_lblstmts: ty. -Hint Extern 1 (wt_int _ _ _) => exact I: ty. -Hint Extern 1 (wt_int _ _ _) => reflexivity: ty. +Global Hint Constructors wt_val wt_rvalue wt_lvalue wt_stmt wt_lblstmts: ty. +Global Hint Extern 1 (wt_int _ _ _) => exact I: ty. +Global Hint Extern 1 (wt_int _ _ _) => reflexivity: ty. Ltac DestructCases := match goal with @@ -595,7 +596,7 @@ Fixpoint check_arguments (el: exprlist) (tyl: typelist) : res unit := Definition check_rval (e: expr) : res unit := match e with - | Eloc _ _ _ | Evar _ _ | Ederef _ _ | Efield _ _ _ => + | Eloc _ _ _ _ | Evar _ _ | Ederef _ _ | Efield _ _ _ => Error (msg "not a r-value") | _ => OK tt @@ -603,7 +604,7 @@ Definition check_rval (e: expr) : res unit := Definition check_lval (e: expr) : res unit := match e with - | Eloc _ _ _ | Evar _ _ | Ederef _ _ | Efield _ _ _ => + | Eloc _ _ _ _ | Evar _ _ | Ederef _ _ | Efield _ _ _ => OK tt | _ => Error (msg "not a l-value") @@ -845,7 +846,7 @@ Fixpoint retype_expr (ce: composite_env) (e: typenv) (a: expr) : res expr := do r1' <- retype_expr ce e r1; do rl' <- retype_exprlist ce e rl; ecall r1' rl' | Ebuiltin ef tyargs rl tyres => do rl' <- retype_exprlist ce e rl; ebuiltin ef tyargs rl' tyres - | Eloc _ _ _ => + | Eloc _ _ _ _ => Error (msg "Eloc in source") | Eparen _ _ _ => Error (msg "Eparen in source") @@ -955,7 +956,7 @@ Proof. destruct (classify_bool t); congruence. Qed. -Hint Resolve check_cast_sound check_bool_sound: ty. +Global Hint Resolve check_cast_sound check_bool_sound: ty. Lemma check_arguments_sound: forall el tl x, check_arguments el tl = OK x -> wt_arguments el tl. @@ -983,6 +984,7 @@ Lemma binarith_type_cast: forall t1 t2 m t, binarith_type t1 t2 m = OK t -> wt_cast t1 t /\ wt_cast t2 t. Proof. +Local Transparent Ctypes.intsize_eq. unfold wt_cast, binarith_type, classify_binarith; intros; DestructCases; simpl; split; try congruence; try (destruct Archi.ptr64; congruence). @@ -1428,8 +1430,8 @@ Lemma pres_cast_int_int: forall sz sg n, wt_int (cast_int_int sz sg n) sz sg. Proof. intros. unfold cast_int_int. destruct sz; simpl. -- destruct sg. apply Int.sign_ext_idem; omega. apply Int.zero_ext_idem; omega. -- destruct sg. apply Int.sign_ext_idem; omega. apply Int.zero_ext_idem; omega. +- destruct sg. apply Int.sign_ext_idem; lia. apply Int.zero_ext_idem; lia. +- destruct sg. apply Int.sign_ext_idem; lia. apply Int.zero_ext_idem; lia. - auto. - destruct (Int.eq n Int.zero); auto. Qed. @@ -1616,12 +1618,12 @@ Proof. unfold access_mode, Val.load_result. remember Archi.ptr64 as ptr64. intros until v; intros AC. destruct ty; simpl in AC; try discriminate AC. - destruct i; [destruct s|destruct s|idtac|idtac]; inv AC; simpl. - destruct v; auto with ty. constructor; red. apply Int.sign_ext_idem; omega. - destruct v; auto with ty. constructor; red. apply Int.zero_ext_idem; omega. - destruct v; auto with ty. constructor; red. apply Int.sign_ext_idem; omega. - destruct v; auto with ty. constructor; red. apply Int.zero_ext_idem; omega. + destruct v; auto with ty. constructor; red. apply Int.sign_ext_idem; lia. + destruct v; auto with ty. constructor; red. apply Int.zero_ext_idem; lia. + destruct v; auto with ty. constructor; red. apply Int.sign_ext_idem; lia. + destruct v; auto with ty. constructor; red. apply Int.zero_ext_idem; lia. destruct Archi.ptr64 eqn:SF; destruct v; auto with ty. - destruct v; auto with ty. constructor; red. apply Int.zero_ext_idem; omega. + destruct v; auto with ty. constructor; red. apply Int.zero_ext_idem; lia. - inv AC. destruct Archi.ptr64 eqn:SF; destruct v; auto with ty. - destruct f; inv AC; destruct v; auto with ty. - inv AC. unfold Mptr. destruct Archi.ptr64 eqn:SF; destruct v; auto with ty. @@ -1637,16 +1639,16 @@ Proof. destruct ty; simpl in ACC; try discriminate. - destruct i; [destruct s|destruct s|idtac|idtac]; inv ACC; unfold decode_val. destruct (proj_bytes vl); auto with ty. - constructor; red. apply Int.sign_ext_idem; omega. + constructor; red. apply Int.sign_ext_idem; lia. destruct (proj_bytes vl); auto with ty. - constructor; red. apply Int.zero_ext_idem; omega. + constructor; red. apply Int.zero_ext_idem; lia. destruct (proj_bytes vl); auto with ty. - constructor; red. apply Int.sign_ext_idem; omega. + constructor; red. apply Int.sign_ext_idem; lia. destruct (proj_bytes vl); auto with ty. - constructor; red. apply Int.zero_ext_idem; omega. + constructor; red. apply Int.zero_ext_idem; lia. destruct (proj_bytes vl). auto with ty. destruct Archi.ptr64 eqn:SF; auto with ty. destruct (proj_bytes vl); auto with ty. - constructor; red. apply Int.zero_ext_idem; omega. + constructor; red. apply Int.zero_ext_idem; lia. - inv ACC. unfold decode_val. destruct (proj_bytes vl). auto with ty. destruct Archi.ptr64 eqn:SF; auto with ty. - destruct f; inv ACC; unfold decode_val; destruct (proj_bytes vl); auto with ty. @@ -1655,9 +1657,31 @@ Proof. unfold Mptr in *. destruct Archi.ptr64 eqn:SF; auto with ty. Qed. +Remark wt_bitfield_normalize: forall sz sg width sg1 n, + 0 < width <= bitsize_intsize sz -> + sg1 = (if zlt width (bitsize_intsize sz) then Signed else sg) -> + wt_int (bitfield_normalize sz sg width n) sz sg1. +Proof. + intros. destruct sz; cbn in *. + + destruct sg. + * replace sg1 with Signed by (destruct zlt; auto). + apply Int.sign_ext_widen; lia. + * subst sg1; destruct zlt. + ** apply Int.sign_zero_ext_widen; lia. + ** apply Int.zero_ext_widen; lia. + + destruct sg. + * replace sg1 with Signed by (destruct zlt; auto). + apply Int.sign_ext_widen; lia. + * subst sg1; destruct zlt. + ** apply Int.sign_zero_ext_widen; lia. + ** apply Int.zero_ext_widen; lia. + + auto. + + apply Int.zero_ext_widen; lia. +Qed. + Lemma wt_deref_loc: - forall ge ty m b ofs t v, - deref_loc ge ty m b ofs t v -> + forall ge ty m b ofs bf t v, + deref_loc ge ty m b ofs bf t v -> wt_val v ty. Proof. induction 1. @@ -1679,6 +1703,19 @@ Proof. destruct ty; simpl in H; try discriminate; auto with ty. destruct i; destruct s; discriminate. destruct f; discriminate. +- (* bitfield *) + inv H. constructor. + apply wt_bitfield_normalize. lia. auto. +Qed. + +Lemma wt_assign_loc: + forall ge ty m b ofs bf v t m' v', + assign_loc ge ty m b ofs bf v t m' v' -> + wt_val v ty -> wt_val v' ty. +Proof. + induction 1; intros; auto. +- inv H. constructor. + apply wt_bitfield_normalize. lia. auto. Qed. Lemma wt_cast_self: @@ -1769,7 +1806,7 @@ Proof. - (* condition *) constructor. destruct b; auto. destruct b; auto. red; auto. - (* sizeof *) unfold size_t, Vptrofs; destruct Archi.ptr64; constructor; auto with ty. - (* alignof *) unfold size_t, Vptrofs; destruct Archi.ptr64; constructor; auto with ty. -- (* assign *) inversion H5. constructor. eapply pres_sem_cast; eauto. +- (* assign *) inversion H5. constructor. eapply wt_assign_loc; eauto. eapply pres_sem_cast; eauto. - (* assignop *) subst tyres l r. constructor. auto. constructor. constructor. eapply wt_deref_loc; eauto. auto. auto. auto. diff --git a/cfrontend/Initializers.v b/cfrontend/Initializers.v index 77d6cfea..32fbf46b 100644 --- a/cfrontend/Initializers.v +++ b/cfrontend/Initializers.v @@ -114,18 +114,23 @@ Fixpoint constval (ce: composite_env) (a: expr) : res val := | Ederef r ty => constval ce r | Efield l f ty => - match typeof l with - | Tstruct id _ => - do co <- lookup_composite ce id; - do delta <- field_offset ce f (co_members co); - do v <- constval ce l; + do (delta, bf) <- + match typeof l with + | Tstruct id _ => + do co <- lookup_composite ce id; field_offset ce f (co_members co) + | Tunion id _ => + do co <- lookup_composite ce id; union_field_offset ce f (co_members co) + | _ => + Error (msg "ill-typed field access") + end; + do v <- constval ce l; + match bf with + | Full => OK (if Archi.ptr64 then Val.addl v (Vlong (Int64.repr delta)) else Val.add v (Vint (Int.repr delta))) - | Tunion id _ => - constval ce l - | _ => - Error(msg "ill-typed field access") + | Bits _ _ _ _ => + Error(msg "taking the address of a bitfield") end | Eparen r tycast ty => do v <- constval ce r; do_cast v (typeof r) tycast @@ -138,6 +143,183 @@ Fixpoint constval (ce: composite_env) (a: expr) : res val := Definition constval_cast (ce: composite_env) (a: expr) (ty: type): res val := do v <- constval ce a; do_cast v (typeof a) ty. +(** * Building and recording initialization data *) + +(** The following [state] type is the output of the translation of + initializers. It contains the list of initialization data + generated so far, the corresponding position in bytes, and the + total size expected for the final initialization data, in bytes. *) + +Record state : Type := { + init: list init_data; (**r reversed *) + curr: Z; (**r current position for head of [init] *) + total_size: Z (**r total expected size *) +}. + +(** A state [s] can also be viewed as a memory block. The size of + the block is [s.(total_size)], it is initialized with zero bytes, + then filled with the initialization data [rev s.(init)] like + [Genv.store_init_data_list] does. *) + +Definition initial_state (sz: Z) : state := + {| init := nil; curr := 0; total_size := sz |}. + +(** We now define abstract "store" operations that operate + directly on the state, but whose behavior mimic those of + storing in the corresponding memory block. To initialize + bitfields, we also need an abstract "load" operation. + The operations are optimized for stores that occur at increasing + positions, like those that take place during initialization. *) + +(** Initialization from bytes *) + +Definition int_of_byte (b: byte) := Int.repr (Byte.unsigned b). + +Definition Init_byte (b: byte) := Init_int8 (int_of_byte b). + +(** Add a list of bytes to a reversed initialization data list. *) + +Fixpoint add_rev_bytes (l: list byte) (il: list init_data) := + match l with + | nil => il + | b :: l => add_rev_bytes l (Init_byte b :: il) + end. + +(** Add [n] zero bytes to an initialization data list. *) + +Definition add_zeros (n: Z) (il: list init_data) := + Z.iter n (fun l => Init_int8 Int.zero :: l) il. + +(** Make sure the [depth] positions at the top of [il] are bytes, + that is, [Init_int8] items. Other numerical items are split + into bytes. [Init_addrof] items cannot be split and result in + an error. *) + +Fixpoint normalize (il: list init_data) (depth: Z) : res (list init_data) := + if zle depth 0 then OK il else + match il with + | nil => + Error (msg "normalize: empty list") + | Init_int8 n :: il => + do il' <- normalize il (depth - 1); + OK (Init_int8 n :: il') + | Init_int16 n :: il => + do il' <- normalize il (depth - 2); + OK (add_rev_bytes (encode_int 2%nat (Int.unsigned n)) il') + | Init_int32 n :: il => + do il' <- normalize il (depth - 4); + OK (add_rev_bytes (encode_int 4%nat (Int.unsigned n)) il') + | Init_int64 n :: il => + do il' <- normalize il (depth - 8); + OK (add_rev_bytes (encode_int 8%nat (Int64.unsigned n)) il') + | Init_float32 f :: il => + do il' <- normalize il (depth - 4); + OK (add_rev_bytes (encode_int 4%nat (Int.unsigned (Float32.to_bits f))) il') + | Init_float64 f :: il => + do il' <- normalize il (depth - 8); + OK (add_rev_bytes (encode_int 8%nat (Int64.unsigned (Float.to_bits f))) il') + | Init_addrof _ _ :: il => + Error (msg "normalize: Init_addrof") + | Init_space n :: il => + let n := Z.max 0 n in + if zle n depth then + do il' <- normalize il (depth - n); + OK (add_zeros n il') + else + OK (add_zeros depth (Init_space (n - depth) :: il)) + end. + +(** Split [il] into [depth] bytes and the initialization list that follows. + The bytes are returned reversed. *) + +Fixpoint decompose_rec (accu: list byte) (il: list init_data) (depth: Z) : res (list byte * list init_data) := + if zle depth 0 then OK (accu, il) else + match il with + | Init_int8 n :: il => decompose_rec (Byte.repr (Int.unsigned n) :: accu) il (depth - 1) + | _ => Error (msg "decompose: wrong shape") + end. + +Definition decompose (il: list init_data) (depth: Z) : res (list byte * list init_data) := + decompose_rec nil il depth. + +(** Decompose an initialization list in three parts: + [depth] bytes (reversed), [sz] bytes (reversed), + and the remainder of the initialization list. *) + +Definition trisection (il: list init_data) (depth sz: Z) : res (list byte * list byte * list init_data) := + do il0 <- normalize il (depth + sz); + do (bytes1, il1) <- decompose il0 depth; + do (bytes2, il2) <- decompose il1 sz; + OK (bytes1, bytes2, il2). + +(** Graphically: [rev il] is equal to +<< + <---sz---><--depth--> ++----------------+---------+---------+ +| | | | ++----------------+---------+---------+ + rev il2 bytes2 bytes1 +>> +*) + +(** Add padding if necessary so that position [pos] is within the state. *) + +Definition pad_to (s: state) (pos: Z) : state := + if zle pos s.(curr) + then s + else {| init := Init_space (pos - s.(curr)) :: s.(init); + curr := pos; + total_size := s.(total_size) |}. + +(** Store the initialization data [i] at position [pos] in state [s]. *) + +Definition store_data (s: state) (pos: Z) (i: init_data) : res state := + let sz := init_data_size i in + assertion (zle 0 pos && zle (pos + sz) s.(total_size)); + if zle s.(curr) pos then + OK {| init := i :: (if zlt s.(curr) pos + then Init_space (pos - s.(curr)) :: s.(init) + else s.(init)); + curr := pos + sz; + total_size := s.(total_size) |} + else + let s' := pad_to s (pos + sz) in + do x3 <- trisection s'.(init) (s'.(curr) - (pos + sz)) sz; + let '(bytes1, _, il2) := x3 in + OK {| init := add_rev_bytes bytes1 (i :: il2); + curr := s'.(curr); + total_size := s'.(total_size) |}. + +(** Store the integer [n] of size [isz] at position [pos] in state [s]. *) + +Definition init_data_for_carrier (isz: intsize) (n: int) := + match isz with + | I8 | IBool => Init_int8 n + | I16 => Init_int16 n + | I32 => Init_int32 n + end. + +Definition store_int (s: state) (pos: Z) (isz: intsize) (n: int) : res state := + store_data s pos (init_data_for_carrier isz n). + +(** Load the integer of size [isz] at position [pos] in state [s]. *) + +Definition load_int (s: state) (pos: Z) (isz: intsize) : res int := + let chunk := chunk_for_carrier isz in + let sz := size_chunk chunk in + assertion (zle 0 pos && zle (pos + sz) s.(total_size)); + let s' := pad_to s (pos + sz) in + do x3 <- trisection s'.(init) (s'.(curr) - (pos + sz)) sz; + let '(_, bytes2, _) := x3 in + OK (Int.repr (decode_int bytes2)). + +(** Extract the final initialization data from a state. *) + +Definition init_data_list_of_state (s: state) : res (list init_data) := + assertion (zle s.(curr) s.(total_size)); + let s' := pad_to s s.(total_size) in + OK (List.rev' s'.(init)). + (** * Translation of initializers *) Inductive initializer := @@ -149,6 +331,11 @@ with initializer_list := | Init_nil | Init_cons (i: initializer) (il: initializer_list). +Definition length_initializer_list (il: initializer_list) := + let fix length (accu: Z) (il: initializer_list) : Z := + match il with Init_nil => accu | Init_cons _ il => length (Z.succ accu) il end + in length 0 il. + (** Translate an initializing expression [a] for a scalar variable of type [ty]. Return the corresponding initialization datum. *) @@ -170,69 +357,116 @@ Definition transl_init_single (ce: composite_env) (ty: type) (a: expr) : res ini | _, _ => Error (msg "type mismatch in initializer") end. -(** Translate an initializer [i] for a variable of type [ty]. - [transl_init ce ty i] returns the appropriate list of initialization data. - The intermediate functions [transl_init_rec], [transl_init_array] - and [transl_init_struct] append initialization data to the given - list [k], and build the list of initialization data in reverse order, - so as to remain tail-recursive. *) +(** Initialize a bitfield [Bits sz sg p w] with expression [a]. *) -Definition padding (frm to: Z) (k: list init_data) : list init_data := - if zlt frm to then Init_space (to - frm) :: k else k. +Definition transl_init_bitfield (ce: composite_env) (s: state) + (ty: type) (sz: intsize) (p w: Z) + (i: initializer) (pos: Z) : res state := + match i with + | Init_single a => + do v <- constval_cast ce a ty; + match v with + | Vint n => + do c <- load_int s pos sz; + let c' := Int.bitfield_insert (first_bit sz p w) w c n in + store_int s pos sz c' + | Vundef => + Error (msg "undefined operation in bitfield initializer") + | _ => + Error (msg "type mismatch in bitfield initializer") + end + | _ => + Error (msg "bitfield initialized by composite initializer") + end. + +(** Padding bitfields and bitfields with zero width are not initialized. *) + +Definition member_not_initialized (m: member) : bool := + match m with + | Member_plain _ _ => false + | Member_bitfield _ _ _ _ w p => p || zle w 0 + end. -Fixpoint transl_init_rec (ce: composite_env) (ty: type) (i: initializer) - (k: list init_data) {struct i} : res (list init_data) := +(** Translate an initializer [i] for a variable of type [ty] + and store the corresponding list of initialization data in state [s] + at position [pos]. Return the updated state. *) + +Fixpoint transl_init_rec (ce: composite_env) (s: state) + (ty: type) (i: initializer) (pos: Z) + {struct i} : res state := match i, ty with | Init_single a, _ => - do d <- transl_init_single ce ty a; OK (d :: k) + do d <- transl_init_single ce ty a; store_data s pos d | Init_array il, Tarray tyelt nelt _ => - transl_init_array ce tyelt il (Z.max 0 nelt) k + assertion (zle (length_initializer_list il) (Z.max 0 nelt)); + transl_init_array ce s tyelt il pos | Init_struct il, Tstruct id _ => do co <- lookup_composite ce id; match co_su co with - | Struct => transl_init_struct ce ty (co_members co) il 0 k + | Struct => transl_init_struct ce s (co_members co) il pos 0 | Union => Error (MSG "struct/union mismatch on " :: CTX id :: nil) end | Init_union f i1, Tunion id _ => do co <- lookup_composite ce id; match co_su co with | Struct => Error (MSG "union/struct mismatch on " :: CTX id :: nil) - | Union => - do ty1 <- field_type f (co_members co); - do k1 <- transl_init_rec ce ty1 i1 k; - OK (padding (sizeof ce ty1) (sizeof ce ty) k1) + | Union => do ty1 <- field_type f (co_members co); + do (delta, layout) <- union_field_offset ce f (co_members co); + match layout with + | Full => + transl_init_rec ce s ty1 i1 (pos + delta) + | Bits sz sg p w => + transl_init_bitfield ce s ty1 sz p w i1 (pos + delta) + end end | _, _ => Error (msg "wrong type for compound initializer") end -with transl_init_array (ce: composite_env) (ty: type) (il: initializer_list) (sz: Z) - (k: list init_data) {struct il} : res (list init_data) := +with transl_init_array (ce: composite_env) (s: state) + (tyelt: type) (il: initializer_list) (pos: Z) + {struct il} : res state := match il with | Init_nil => - if zeq sz 0 then OK k - else if zle 0 sz then OK (Init_space (sz * sizeof ce ty) :: k) - else Error (msg "wrong number of elements in array initializer") + OK s | Init_cons i1 il' => - do k1 <- transl_init_rec ce ty i1 k; - transl_init_array ce ty il' (sz - 1) k1 + do s1 <- transl_init_rec ce s tyelt i1 pos; + transl_init_array ce s1 tyelt il' (pos + sizeof ce tyelt) end -with transl_init_struct (ce: composite_env) (ty: type) - (fl: members) (il: initializer_list) (pos: Z) - (k: list init_data) - {struct il} : res (list init_data) := - match il, fl with - | Init_nil, nil => - OK (padding pos (sizeof ce ty) k) - | Init_cons i1 il', (_, ty1) :: fl' => - let pos1 := align pos (alignof ce ty1) in - do k1 <- transl_init_rec ce ty1 i1 (padding pos pos1 k); - transl_init_struct ce ty fl' il' (pos1 + sizeof ce ty1) k1 - | _, _ => - Error (msg "wrong number of elements in struct initializer") +with transl_init_struct (ce: composite_env) (s: state) + (ms: members) (il: initializer_list) + (base: Z) (pos: Z) + {struct il} : res state := + match il with + | Init_nil => + OK s + | Init_cons i1 il' => + let fix init (ms: members) (pos: Z) {struct ms} : res state := + match ms with + | nil => + Error (msg "too many elements in struct initializer") + | m :: ms' => + if member_not_initialized m then + init ms' (next_field ce pos m) + else + do (delta, layout) <- layout_field ce pos m; + do s1 <- + match layout with + | Full => + transl_init_rec ce s (type_member m) i1 (base + delta) + | Bits sz sg p w => + transl_init_bitfield ce s (type_member m) sz p w i1 (base + delta) + end; + transl_init_struct ce s1 ms' il' base (next_field ce pos m) + end in + init ms pos end. +(** The entry point. *) + Definition transl_init (ce: composite_env) (ty: type) (i: initializer) : res (list init_data) := - do k <- transl_init_rec ce ty i nil; OK (List.rev' k). + let s0 := initial_state (sizeof ce ty) in + do s1 <- transl_init_rec ce s0 ty i 0; + init_data_list_of_state s1. diff --git a/cfrontend/Initializersproof.v b/cfrontend/Initializersproof.v index 272b929f..00f7e331 100644 --- a/cfrontend/Initializersproof.v +++ b/cfrontend/Initializersproof.v @@ -12,7 +12,7 @@ (** Compile-time evaluation of initializers for global C variables. *) -Require Import Coqlib Maps. +Require Import Zwf Coqlib Maps. Require Import Errors Integers Floats Values AST Memory Globalenvs Events Smallstep. Require Import Ctypes Cop Csyntax Csem. Require Import Initializers. @@ -30,7 +30,7 @@ Variable ge: genv. Fixpoint simple (a: expr) : Prop := match a with - | Eloc _ _ _ => True + | Eloc _ _ _ _ => True | Evar _ _ => True | Ederef r _ => simple r | Efield l1 _ _ => simple l1 @@ -65,38 +65,38 @@ Section SIMPLE_EXPRS. Variable e: env. Variable m: mem. -Inductive eval_simple_lvalue: expr -> block -> ptrofs -> Prop := - | esl_loc: forall b ofs ty, - eval_simple_lvalue (Eloc b ofs ty) b ofs +Inductive eval_simple_lvalue: expr -> block -> ptrofs -> bitfield -> Prop := + | esl_loc: forall b ofs bf ty, + eval_simple_lvalue (Eloc b ofs bf ty) b ofs bf | esl_var_local: forall x ty b, e!x = Some(b, ty) -> - eval_simple_lvalue (Evar x ty) b Ptrofs.zero + eval_simple_lvalue (Evar x ty) b Ptrofs.zero Full | esl_var_global: forall x ty b, e!x = None -> Genv.find_symbol ge x = Some b -> - eval_simple_lvalue (Evar x ty) b Ptrofs.zero + eval_simple_lvalue (Evar x ty) b Ptrofs.zero Full | esl_deref: forall r ty b ofs, eval_simple_rvalue r (Vptr b ofs) -> - eval_simple_lvalue (Ederef r ty) b ofs - | esl_field_struct: forall r f ty b ofs id co a delta, + eval_simple_lvalue (Ederef r ty) b ofs Full + | esl_field_struct: forall r f ty b ofs id co a delta bf, eval_simple_rvalue r (Vptr b ofs) -> - typeof r = Tstruct id a -> ge.(genv_cenv)!id = Some co -> field_offset ge f (co_members co) = OK delta -> - eval_simple_lvalue (Efield r f ty) b (Ptrofs.add ofs (Ptrofs.repr delta)) - | esl_field_union: forall r f ty b ofs id a, + typeof r = Tstruct id a -> ge.(genv_cenv)!id = Some co -> field_offset ge f (co_members co) = OK (delta, bf) -> + eval_simple_lvalue (Efield r f ty) b (Ptrofs.add ofs (Ptrofs.repr delta)) bf + | esl_field_union: forall r f ty b ofs id co a delta bf, eval_simple_rvalue r (Vptr b ofs) -> - typeof r = Tunion id a -> - eval_simple_lvalue (Efield r f ty) b ofs + typeof r = Tunion id a -> ge.(genv_cenv)!id = Some co -> union_field_offset ge f (co_members co) = OK (delta, bf) -> + eval_simple_lvalue (Efield r f ty) b (Ptrofs.add ofs (Ptrofs.repr delta)) bf with eval_simple_rvalue: expr -> val -> Prop := | esr_val: forall v ty, eval_simple_rvalue (Eval v ty) v - | esr_rvalof: forall b ofs l ty v, - eval_simple_lvalue l b ofs -> + | esr_rvalof: forall b ofs bf l ty v, + eval_simple_lvalue l b ofs bf -> ty = typeof l -> - deref_loc ge ty m b ofs E0 v -> + deref_loc ge ty m b ofs bf E0 v -> eval_simple_rvalue (Evalof l ty) v | esr_addrof: forall b ofs l ty, - eval_simple_lvalue l b ofs -> + eval_simple_lvalue l b ofs Full -> eval_simple_rvalue (Eaddrof l ty) (Vptr b ofs) | esr_unop: forall op r1 ty v1 v, eval_simple_rvalue r1 v1 -> @@ -153,7 +153,7 @@ End SIMPLE_EXPRS. Definition compat_eval (k: kind) (e: env) (a a': expr) (m: mem) : Prop := typeof a = typeof a' /\ match k with - | LV => forall b ofs, eval_simple_lvalue e m a' b ofs -> eval_simple_lvalue e m a b ofs + | LV => forall b ofs bf, eval_simple_lvalue e m a' b ofs bf -> eval_simple_lvalue e m a b ofs bf | RV => forall v, eval_simple_rvalue e m a' v -> eval_simple_rvalue e m a v end. @@ -167,7 +167,7 @@ Lemma lred_compat: forall e l m l' m', lred ge e l m l' m' -> m = m' /\ compat_eval LV e l l' m. Proof. - induction 1; simpl; split; auto; split; auto; intros bx ofsx EV; inv EV. + induction 1; simpl; split; auto; split; auto; intros bx ofsx bf' EV; inv EV. apply esl_var_local; auto. apply esl_var_global; auto. constructor. constructor. @@ -365,6 +365,22 @@ Proof. intros. eapply bool_val_inj; eauto. intros. rewrite mem_empty_not_weak_valid_pointer in H2; discriminate. Qed. +Lemma add_offset_match: + forall v b ofs delta, + Val.inject inj v (Vptr b ofs) -> + Val.inject inj + (if Archi.ptr64 + then Val.addl v (Vlong (Int64.repr delta)) + else Val.add v (Vint (Int.repr delta))) + (Vptr b (Ptrofs.add ofs (Ptrofs.repr delta))). +Proof. + intros. inv H. +- rewrite Ptrofs.add_assoc. rewrite (Ptrofs.add_commut (Ptrofs.repr delta0)). + unfold Val.addl, Val.add; destruct Archi.ptr64 eqn:SF; + econstructor; eauto; rewrite ! Ptrofs.add_assoc; f_equal; f_equal; symmetry; auto with ptrofs. +- unfold Val.addl, Val.add; destruct Archi.ptr64; auto. +Qed. + (** Soundness of [constval] with respect to the big-step semantics *) Lemma constval_rvalue: @@ -374,20 +390,22 @@ Lemma constval_rvalue: constval ge a = OK v' -> Val.inject inj v' v with constval_lvalue: - forall m a b ofs, - eval_simple_lvalue empty_env m a b ofs -> + forall m a b ofs bf, + eval_simple_lvalue empty_env m a b ofs bf -> forall v', constval ge a = OK v' -> - Val.inject inj v' (Vptr b ofs). + bf = Full /\ Val.inject inj v' (Vptr b ofs). Proof. (* rvalue *) induction 1; intros vres CV; simpl in CV; try (monadInv CV). (* val *) destruct v; monadInv CV; constructor. (* rval *) - inv H1; rewrite H2 in CV; try congruence. eauto. eauto. + assert (constval ge l = OK vres) by (destruct (access_mode ty); congruence). + exploit constval_lvalue; eauto. intros [A B]. subst bf. + inv H1; rewrite H3 in CV; congruence. (* addrof *) - eauto. + eapply constval_lvalue; eauto. (* unop *) destruct (sem_unary_operation op x (typeof r1) Mem.empty) as [v1'|] eqn:E; inv EQ0. exploit (sem_unary_operation_inj inj Mem.empty m). @@ -438,28 +456,31 @@ Proof. (* lvalue *) induction 1; intros v' CV; simpl in CV; try (monadInv CV). (* var local *) - unfold empty_env in H. rewrite PTree.gempty in H. congruence. + split; auto. unfold empty_env in H. rewrite PTree.gempty in H. congruence. (* var_global *) - econstructor. unfold inj. rewrite H0. eauto. auto. + split; auto. econstructor. unfold inj. rewrite H0. eauto. auto. (* deref *) - eauto. + split; eauto. (* field struct *) - rewrite H0 in CV. monadInv CV. unfold lookup_composite in EQ; rewrite H1 in EQ; monadInv EQ. - exploit constval_rvalue; eauto. intro MV. inv MV. - replace x0 with delta by congruence. rewrite Ptrofs.add_assoc. rewrite (Ptrofs.add_commut (Ptrofs.repr delta0)). - simpl; destruct Archi.ptr64 eqn:SF; - econstructor; eauto; rewrite ! Ptrofs.add_assoc; f_equal; f_equal; symmetry; auto with ptrofs. - destruct Archi.ptr64; auto. + rewrite H0 in EQ. monadInv EQ. destruct x0; monadInv EQ2. + unfold lookup_composite in EQ0; rewrite H1 in EQ0; monadInv EQ0. + exploit constval_rvalue; eauto. intro MV. + split. congruence. + replace x with delta by congruence. + apply (add_offset_match _ _ _ _ MV). (* field union *) - rewrite H0 in CV. eauto. + rewrite H0 in EQ. monadInv EQ. destruct x0; monadInv EQ2. + unfold lookup_composite in EQ0; rewrite H1 in EQ0; monadInv EQ0. + exploit constval_rvalue; eauto. intro MV. + split. congruence. + replace x with delta by congruence. + apply (add_offset_match _ _ _ _ MV). Qed. Lemma constval_simple: forall a v, constval ge a = OK v -> simple a. Proof. induction a; simpl; intros vx CV; try (monadInv CV); eauto. - destruct (typeof a); discriminate || eauto. - monadInv CV. eauto. destruct (access_mode ty); discriminate || eauto. intuition eauto. Qed. @@ -476,420 +497,854 @@ Proof. intros [A [B C]]. intuition. eapply constval_rvalue; eauto. Qed. -(** * Relational specification of the translation of initializers *) - -Definition tr_padding (frm to: Z) : list init_data := - if zlt frm to then Init_space (to - frm) :: nil else nil. - -Inductive tr_init: type -> initializer -> list init_data -> Prop := - | tr_init_sgl: forall ty a d, - transl_init_single ge ty a = OK d -> - tr_init ty (Init_single a) (d :: nil) - | tr_init_arr: forall tyelt nelt attr il d, - tr_init_array tyelt il (Z.max 0 nelt) d -> - tr_init (Tarray tyelt nelt attr) (Init_array il) d - | tr_init_str: forall id attr il co d, - lookup_composite ge id = OK co -> co_su co = Struct -> - tr_init_struct (Tstruct id attr) (co_members co) il 0 d -> - tr_init (Tstruct id attr) (Init_struct il) d - | tr_init_uni: forall id attr f i1 co ty1 d, - lookup_composite ge id = OK co -> co_su co = Union -> field_type f (co_members co) = OK ty1 -> - tr_init ty1 i1 d -> - tr_init (Tunion id attr) (Init_union f i1) - (d ++ tr_padding (sizeof ge ty1) (sizeof ge (Tunion id attr))) - -with tr_init_array: type -> initializer_list -> Z -> list init_data -> Prop := - | tr_init_array_nil_0: forall ty, - tr_init_array ty Init_nil 0 nil - | tr_init_array_nil_pos: forall ty sz, - 0 < sz -> - tr_init_array ty Init_nil sz (Init_space (sz * sizeof ge ty) :: nil) - | tr_init_array_cons: forall ty i il sz d1 d2, - tr_init ty i d1 -> tr_init_array ty il (sz - 1) d2 -> - tr_init_array ty (Init_cons i il) sz (d1 ++ d2) - -with tr_init_struct: type -> members -> initializer_list -> Z -> list init_data -> Prop := - | tr_init_struct_nil: forall ty pos, - tr_init_struct ty nil Init_nil pos (tr_padding pos (sizeof ge ty)) - | tr_init_struct_cons: forall ty f1 ty1 fl i1 il pos d1 d2, - let pos1 := align pos (alignof ge ty1) in - tr_init ty1 i1 d1 -> - tr_init_struct ty fl il (pos1 + sizeof ge ty1) d2 -> - tr_init_struct ty ((f1, ty1) :: fl) (Init_cons i1 il) - pos (tr_padding pos pos1 ++ d1 ++ d2). - -Lemma transl_padding_spec: - forall frm to k, padding frm to k = rev (tr_padding frm to) ++ k. -Proof. - unfold padding, tr_padding; intros. - destruct (zlt frm to); auto. -Qed. - -Lemma transl_init_rec_spec: - forall i ty k res, - transl_init_rec ge ty i k = OK res -> - exists d, tr_init ty i d /\ res = rev d ++ k - -with transl_init_array_spec: - forall il ty sz k res, - transl_init_array ge ty il sz k = OK res -> - exists d, tr_init_array ty il sz d /\ res = rev d ++ k - -with transl_init_struct_spec: - forall il ty fl pos k res, - transl_init_struct ge ty fl il pos k = OK res -> - exists d, tr_init_struct ty fl il pos d /\ res = rev d ++ k. - -Proof. -Local Opaque sizeof. -- destruct i; intros until res; intros TR; simpl in TR. -+ monadInv TR. exists (x :: nil); split; auto. constructor; auto. -+ destruct ty; try discriminate. - destruct (transl_init_array_spec _ _ _ _ _ TR) as (d & A & B). - exists d; split; auto. constructor; auto. -+ destruct ty; try discriminate. monadInv TR. destruct (co_su x) eqn:SU; try discriminate. - destruct (transl_init_struct_spec _ _ _ _ _ _ EQ0) as (d & A & B). - exists d; split; auto. econstructor; eauto. -+ destruct ty; try discriminate. - monadInv TR. destruct (co_su x) eqn:SU; monadInv EQ0. - destruct (transl_init_rec_spec _ _ _ _ EQ0) as (d & A & B). - exists (d ++ tr_padding (sizeof ge x0) (sizeof ge (Tunion i0 a))); split. - econstructor; eauto. - rewrite rev_app_distr, app_ass, B. apply transl_padding_spec. - -- destruct il; intros until res; intros TR; simpl in TR. -+ destruct (zeq sz 0). - inv TR. exists (@nil init_data); split; auto. constructor. - destruct (zle 0 sz). - inv TR. econstructor; split. constructor. omega. auto. - discriminate. -+ monadInv TR. - destruct (transl_init_rec_spec _ _ _ _ EQ) as (d1 & A1 & B1). - destruct (transl_init_array_spec _ _ _ _ _ EQ0) as (d2 & A2 & B2). - exists (d1 ++ d2); split. econstructor; eauto. - subst res x. rewrite rev_app_distr, app_ass. auto. +(** * Correctness of operations over the initialization state *) + +(** ** Properties of the in-memory bytes denoted by initialization data *) + +Local Notation boid := (Genv.bytes_of_init_data (genv_genv ge)). +Local Notation boidl := (Genv.bytes_of_init_data_list (genv_genv ge)). + +Lemma boidl_app: forall il2 il1, + boidl (il1 ++ il2) = boidl il1 ++ boidl il2. +Proof. + induction il1 as [ | il il1]; simpl. auto. rewrite app_ass. f_equal; auto. +Qed. + +Corollary boidl_rev_cons: forall i il, + boidl (rev il ++ i :: nil) = boidl (rev il) ++ boid i. +Proof. + intros. rewrite boidl_app. simpl. rewrite <- app_nil_end. auto. +Qed. + +Definition byte_of_int (n: int) := Byte.repr (Int.unsigned n). + +Lemma byte_of_int_of_byte: forall b, byte_of_int (int_of_byte b) = b. +Proof. + intros. unfold int_of_byte, byte_of_int. + rewrite Int.unsigned_repr, Byte.repr_unsigned. auto. + assert(Byte.max_unsigned < Int.max_unsigned) by reflexivity. + generalize (Byte.unsigned_range_2 b). lia. +Qed. + +Lemma inj_bytes_1: forall n, + inj_bytes (encode_int 1 n) = Byte (Byte.repr n) :: nil. +Proof. + intros. unfold encode_int, bytes_of_int, rev_if_be. destruct Archi.big_endian; auto. +Qed. + +Lemma inj_bytes_byte: forall b, + inj_bytes (encode_int 1 (Int.unsigned (int_of_byte b))) = Byte b :: nil. +Proof. + intros. rewrite inj_bytes_1. do 2 f_equal. apply byte_of_int_of_byte. +Qed. + +Lemma boidl_init_ints8: forall l, + boidl (map Init_int8 l) = inj_bytes (map byte_of_int l). +Proof. + induction l as [ | i l]; simpl. auto. rewrite inj_bytes_1; simpl. f_equal; auto. +Qed. + +Lemma boidl_init_bytes: forall l, + boidl (map Init_byte l) = inj_bytes l. +Proof. + induction l as [ | b l]; simpl. auto. rewrite inj_bytes_byte, IHl. auto. +Qed. + +Lemma boidl_ints8: forall i n, + boidl (repeat (Init_int8 i) n) = repeat (Byte (byte_of_int i)) n. +Proof. + induction n; simpl. auto. rewrite inj_bytes_1. simpl; f_equal; auto. +Qed. + +(** ** Properties of operations over list of initialization data *) + +Lemma add_rev_bytes_spec: forall l il, + add_rev_bytes l il = List.map Init_byte (List.rev l) ++ il. +Proof. + induction l as [ | b l]; intros; simpl. +- auto. +- rewrite IHl. rewrite map_app. simpl. rewrite app_ass. auto. +Qed. + +Lemma add_rev_bytes_spec': forall l il, + List.rev (add_rev_bytes l il) = List.rev il ++ List.map Init_byte l. +Proof. + intros. rewrite add_rev_bytes_spec. rewrite rev_app_distr, map_rev, rev_involutive. auto. +Qed. + +Lemma add_zeros_spec: forall n il, + 0 <= n -> + add_zeros n il = List.repeat (Init_int8 Int.zero) (Z.to_nat n) ++ il. +Proof. + intros. + unfold add_zeros; rewrite iter_nat_of_Z by auto; rewrite Zabs2Nat.abs_nat_nonneg by auto. + induction (Z.to_nat n); simpl. auto. f_equal; auto. +Qed. + +Lemma decompose_spec: forall il depth bl il', + decompose il depth = OK (bl, il') -> + exists nl, il = List.map Init_int8 nl ++ il' + /\ bl = List.map byte_of_int (rev nl) + /\ List.length nl = Z.to_nat depth. +Proof. + assert (REC: forall il accu depth bl il', + decompose_rec accu il depth = OK (bl, il') -> + exists nl, il = List.map Init_int8 nl ++ il' + /\ bl = List.map byte_of_int (rev nl) ++ accu + /\ List.length nl = Z.to_nat depth). + { induction il as [ | i il ]; intros until il'; intros D; simpl in D. + - destruct (zle depth 0); inv D. + exists (@nil int); simpl. rewrite Z_to_nat_neg by auto. auto. + - destruct (zle depth 0). + + inv D. exists (@nil int); simpl. rewrite Z_to_nat_neg by auto. auto. + + destruct i; try discriminate. + apply IHil in D; destruct D as (nl & P & Q & R). + exists (i :: nl); simpl; split. congruence. split. + rewrite map_app. simpl. rewrite app_ass. exact Q. + rewrite R, <- Z2Nat.inj_succ by lia. f_equal; lia. + } + intros. apply REC in H. destruct H as (nl & P & Q & R). rewrite app_nil_r in Q. + exists nl; auto. +Qed. + +Lemma list_repeat_app: forall (A: Type) (a: A) n2 n1, + List.repeat a n1 ++ List.repeat a n2 = List.repeat a (n1 + n2)%nat. +Proof. + induction n1; simpl; congruence. +Qed. + +Lemma list_rev_repeat: forall (A: Type) (a: A) n, + rev (List.repeat a n) = List.repeat a n. +Proof. + induction n; simpl. auto. rewrite IHn. change (a :: nil) with (repeat a 1%nat). + rewrite list_repeat_app. rewrite Nat.add_comm. auto. +Qed. + +Lemma normalize_boidl: forall il depth il', + normalize il depth = OK il' -> + boidl (rev il') = boidl (rev il). +Proof. + induction il as [ | i il]; simpl; intros depth il' AT. +- destruct (zle depth 0); inv AT. auto. +- destruct (zle depth 0). inv AT. auto. + destruct i; + try (monadInv AT; simpl; + rewrite ? add_rev_bytes_spec', ? boidl_rev_cons, ? boidl_app, ? boidl_init_bytes; + erewrite IHil by eauto; reflexivity). + set (n := Z.max 0 z) in *. destruct (zle n depth); monadInv AT. + + rewrite add_zeros_spec, rev_app_distr, ! boidl_app by lia. + erewrite IHil by eauto. f_equal. + rewrite list_rev_repeat. simpl. rewrite app_nil_r, boidl_ints8. + f_equal. unfold n. apply Z.max_case_strong; intros; auto. rewrite ! Z_to_nat_neg by lia. auto. + + rewrite add_zeros_spec, rev_app_distr, !boidl_app by lia. + simpl. rewrite boidl_rev_cons, list_rev_repeat. simpl. + rewrite app_ass, app_nil_r, !boidl_ints8. f_equal. + rewrite list_repeat_app. f_equal. rewrite <- Z2Nat.inj_add by lia. + unfold n. apply Z.max_case_strong; intros; f_equal; lia. +Qed. + +Lemma trisection_boidl: forall il depth sz bytes1 bytes2 il', + trisection il depth sz = OK (bytes1, bytes2, il') -> + boidl (rev il) = boidl (rev il') ++ inj_bytes bytes2 ++ inj_bytes bytes1 + /\ length bytes1 = Z.to_nat depth + /\ length bytes2 = Z.to_nat sz. +Proof. + unfold trisection; intros. monadInv H. + apply normalize_boidl in EQ. rewrite <- EQ. + apply decompose_spec in EQ1. destruct EQ1 as (nl1 & A1 & B1 & C1). + apply decompose_spec in EQ0. destruct EQ0 as (nl2 & A2 & B2 & C2). + split. +- rewrite A1, A2, !rev_app_distr, !boidl_app, app_ass. + rewrite <- !map_rev, !boidl_init_ints8. rewrite <- B1, <- B2. auto. +- rewrite B1, B2, !map_length, !rev_length. auto. +Qed. + +Lemma store_init_data_loadbytes: + forall m b p i m', + Genv.store_init_data ge m b p i = Some m' -> + match i with Init_space _ => False | _ => True end -> + Mem.loadbytes m' b p (init_data_size i) = Some (boid i). +Proof. + intros; destruct i; simpl in H; try apply (Mem.loadbytes_store_same _ _ _ _ _ _ H). +- contradiction. +- rewrite Genv.init_data_size_addrof. simpl. + destruct (Genv.find_symbol ge i) as [b'|]; try discriminate. + rewrite (Mem.loadbytes_store_same _ _ _ _ _ _ H). + unfold encode_val, Mptr; destruct Archi.ptr64; reflexivity. +Qed. + +(** ** Validity and size of initialization data *) + +Definition idvalid (i: init_data) : Prop := + match i with + | Init_addrof symb ofs => exists b, Genv.find_symbol ge symb = Some b + | _ => True + end. + +Fixpoint idlvalid (p: Z) (il: list init_data) {struct il} : Prop := + match il with + | nil => True + | i1 :: il => + (Genv.init_data_alignment i1 | p) + /\ idvalid i1 + /\ idlvalid (p + init_data_size i1) il + end. + +Lemma idlvalid_app: forall l2 l1 pos, + idlvalid pos (l1 ++ l2) <-> idlvalid pos l1 /\ idlvalid (pos + init_data_list_size l1) l2. +Proof. + induction l1 as [ | d l1]; intros; simpl. +- rewrite Z.add_0_r; tauto. +- rewrite IHl1. rewrite Z.add_assoc. tauto. +Qed. + +Lemma add_rev_bytes_valid: forall il bl, + idlvalid 0 (rev il) -> idlvalid 0 (rev (add_rev_bytes bl il)). +Proof. + intros. rewrite add_rev_bytes_spec, rev_app_distr, idlvalid_app. split; auto. + generalize (rev bl) (0 + init_data_list_size (rev il)). induction l; simpl; intros. + auto. + rewrite idlvalid_app; split; auto. simpl. auto using Z.divide_1_l. +Qed. + +Lemma add_zeros_valid: forall il n, + 0 <= n -> idlvalid 0 (rev il) -> idlvalid 0 (rev (add_zeros n il)). +Proof. + intros. rewrite add_zeros_spec, rev_app_distr, idlvalid_app by auto. + split; auto. + generalize (Z.to_nat n) (0 + init_data_list_size (rev il)). induction n0; simpl; intros. + auto. + rewrite idlvalid_app; split; auto. simpl. auto using Z.divide_1_l. +Qed. -- destruct il; intros until res; intros TR; simpl in TR. -+ destruct fl; inv TR. econstructor; split. constructor. apply transl_padding_spec. -+ destruct fl as [ | [f1 ty1] fl ]; monadInv TR. - destruct (transl_init_rec_spec _ _ _ _ EQ) as (d1 & A1 & B1). - destruct (transl_init_struct_spec _ _ _ _ _ _ EQ0) as (d2 & A2 & B2). - exists (tr_padding pos (align pos (alignof ge ty1)) ++ d1 ++ d2); split. - econstructor; eauto. - rewrite ! rev_app_distr. subst res x. rewrite ! app_ass. rewrite transl_padding_spec. auto. +Lemma normalize_valid: forall il depth il', + normalize il depth = OK il' -> idlvalid 0 (rev il) -> idlvalid 0 (rev il'). +Proof. + induction il as [ | i il]; simpl; intros. +- destruct (zle depth 0); inv H. simpl. tauto. +- destruct (zle depth 0). inv H. auto. + rewrite idlvalid_app in H0; destruct H0. + destruct i; try (monadInv H; apply add_rev_bytes_valid; eapply IHil; eauto). + + monadInv H. simpl. rewrite idlvalid_app; split. eauto. simpl; auto using Z.divide_1_l. + + destruct (zle (Z.max 0 z)); monadInv H. + * apply add_zeros_valid. lia. eauto. + * apply add_zeros_valid. lia. simpl. rewrite idlvalid_app; split. auto. simpl; auto using Z.divide_1_l. Qed. -Theorem transl_init_spec: - forall ty i d, transl_init ge ty i = OK d -> tr_init ty i d. +Lemma trisection_valid: forall il depth sz bytes1 bytes2 il', + trisection il depth sz = OK (bytes1, bytes2, il') -> + idlvalid 0 (rev il) -> + idlvalid 0 (rev il'). Proof. - unfold transl_init; intros. monadInv H. - exploit transl_init_rec_spec; eauto. intros (d & A & B). - subst x. unfold rev'; rewrite <- rev_alt. - rewrite rev_app_distr; simpl. rewrite rev_involutive. auto. + unfold trisection; intros. monadInv H. + apply decompose_spec in EQ1. destruct EQ1 as (nl1 & A1 & B1 & C1). + apply decompose_spec in EQ0. destruct EQ0 as (nl2 & A2 & B2 & C2). + exploit normalize_valid; eauto. rewrite A1, A2, !rev_app_distr, !idlvalid_app. + tauto. +Qed. + +Lemma init_data_size_boid: forall i, + init_data_size i = Z.of_nat (length (boid i)). +Proof. + intros. destruct i; simpl; rewrite ?length_inj_bytes, ?encode_int_length; auto. +- rewrite repeat_length. rewrite Z_to_nat_max; auto. +- destruct (Genv.find_symbol ge i), Archi.ptr64; reflexivity. +Qed. + +Lemma init_data_list_size_boidl: forall il, + init_data_list_size il = Z.of_nat (length (boidl il)). +Proof. + induction il as [ | i il]; simpl. auto. + rewrite app_length, init_data_size_boid. lia. +Qed. + +Lemma init_data_list_size_app: forall l1 l2, + init_data_list_size (l1 ++ l2) = init_data_list_size l1 + init_data_list_size l2. +Proof. + induction l1 as [ | i l1]; intros; simpl. auto. rewrite IHl1; lia. +Qed. + +(** ** Memory areas that are initialized to zeros *) + +Definition reads_as_zeros (m: mem) (b: block) (from to: Z) : Prop := + forall i, from <= i < to -> Mem.loadbytes m b i 1 = Some (Byte Byte.zero :: nil). + +Lemma reads_as_zeros_mono: forall m b from1 from2 to1 to2, + reads_as_zeros m b from1 to1 -> from1 <= from2 -> to2 <= to1 -> + reads_as_zeros m b from2 to2. +Proof. + intros; red; intros. apply H; lia. +Qed. + +Remark reads_as_zeros_unchanged: + forall (P: block -> Z -> Prop) m b from to m', + reads_as_zeros m b from to -> + Mem.unchanged_on P m m' -> + (forall i, from <= i < to -> P b i) -> + reads_as_zeros m' b from to. +Proof. + intros; red; intros. eapply Mem.loadbytes_unchanged_on; eauto. + intros; apply H1. lia. +Qed. + +Lemma reads_as_zeros_loadbytes: forall m b from to, + reads_as_zeros m b from to -> + forall len pos, from <= pos -> pos + len <= to -> 0 <= len -> + Mem.loadbytes m b pos len = Some (repeat (Byte Byte.zero) (Z.to_nat len)). +Proof. + intros until to; intros RZ. + induction len using (well_founded_induction (Zwf_well_founded 0)). + intros. destruct (zeq len 0). +- subst len. rewrite Mem.loadbytes_empty by lia. auto. +- replace (Z.to_nat len) with (S (Z.to_nat (len - 1))). + change (repeat (Byte Byte.zero) (S (Z.to_nat (len - 1)))) + with ((Byte Byte.zero :: nil) ++ repeat (Byte Byte.zero) (Z.to_nat (len - 1))). + replace len with (1 + (len - 1)) at 1 by lia. + apply Mem.loadbytes_concat; try lia. + + apply RZ. lia. + + apply H; unfold Zwf; lia. + + rewrite <- Z2Nat.inj_succ by lia. f_equal; lia. +Qed. + +Lemma reads_as_zeros_equiv: forall m b from to, + reads_as_zeros m b from to <-> Genv.readbytes_as_zero m b from (to - from). +Proof. + intros; split; intros. +- red; intros. set (len := Z.of_nat n). + replace n with (Z.to_nat len) by apply Nat2Z.id. + eapply reads_as_zeros_loadbytes; eauto. lia. lia. +- red; intros. red in H. apply (H i 1%nat). lia. lia. +Qed. + +(** ** Semantic correctness of state operations *) + +(** Semantic interpretation of states. *) + +Record match_state (s: state) (m: mem) (b: block) : Prop := { + match_range: + 0 <= s.(curr) <= s.(total_size); + match_contents: + Mem.loadbytes m b 0 s.(curr) = Some (boidl (rev s.(init))); + match_valid: + idlvalid 0 (rev s.(init)); + match_uninitialized: + reads_as_zeros m b s.(curr) s.(total_size) +}. + +Lemma match_size: forall s m b, + match_state s m b -> + init_data_list_size (rev s.(init)) = s.(curr). +Proof. + intros. rewrite init_data_list_size_boidl. + erewrite Mem.loadbytes_length by (eapply match_contents; eauto). + apply Z2Nat.id. eapply match_range; eauto. +Qed. + +Lemma curr_pad_to: forall s pos, + curr s <= curr (pad_to s pos) /\ pos <= curr (pad_to s pos). +Proof. + unfold pad_to; intros. destruct (zle pos (curr s)); simpl; lia. +Qed. + +Lemma total_size_pad_to: forall s pos, + total_size (pad_to s pos) = total_size s. +Proof. + unfold pad_to; intros. destruct (zle pos (curr s)); auto. +Qed. + +Lemma pad_to_correct: forall pos s m b, + match_state s m b -> pos <= s.(total_size) -> + match_state (pad_to s pos) m b. +Proof. + intros. unfold pad_to. destruct (zle pos (curr s)); auto. + destruct H; constructor; simpl; intros. +- lia. +- rewrite boidl_rev_cons. simpl. + replace pos with (s.(curr) + (pos - s.(curr))) at 1 by lia. + apply Mem.loadbytes_concat; try lia. + * auto. + * eapply reads_as_zeros_loadbytes; eauto. lia. lia. lia. +- rewrite idlvalid_app. split; auto. simpl. intuition auto using Z.divide_1_l. +- eapply reads_as_zeros_mono; eauto; lia. +Qed. + +Lemma trisection_correct: forall s m b pos sz bytes1 bytes2 il, + match_state s m b -> + trisection s.(init) (s.(curr) - (pos + sz)) sz = OK (bytes1, bytes2, il) -> + 0 <= pos -> pos + sz <= s.(curr) -> 0 <= sz -> + Mem.loadbytes m b 0 pos = Some (boidl (rev il)) + /\ Mem.loadbytes m b pos sz = Some (inj_bytes bytes2) + /\ Mem.loadbytes m b (pos + sz) (s.(curr) - (pos + sz)) = Some (inj_bytes bytes1). +Proof. + intros. apply trisection_boidl in H0. destruct H0 as (A & B & C). + set (depth := curr s - (pos + sz)) in *. + pose proof (match_contents _ _ _ H) as D. + replace (curr s) with ((pos + sz) + depth) in D by lia. + exploit Mem.loadbytes_split. eexact D. lia. lia. + rewrite Z.add_0_l. intros (bytes0 & bytes1' & LB0 & LB1 & E1). + exploit Mem.loadbytes_split. eexact LB0. lia. lia. + rewrite Z.add_0_l. intros (bytes3 & bytes2' & LB3 & LB2 & E2). + rewrite A in E1. rewrite <- app_ass in E1. + exploit list_append_injective_r. eexact E1. + { unfold inj_bytes; rewrite map_length. erewrite Mem.loadbytes_length; eauto. } + intros (E3 & E4). + rewrite E2 in E3. + exploit list_append_injective_r. eexact E3. + { unfold inj_bytes; rewrite map_length. erewrite Mem.loadbytes_length; eauto. } + intros (E5 & E6). + intuition congruence. +Qed. + +Remark decode_int_zero_ext: forall n bytes, + 0 <= n <= 4 -> n = Z.of_nat (length bytes) -> + Int.zero_ext (n * 8) (Int.repr (decode_int bytes)) = Int.repr (decode_int bytes). +Proof. + intros. + assert (0 <= decode_int bytes < two_p (n * 8)). + { rewrite H0. replace (length bytes) with (length (rev_if_be bytes)). + apply int_of_bytes_range. + apply rev_if_be_length. } + assert (two_p (n * 8) <= Int.modulus). + { apply (two_p_monotone (n * 8) 32); lia. } + unfold Int.zero_ext. + rewrite Int.unsigned_repr by (unfold Int.max_unsigned; lia). + rewrite Zbits.Zzero_ext_mod by lia. + rewrite Zmod_small by auto. auto. +Qed. + +Theorem load_int_correct: forall s m b pos isz i v, + match_state s m b -> + load_int s pos isz = OK i -> + Mem.load (chunk_for_carrier isz) m b pos = Some v -> + v = Vint i. +Proof. + intros until v; intros MS RI LD. + exploit Mem.load_valid_access. eauto. intros [PERM ALIGN]. + unfold load_int in RI. + set (chunk := chunk_for_carrier isz) in *. + set (sz := size_chunk chunk) in *. + assert (sz > 0) by (apply size_chunk_pos). + set (s1 := pad_to s (pos + sz)) in *. + assert (pos + sz <= curr s1) by (apply curr_pad_to). + monadInv RI. InvBooleans. destruct x as [[bytes1 bytes2] il]. + assert (MS': match_state s1 m b) by (apply pad_to_correct; auto). + exploit trisection_correct; eauto. lia. + intros (L1 & L2 & L3). + assert (LEN: Z.of_nat (length bytes2) = sz). + { apply Mem.loadbytes_length in L2. unfold inj_bytes in L2. + rewrite map_length in L2. rewrite L2. apply Z2Nat.id; lia. } + exploit Mem.loadbytes_load. eexact L2. exact ALIGN. rewrite LD. + unfold decode_val. rewrite proj_inj_bytes. intros E; inv E; inv EQ0. + unfold chunk, chunk_for_carrier; destruct isz; f_equal. + - apply (decode_int_zero_ext 1). lia. auto. + - apply (decode_int_zero_ext 2). lia. auto. + - apply (decode_int_zero_ext 1). lia. auto. +Qed. + +Remark loadbytes_concat_3: forall m b ofs1 len1 l1 ofs2 len2 l2 ofs3 len3 l3 len, + Mem.loadbytes m b ofs1 len1 = Some l1 -> + Mem.loadbytes m b ofs2 len2 = Some l2 -> + Mem.loadbytes m b ofs3 len3 = Some l3 -> + ofs2 = ofs1 + len1 -> ofs3 = ofs2 + len2 -> 0 <= len1 -> 0 <= len2 -> 0 <= len3 -> + len = len1 + len2 + len3 -> + Mem.loadbytes m b ofs1 len = Some (l1 ++ l2 ++ l3). +Proof. + intros. rewrite H7, <- Z.add_assoc. apply Mem.loadbytes_concat. auto. + apply Mem.loadbytes_concat. rewrite <- H2; auto. rewrite <- H2, <- H3; auto. + lia. lia. lia. lia. +Qed. + +Theorem store_data_correct: forall s m b pos i s' m', + match_state s m b -> + store_data s pos i = OK s' -> + Genv.store_init_data ge m b pos i = Some m' -> + match i with Init_space _ => False | _ => True end -> + match_state s' m' b. +Proof. + intros until m'; intros MS ST SI NOSPACE. + exploit Genv.store_init_data_aligned; eauto. intros ALIGN. + assert (VALID: idvalid i). + { destruct i; simpl; auto. simpl in SI. destruct (Genv.find_symbol ge i); try discriminate. exists b0; auto. } + unfold store_data in ST. + set (sz := init_data_size i) in *. + assert (sz >= 0) by (apply init_data_size_pos). + set (s1 := pad_to s (pos + sz)) in *. + monadInv ST. InvBooleans. + assert (U: Mem.unchanged_on (fun b i => ~(pos <= i < pos + sz)) m m'). + { eapply Genv.store_init_data_unchanged. eauto. tauto. } + exploit store_init_data_loadbytes; eauto. fold sz. intros D. + destruct (zle (curr s) pos). +- inv ST. + set (il := if zlt (curr s) pos then Init_space (pos - curr s) :: init s else init s). + assert (IL: boidl (rev il) = boidl (rev (init s)) ++ repeat (Byte Byte.zero) (Z.to_nat (pos - curr s))). + { unfold il; destruct (zlt (curr s) pos). + - simpl rev. rewrite boidl_rev_cons. simpl. auto. + - rewrite Z_to_nat_neg by lia. simpl. rewrite app_nil_r; auto. + } + constructor; simpl; intros. + + lia. + + rewrite boidl_rev_cons, IL, app_ass. + apply loadbytes_concat_3 with (len1 := curr s) (ofs2 := curr s) (len2 := pos - curr s) (ofs3 := pos) (len3 := sz); try lia. + * eapply Mem.loadbytes_unchanged_on; eauto. + intros. simpl. lia. + eapply match_contents; eauto. + * eapply Mem.loadbytes_unchanged_on; eauto. + intros. simpl. lia. + eapply reads_as_zeros_loadbytes. eapply match_uninitialized; eauto. lia. lia. lia. + * exact D. + * eapply match_range; eauto. + + rewrite idlvalid_app; split. + * unfold il; destruct (zlt (curr s) pos). + ** simpl; rewrite idlvalid_app; split. eapply match_valid; eauto. simpl. auto using Z.divide_1_l. + ** eapply match_valid; eauto. + * simpl. + replace (init_data_list_size (rev il)) with pos. tauto. + unfold il; destruct (zlt (curr s) pos). + ** simpl; rewrite init_data_list_size_app; simpl. + erewrite match_size by eauto. lia. + ** erewrite match_size by eauto. lia. + + eapply reads_as_zeros_unchanged; eauto. + eapply reads_as_zeros_mono. eapply match_uninitialized; eauto. lia. lia. + intros. simpl. lia. +- monadInv ST. destruct x as [[bytes1 bytes2] il]. inv EQ0. + assert (pos + sz <= curr s1) by (apply curr_pad_to). + assert (MS': match_state s1 m b) by (apply pad_to_correct; auto). + exploit trisection_correct; eauto. lia. + intros (L1 & L2 & L3). + constructor; simpl; intros. + + eapply match_range; eauto. + + rewrite add_rev_bytes_spec, rev_app_distr; simpl; rewrite app_ass; simpl. + rewrite <- map_rev, rev_involutive. + rewrite boidl_app. simpl. rewrite boidl_init_bytes. + apply loadbytes_concat_3 with (len1 := pos) (ofs2 := pos) (len2 := sz) (ofs3 := pos + sz) + (len3 := curr s1 - (pos + sz)); try lia. + * eapply Mem.loadbytes_unchanged_on; eauto. + intros. simpl. lia. + * exact D. + * eapply Mem.loadbytes_unchanged_on; eauto. + intros. simpl. lia. + + apply add_rev_bytes_valid. simpl; rewrite idlvalid_app; split. + * eapply trisection_valid; eauto. eapply match_valid; eauto. + * rewrite init_data_list_size_boidl. erewrite Mem.loadbytes_length by eauto. + rewrite Z2Nat.id by lia. simpl. tauto. + + eapply reads_as_zeros_unchanged; eauto. eapply match_uninitialized; eauto. + intros. simpl. lia. +Qed. + +Corollary store_int_correct: forall s m b pos isz n s' m', + match_state s m b -> + store_int s pos isz n = OK s' -> + Mem.store (chunk_for_carrier isz) m b pos (Vint n) = Some m' -> + match_state s' m' b. +Proof. + intros. eapply store_data_correct; eauto. +- destruct isz; exact H1. +- destruct isz; exact I. +Qed. + +Theorem init_data_list_of_state_correct: forall s m b il b' m1, + match_state s m b -> + init_data_list_of_state s = OK il -> + Mem.range_perm m1 b' 0 s.(total_size) Cur Writable -> + reads_as_zeros m1 b' 0 s.(total_size) -> + exists m2, + Genv.store_init_data_list ge m1 b' 0 il = Some m2 + /\ Mem.loadbytes m2 b' 0 (init_data_list_size il) = Mem.loadbytes m b 0 s.(total_size). +Proof. + intros. unfold init_data_list_of_state in H0; monadInv H0. rename l into LE. + set (s1 := pad_to s s.(total_size)) in *. + assert (MS1: match_state s1 m b) by (apply pad_to_correct; auto; lia). + apply reads_as_zeros_equiv in H2. rewrite Z.sub_0_r in H2. + assert (R: rev' (init s1) = rev (init s1)). + { unfold rev'. rewrite <- rev_alt. auto. } + assert (C: curr s1 = total_size s). + { unfold s1, pad_to. destruct zle; simpl; lia. } + assert (A: Genv.init_data_list_aligned 0 (rev (init s1))). + { exploit match_valid; eauto. generalize (rev (init s1)) 0. + induction l as [ | i l]; simpl; intuition. } + assert (B: forall id ofs, In (Init_addrof id ofs) (rev (init s1)) -> + exists b, Genv.find_symbol ge id = Some b). + { intros id ofs. exploit match_valid; eauto. generalize (rev (init s1)) 0. + induction l as [ | i l]; simpl; intuition eauto. subst i; assumption. } + exploit Genv.store_init_data_list_exists. + 2: eexact A. 2: eexact B. + erewrite match_size by eauto. rewrite C. eauto. + intros (m2 & ST). exists m2; split. +- rewrite R. auto. +- rewrite R. transitivity (Some (boidl (rev (init s1)))). + + eapply Genv.store_init_data_list_loadbytes; eauto. + erewrite match_size, C by eauto. auto. + + symmetry. rewrite <- C. eapply match_contents; eauto. +Qed. + +(** ** Total size properties *) + +Lemma total_size_store_data: forall s pos i s', + store_data s pos i = OK s' -> total_size s' = total_size s. +Proof. + unfold store_data; intros. monadInv H. destruct (zle (curr s) pos); monadInv H. +- auto. +- destruct x as [[bytes1 bytes2] il2]. inv EQ0. simpl. apply total_size_pad_to. +Qed. + +Lemma total_size_transl_init_bitfield: forall ce s ty sz p w i pos s', + transl_init_bitfield ce s ty sz p w i pos = OK s' -> total_size s' = total_size s. +Proof. + unfold transl_init_bitfield; intros. destruct i; monadInv H. destruct x; monadInv EQ0. + eapply total_size_store_data. eexact EQ2. +Qed. + +Lemma total_size_transl_init_rec: forall ce s ty i pos s', + transl_init_rec ce s ty i pos = OK s' -> total_size s' = total_size s +with total_size_transl_init_array: forall ce s tyelt il pos s', + transl_init_array ce s tyelt il pos = OK s' -> total_size s' = total_size s +with total_size_transl_init_struct: forall ce s ms il base pos s', + transl_init_struct ce s ms il base pos = OK s' -> total_size s' = total_size s. +Proof. +- destruct i; simpl; intros. + + monadInv H; eauto using total_size_store_data. + + destruct ty; monadInv H. eauto. + + destruct ty; monadInv H. destruct (co_su x); try discriminate. eauto. + + destruct ty; monadInv H. destruct (co_su x); monadInv EQ0. destruct x2. + * eauto. + * eauto using total_size_transl_init_bitfield. +- destruct il; simpl; intros. + + inv H; auto. + + monadInv H. transitivity (total_size x); eauto. +- destruct il; simpl; intros. + + inv H; auto. + + revert ms pos H. induction ms; intros. + * inv H. + * destruct (member_not_initialized a). eapply IHms; eauto. + monadInv H. transitivity (total_size x1). eauto. + destruct x0; eauto using total_size_transl_init_bitfield. Qed. (** * Soundness of the translation of initializers *) (** Soundness for single initializers. *) -Theorem transl_init_single_steps: - forall ty a data f m v1 ty1 m' v chunk b ofs m'', +Inductive exec_assign: mem -> block -> Z -> bitfield -> type -> val -> mem -> Prop := + | exec_assign_full: forall m b ofs ty v m' chunk, + access_mode ty = By_value chunk -> + Mem.store chunk m b ofs v = Some m' -> + exec_assign m b ofs Full ty v m' + | exec_assign_bits: forall m b ofs sz sg sg1 attr pos width ty n m' c, + type_is_volatile ty = false -> + 0 <= pos -> 0 < width -> pos + width <= bitsize_intsize sz -> + sg1 = (if zlt width (bitsize_intsize sz) then Signed else sg) -> + Mem.load (chunk_for_carrier sz) m b ofs = Some (Vint c) -> + Mem.store (chunk_for_carrier sz) m b ofs + (Vint (Int.bitfield_insert (first_bit sz pos width) width c n)) = Some m' -> + exec_assign m b ofs (Bits sz sg pos width) (Tint sz sg1 attr) (Vint n) m'. + +Lemma transl_init_single_sound: + forall ty a data f m v1 ty1 m' v b ofs m'', transl_init_single ge ty a = OK data -> star step ge (ExprState f a Kstop empty_env m) E0 (ExprState f (Eval v1 ty1) Kstop empty_env m') -> sem_cast v1 ty1 ty m' = Some v -> - access_mode ty = By_value chunk -> - Mem.store chunk m' b ofs v = Some m'' -> - Genv.store_init_data ge m b ofs data = Some m''. + exec_assign m' b ofs Full ty v m'' -> + Genv.store_init_data ge m b ofs data = Some m'' + /\ match data with Init_space _ => False | _ => True end. Proof. - intros. monadInv H. monadInv EQ. + intros until m''; intros TR STEPS CAST ASG. + monadInv TR. monadInv EQ. exploit constval_steps; eauto. intros [A [B C]]. subst m' ty1. exploit sem_cast_match; eauto. intros D. - unfold Genv.store_init_data. - inv D. + inv ASG. rename H into A. unfold Genv.store_init_data. inv D. - (* int *) remember Archi.ptr64 as ptr64. destruct ty; try discriminate EQ0. + destruct i0; inv EQ0. - destruct s; simpl in H2; inv H2. rewrite <- Mem.store_signed_unsigned_8; auto. auto. - destruct s; simpl in H2; inv H2. rewrite <- Mem.store_signed_unsigned_16; auto. auto. - simpl in H2; inv H2. assumption. - simpl in H2; inv H2. assumption. -+ destruct ptr64; inv EQ0. simpl in H2; unfold Mptr in H2; rewrite <- Heqptr64 in H2; inv H2. assumption. + destruct s; simpl in A; inv A. rewrite <- Mem.store_signed_unsigned_8; auto. auto. + destruct s; simpl in A; inv A. rewrite <- Mem.store_signed_unsigned_16; auto. auto. + simpl in A; inv A. auto. + simpl in A; inv A. auto. ++ destruct ptr64; inv EQ0. simpl in A; unfold Mptr in A; rewrite <- Heqptr64 in A; inv A. auto. - (* Long *) - remember Archi.ptr64 as ptr64. destruct ty; inv EQ0. -+ simpl in H2; inv H2. assumption. -+ simpl in H2; unfold Mptr in H2; destruct Archi.ptr64; inv H4. - inv H2; assumption. + remember Archi.ptr64 as ptr64. destruct ty; monadInv EQ0. ++ simpl in A; inv A. auto. ++ simpl in A; unfold Mptr in A; rewrite <- Heqptr64 in A; inv A. auto. - (* float *) destruct ty; try discriminate. - destruct f1; inv EQ0; simpl in H2; inv H2; assumption. + destruct f1; inv EQ0; simpl in A; inv A; auto. - (* single *) destruct ty; try discriminate. - destruct f1; inv EQ0; simpl in H2; inv H2; assumption. + destruct f1; inv EQ0; simpl in A; inv A; auto. - (* pointer *) unfold inj in H. - assert (data = Init_addrof b1 ofs1 /\ chunk = Mptr). + assert (X: data = Init_addrof b1 ofs1 /\ chunk = Mptr). { remember Archi.ptr64 as ptr64. destruct ty; inversion EQ0. - destruct i; inv H5. unfold Mptr. destruct Archi.ptr64; inv H6; inv H2; auto. - subst ptr64. unfold Mptr. destruct Archi.ptr64; inv H5; inv H2; auto. - inv H2. auto. } - destruct H4; subst. destruct (Genv.find_symbol ge b1); inv H. - rewrite Ptrofs.add_zero in H3. auto. + - destruct i; monadInv H2. unfold Mptr. rewrite <- Heqptr64. inv A; auto. + - monadInv H2. unfold Mptr. rewrite <- Heqptr64. inv A; auto. + - inv A; auto. + } + destruct X; subst. destruct (Genv.find_symbol ge b1); inv H. + rewrite Ptrofs.add_zero in H0. auto. - (* undef *) discriminate. Qed. -(** Size properties for initializers. *) - -Lemma transl_init_single_size: - forall ty a data, - transl_init_single ge ty a = OK data -> - init_data_size data = sizeof ge ty. -Proof. - intros. monadInv H. monadInv EQ. remember Archi.ptr64 as ptr64. destruct x. -- monadInv EQ0. -- destruct ty; try discriminate. - destruct i0; inv EQ0; auto. - destruct ptr64; inv EQ0. -Local Transparent sizeof. - unfold sizeof. rewrite <- Heqptr64; auto. -- destruct ty; inv EQ0; auto. - unfold sizeof. destruct Archi.ptr64; inv H0; auto. -- destruct ty; try discriminate. - destruct f0; inv EQ0; auto. -- destruct ty; try discriminate. - destruct f0; inv EQ0; auto. -- destruct ty; try discriminate. - destruct i0; inv EQ0; auto. - destruct Archi.ptr64 eqn:SF; inv H0. simpl. rewrite SF; auto. - destruct ptr64; inv EQ0. simpl. rewrite <- Heqptr64; auto. - inv EQ0. unfold init_data_size, sizeof. auto. -Qed. - -Notation idlsize := init_data_list_size. - -Remark padding_size: - forall frm to, frm <= to -> idlsize (tr_padding frm to) = to - frm. -Proof. - unfold tr_padding; intros. destruct (zlt frm to). - simpl. xomega. - simpl. omega. -Qed. - -Remark idlsize_app: - forall d1 d2, idlsize (d1 ++ d2) = idlsize d1 + idlsize d2. -Proof. - induction d1; simpl; intros. - auto. - rewrite IHd1. omega. -Qed. - -Remark union_field_size: - forall f ty fl, field_type f fl = OK ty -> sizeof ge ty <= sizeof_union ge fl. -Proof. - induction fl as [|[i t]]; simpl; intros. -- inv H. -- destruct (ident_eq f i). - + inv H. xomega. - + specialize (IHfl H). xomega. -Qed. - -Hypothesis ce_consistent: composite_env_consistent ge. - -Lemma tr_init_size: - forall i ty data, - tr_init ty i data -> - idlsize data = sizeof ge ty -with tr_init_array_size: - forall ty il sz data, - tr_init_array ty il sz data -> - idlsize data = sizeof ge ty * sz -with tr_init_struct_size: - forall ty fl il pos data, - tr_init_struct ty fl il pos data -> - sizeof_struct ge pos fl <= sizeof ge ty -> - idlsize data + pos = sizeof ge ty. -Proof. -Local Opaque sizeof. -- destruct 1; simpl. -+ erewrite transl_init_single_size by eauto. omega. -+ Local Transparent sizeof. simpl. eapply tr_init_array_size; eauto. -+ replace (idlsize d) with (idlsize d + 0) by omega. - eapply tr_init_struct_size; eauto. simpl. - unfold lookup_composite in H. destruct (ge.(genv_cenv)!id) as [co'|] eqn:?; inv H. - erewrite co_consistent_sizeof by (eapply ce_consistent; eauto). - unfold sizeof_composite. rewrite H0. apply align_le. - destruct (co_alignof_two_p co) as [n EQ]. rewrite EQ. apply two_power_nat_pos. -+ rewrite idlsize_app, padding_size. - exploit tr_init_size; eauto. intros EQ; rewrite EQ. omega. - simpl. unfold lookup_composite in H. destruct (ge.(genv_cenv)!id) as [co'|] eqn:?; inv H. - apply Z.le_trans with (sizeof_union ge (co_members co)). - eapply union_field_size; eauto. - erewrite co_consistent_sizeof by (eapply ce_consistent; eauto). - unfold sizeof_composite. rewrite H0. apply align_le. - destruct (co_alignof_two_p co) as [n EQ]. rewrite EQ. apply two_power_nat_pos. - -- destruct 1; simpl. -+ omega. -+ rewrite Z.mul_comm. - assert (0 <= sizeof ge ty * sz). - { apply Zmult_gt_0_le_0_compat. omega. generalize (sizeof_pos ge ty); omega. } - xomega. -+ rewrite idlsize_app. - erewrite tr_init_size by eauto. - erewrite tr_init_array_size by eauto. - ring. - -- destruct 1; simpl; intros. -+ rewrite padding_size by auto. omega. -+ rewrite ! idlsize_app, padding_size. - erewrite tr_init_size by eauto. - rewrite <- (tr_init_struct_size _ _ _ _ _ H0 H1). omega. - unfold pos1. apply align_le. apply alignof_pos. -Qed. +(* Hypothesis ce_consistent: composite_env_consistent ge. *) (** A semantics for general initializers *) Definition dummy_function := mkfunction Tvoid cc_default nil nil Sskip. -Fixpoint fields_of_struct (fl: members) (pos: Z) : list (Z * type) := - match fl with - | nil => nil - | (id1, ty1) :: fl' => - (align pos (alignof ge ty1), ty1) :: fields_of_struct fl' (align pos (alignof ge ty1) + sizeof ge ty1) +Fixpoint initialized_fields_of_struct (ms: members) (pos: Z) : res (list (Z * bitfield * type)) := + match ms with + | nil => + OK nil + | m :: ms' => + let pos' := next_field ge.(genv_cenv) pos m in + if member_not_initialized m + then initialized_fields_of_struct ms' pos' + else + do ofs_bf <- layout_field ge.(genv_cenv) pos m; + do l <- initialized_fields_of_struct ms' pos'; + OK ((ofs_bf, type_member m) :: l) end. -Inductive exec_init: mem -> block -> Z -> type -> initializer -> mem -> Prop := - | exec_init_single: forall m b ofs ty a v1 ty1 chunk m' v m'', +Inductive exec_init: mem -> block -> Z -> bitfield -> type -> initializer -> mem -> Prop := + | exec_init_single_: forall m b ofs bf ty a v1 ty1 m' v m'', star step ge (ExprState dummy_function a Kstop empty_env m) E0 (ExprState dummy_function (Eval v1 ty1) Kstop empty_env m') -> sem_cast v1 ty1 ty m' = Some v -> - access_mode ty = By_value chunk -> - Mem.store chunk m' b ofs v = Some m'' -> - exec_init m b ofs ty (Init_single a) m'' + exec_assign m' b ofs bf ty v m'' -> + exec_init m b ofs bf ty (Init_single a) m'' | exec_init_array_: forall m b ofs ty sz a il m', exec_init_array m b ofs ty sz il m' -> - exec_init m b ofs (Tarray ty sz a) (Init_array il) m' - | exec_init_struct: forall m b ofs id a il co m', + exec_init m b ofs Full (Tarray ty sz a) (Init_array il) m' + | exec_init_struct_: forall m b ofs id a il co flds m', ge.(genv_cenv)!id = Some co -> co_su co = Struct -> - exec_init_list m b ofs (fields_of_struct (co_members co) 0) il m' -> - exec_init m b ofs (Tstruct id a) (Init_struct il) m' - | exec_init_union: forall m b ofs id a f i ty co m', + initialized_fields_of_struct (co_members co) 0 = OK flds -> + exec_init_struct m b ofs flds il m' -> + exec_init m b ofs Full (Tstruct id a) (Init_struct il) m' + | exec_init_union_: forall m b ofs id a f i co ty pos bf m', ge.(genv_cenv)!id = Some co -> co_su co = Union -> field_type f (co_members co) = OK ty -> - exec_init m b ofs ty i m' -> - exec_init m b ofs (Tunion id a) (Init_union f i) m' + union_field_offset ge f (co_members co) = OK (pos, bf) -> + exec_init m b (ofs + pos) bf ty i m' -> + exec_init m b ofs Full (Tunion id a) (Init_union f i) m' with exec_init_array: mem -> block -> Z -> type -> Z -> initializer_list -> mem -> Prop := | exec_init_array_nil: forall m b ofs ty sz, sz >= 0 -> exec_init_array m b ofs ty sz Init_nil m | exec_init_array_cons: forall m b ofs ty sz i1 il m' m'', - exec_init m b ofs ty i1 m' -> + exec_init m b ofs Full ty i1 m' -> exec_init_array m' b (ofs + sizeof ge ty) ty (sz - 1) il m'' -> exec_init_array m b ofs ty sz (Init_cons i1 il) m'' -with exec_init_list: mem -> block -> Z -> list (Z * type) -> initializer_list -> mem -> Prop := - | exec_init_list_nil: forall m b ofs, - exec_init_list m b ofs nil Init_nil m - | exec_init_list_cons: forall m b ofs pos ty l i1 il m' m'', - exec_init m b (ofs + pos) ty i1 m' -> - exec_init_list m' b ofs l il m'' -> - exec_init_list m b ofs ((pos, ty) :: l) (Init_cons i1 il) m''. +with exec_init_struct: mem -> block -> Z -> list (Z * bitfield * type) -> initializer_list -> mem -> Prop := + | exec_init_struct_nil: forall m b ofs, + exec_init_struct m b ofs nil Init_nil m + | exec_init_struct_cons: forall m b ofs pos bf ty l i1 il m' m'', + exec_init m b (ofs + pos) bf ty i1 m' -> + exec_init_struct m' b ofs l il m'' -> + exec_init_struct m b ofs ((pos, bf, ty) :: l) (Init_cons i1 il) m''. Scheme exec_init_ind3 := Minimality for exec_init Sort Prop with exec_init_array_ind3 := Minimality for exec_init_array Sort Prop - with exec_init_list_ind3 := Minimality for exec_init_list Sort Prop. -Combined Scheme exec_init_scheme from exec_init_ind3, exec_init_array_ind3, exec_init_list_ind3. + with exec_init_struct_ind3 := Minimality for exec_init_struct Sort Prop. +Combined Scheme exec_init_scheme from exec_init_ind3, exec_init_array_ind3, exec_init_struct_ind3. Remark exec_init_array_length: forall m b ofs ty sz il m', exec_init_array m b ofs ty sz il m' -> sz >= 0. Proof. - induction 1; omega. -Qed. - -Lemma store_init_data_list_app: - forall data1 m b ofs m' data2 m'', - Genv.store_init_data_list ge m b ofs data1 = Some m' -> - Genv.store_init_data_list ge m' b (ofs + idlsize data1) data2 = Some m'' -> - Genv.store_init_data_list ge m b ofs (data1 ++ data2) = Some m''. -Proof. - induction data1; simpl; intros. - inv H. rewrite Z.add_0_r in H0. auto. - destruct (Genv.store_init_data ge m b ofs a); try discriminate. - rewrite Z.add_assoc in H0. eauto. + induction 1; lia. Qed. -Remark store_init_data_list_padding: - forall frm to b ofs m, - Genv.store_init_data_list ge m b ofs (tr_padding frm to) = Some m. +Lemma transl_init_rec_sound: + (forall m b ofs bf ty i m', + exec_init m b ofs bf ty i m' -> + forall s s', + match_state s m b -> + match bf with + | Full => transl_init_rec ge s ty i ofs + | Bits sz sg p w => transl_init_bitfield ge s ty sz p w i ofs + end = OK s' -> + match_state s' m' b) +/\ (forall m b ofs ty sz il m', + exec_init_array m b ofs ty sz il m' -> + forall s s', + match_state s m b -> + transl_init_array ge s ty il ofs = OK s' -> + match_state s' m' b) +/\ (forall m b ofs flds il m', + exec_init_struct m b ofs flds il m' -> + forall s s' ms pos, + match_state s m b -> + initialized_fields_of_struct ms pos = OK flds -> + transl_init_struct ge s ms il ofs pos = OK s' -> + match_state s' m' b). Proof. - intros. unfold tr_padding. destruct (zlt frm to); auto. -Qed. - -Lemma tr_init_sound: - (forall m b ofs ty i m', exec_init m b ofs ty i m' -> - forall data, tr_init ty i data -> - Genv.store_init_data_list ge m b ofs data = Some m') -/\(forall m b ofs ty sz il m', exec_init_array m b ofs ty sz il m' -> - forall data, tr_init_array ty il sz data -> - Genv.store_init_data_list ge m b ofs data = Some m') -/\(forall m b ofs l il m', exec_init_list m b ofs l il m' -> - forall ty fl data pos, - l = fields_of_struct fl pos -> - tr_init_struct ty fl il pos data -> - Genv.store_init_data_list ge m b (ofs + pos) data = Some m'). -Proof. -Local Opaque sizeof. - apply exec_init_scheme; simpl; intros. + apply exec_init_scheme. - (* single *) - inv H3. simpl. erewrite transl_init_single_steps by eauto. auto. + intros until m''; intros STEP CAST ASG s s' MS TR. destruct bf; monadInv TR. + + (* full *) + exploit transl_init_single_sound; eauto. intros [P Q]. + eapply store_data_correct; eauto. + + (* bitfield *) + destruct x; monadInv EQ0. monadInv EQ. + exploit constval_steps; eauto. intros [A [B C]]. subst m' ty1. + exploit sem_cast_match; eauto. intros D. + inv ASG. inv D. + set (f := first_bit sz pos width) in *. + assert (E: Vint c = Vint x) by (eapply load_int_correct; eauto). + inv E. + eapply store_int_correct; eauto. - (* array *) - inv H1. replace (Z.max 0 sz) with sz in H7. eauto. - assert (sz >= 0) by (eapply exec_init_array_length; eauto). xomega. + intros. monadInv H2. eauto. - (* struct *) - inv H3. unfold lookup_composite in H7. rewrite H in H7. inv H7. - replace ofs with (ofs + 0) by omega. eauto. + intros. monadInv H5. unfold lookup_composite in EQ. rewrite H in EQ. inv EQ. + rewrite H0 in EQ0. eauto. - (* union *) - inv H4. unfold lookup_composite in H9. rewrite H in H9. inv H9. rewrite H1 in H12; inv H12. - eapply store_init_data_list_app. eauto. - apply store_init_data_list_padding. - -- (* array, empty *) - inv H0; auto. -- (* array, nonempty *) - inv H3. - eapply store_init_data_list_app. - eauto. - rewrite (tr_init_size _ _ _ H7). eauto. - -- (* struct, empty *) - inv H0. apply store_init_data_list_padding. -- (* struct, nonempty *) - inv H4. simpl in H3; inv H3. - eapply store_init_data_list_app. apply store_init_data_list_padding. - rewrite padding_size. - replace (ofs + pos0 + (pos2 - pos0)) with (ofs + pos2) by omega. - eapply store_init_data_list_app. + intros. monadInv H6. unfold lookup_composite in EQ. rewrite H in EQ. inv EQ. rewrite H0 in EQ0. + rewrite H1, H2 in EQ0. simpl in EQ0. eauto. +- (* array nil *) + intros. monadInv H1. auto. +- (* array cons *) + intros. monadInv H4. eauto. +- (* struct nil *) + intros. monadInv H1. auto. +- (* struct cons *) + intros. simpl in H5. revert H4 H5. generalize pos0. induction ms as [ | m1 ms]. discriminate. + simpl. destruct (member_not_initialized m1). + intros; eapply IHms; eauto. + clear IHms. intros. monadInv H5. rewrite EQ in H4. monadInv H4. inv EQ0. eauto. - rewrite (tr_init_size _ _ _ H9). - rewrite <- Z.add_assoc. eapply H2. eauto. eauto. - apply align_le. apply alignof_pos. Qed. End SOUNDNESS. Theorem transl_init_sound: - forall p m b ty i m' data, - exec_init (globalenv p) m b 0 ty i m' -> + forall p m b ty i m1 data, + let sz := sizeof (prog_comp_env p) ty in + Mem.range_perm m b 0 sz Cur Writable -> + reads_as_zeros m b 0 sz -> + exec_init (globalenv p) m b 0 Full ty i m1 -> transl_init (prog_comp_env p) ty i = OK data -> - Genv.store_init_data_list (globalenv p) m b 0 data = Some m'. + exists m2, + Genv.store_init_data_list (globalenv p) m b 0 data = Some m2 + /\ Mem.loadbytes m2 b 0 (init_data_list_size data) = Mem.loadbytes m1 b 0 sz. Proof. intros. set (ge := globalenv p) in *. - change (prog_comp_env p) with (genv_cenv ge) in H0. - destruct (tr_init_sound ge) as (A & B & C). - eapply build_composite_env_consistent. apply prog_comp_env_eq. - eapply A; eauto. apply transl_init_spec; auto. + change (prog_comp_env p) with (genv_cenv ge) in *. + unfold transl_init in H2; monadInv H2. + fold sz in EQ. set (s0 := initial_state sz) in *. + assert (match_state ge s0 m b). + { constructor; simpl. + - generalize (sizeof_pos ge ty). fold sz. lia. + - apply Mem.loadbytes_empty. lia. + - auto. + - assumption. + } + assert (match_state ge x m1 b). + { eapply (proj1 (transl_init_rec_sound ge)); eauto. } + assert (total_size x = sz). + { change sz with s0.(total_size). eapply total_size_transl_init_rec; eauto. } + rewrite <- H4. eapply init_data_list_of_state_correct; eauto; rewrite H4; auto. Qed. diff --git a/cfrontend/PrintClight.ml b/cfrontend/PrintClight.ml index 0e735d2d..a9ecb342 100644 --- a/cfrontend/PrintClight.ml +++ b/cfrontend/PrintClight.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cfrontend/PrintCsyntax.ml b/cfrontend/PrintCsyntax.ml index 97a00b09..16cdfc41 100644 --- a/cfrontend/PrintCsyntax.ml +++ b/cfrontend/PrintCsyntax.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -111,8 +112,8 @@ let rec name_cdecl id ty = | Tnil -> if first then Buffer.add_string b - (if cconv.cc_vararg then "..." else "void") - else if cconv.cc_vararg then + (if cconv.cc_vararg <> None then "..." else "void") + else if cconv.cc_vararg <> None then Buffer.add_string b ", ..." else () @@ -203,7 +204,7 @@ let rec expr p (prec, e) = then fprintf p "@[<hov 2>(" else fprintf p "@[<hov 2>"; begin match e with - | Eloc(b, ofs, _) -> + | Eloc(b, ofs, _, _) -> fprintf p "<loc%a>" !print_pointer_hook (b, ofs) | Evar(id, _) -> fprintf p "%s" (extern_atom id) @@ -400,11 +401,11 @@ let name_function_parameters name_param fun_name params cconv = Buffer.add_char b '('; begin match params with | [] -> - Buffer.add_string b (if cconv.cc_vararg then "..." else "void") + Buffer.add_string b (if cconv.cc_vararg <> None then "..." else "void") | _ -> let rec add_params first = function | [] -> - if cconv.cc_vararg then Buffer.add_string b ",..." + if cconv.cc_vararg <> None then Buffer.add_string b ",..." | (id, ty) :: rem -> if not first then Buffer.add_string b ", "; Buffer.add_string b (name_cdecl (name_param id) ty); @@ -533,13 +534,18 @@ let struct_or_union = function Struct -> "struct" | Union -> "union" let declare_composite p (Composite(id, su, m, a)) = fprintf p "%s %s;@ " (struct_or_union su) (extern_atom id) +let print_member p = function + | Member_plain(id, ty) -> + fprintf p "@ %s;" (name_cdecl (extern_atom id) ty) + | Member_bitfield(id, sz, sg, attr, w, _is_padding) -> + fprintf p "@ %s : %s;" + (name_cdecl (extern_atom id) (Tint(sz, sg, attr))) + (Z.to_string w) + let define_composite p (Composite(id, su, m, a)) = fprintf p "@[<v 2>%s %s%s {" (struct_or_union su) (extern_atom id) (attributes a); - List.iter - (fun (fid, fty) -> - fprintf p "@ %s;" (name_cdecl (extern_atom fid) fty)) - m; + List.iter (print_member p) m; fprintf p "@;<0 -2>};@]@ @ " let print_program p prog = diff --git a/cfrontend/SimplExpr.v b/cfrontend/SimplExpr.v index c7e57a54..bb1dbe38 100644 --- a/cfrontend/SimplExpr.v +++ b/cfrontend/SimplExpr.v @@ -13,17 +13,8 @@ (** Translation from Compcert C to Clight. Side effects are pulled out of Compcert C expressions. *) -Require Import Coqlib. -Require Import Errors. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import AST. -Require Import Ctypes. -Require Import Cop. -Require Import Csyntax. -Require Import Clight. +Require Import Coqlib Maps Integers Floats Values AST Memory Errors. +Require Import Ctypes Cop Csyntax Clight. Local Open Scope string_scope. Local Open Scope list_scope. @@ -71,8 +62,6 @@ Notation "'do' ( X , Y ) <- A ; B" := (bind2 A (fun X Y => B)) (at level 200, X ident, Y ident, A at level 100, B at level 200) : gensym_monad_scope. -Local Open Scope gensym_monad_scope. - Parameter first_unused_ident: unit -> ident. Definition initial_generator (x: unit) : generator := @@ -96,6 +85,12 @@ Fixpoint makeseq_rec (s: statement) (l: list statement) : statement := Definition makeseq (l: list statement) : statement := makeseq_rec Sskip l. +Section SIMPL_EXPR. + +Local Open Scope gensym_monad_scope. + +Variable ce: composite_env. + (** Smart constructor for [if ... then ... else]. *) Fixpoint eval_simpl_expr (a: expr) : option val := @@ -144,16 +139,64 @@ Definition transl_incrdecr (id: incr_or_decr) (a: expr) (ty: type) : expr := | Decr => Ebinop Osub a (Econst_int Int.one type_int32s) (incrdecr_type ty) end. -(** Generate a [Sset] or [Sbuiltin] operation as appropriate - to dereference a l-value [l] and store its result in temporary variable [id]. *) +(** Given a simple l-value expression [l], determine whether it + designates a bitfield. *) + +Definition is_bitfield_access_aux + (fn: composite_env -> ident -> members -> res (Z * bitfield)) + (id: ident) (fld: ident) : mon bitfield := + match ce!id with + | None => error (MSG "unknown composite " :: CTX id :: nil) + | Some co => + match fn ce fld (co_members co) with + | OK (_, bf) => ret bf + | Error _ => error (MSG "unknown field " :: CTX fld :: nil) + end + end. -Definition chunk_for_volatile_type (ty: type) : option memory_chunk := - if type_is_volatile ty - then match access_mode ty with By_value chunk => Some chunk | _ => None end +Definition is_bitfield_access (l: expr) : mon bitfield := + match l with + | Efield r f _ => + match typeof r with + | Tstruct id _ => is_bitfield_access_aux field_offset id f + | Tunion id _ => is_bitfield_access_aux union_field_offset id f + | _ => error (msg "is_bitfield_access") + end + | _ => ret Full + end. + +(** According to the CompCert C semantics, an access to a l-value of + volatile-qualified type can either + - produce an event in the trace of observable events, or + - produce no event and behave as if no volatile qualifier was there. + + The latter case, where the volatile qualifier is ignored, happens if + - the l-value is a struct or union + - the l-value is an access to a bit field. + + The [chunk_for_volatile_type] function distinguishes between the two + cases. It returns [Some chunk] if the semantics is to produce + an observable event of the [Event_vload chunk] or [Event_vstore chunk] + kind. It returns [None] if the semantics is that of a non-volatile + access. *) + +Definition chunk_for_volatile_type (ty: type) (bf: bitfield) : option memory_chunk := + if type_is_volatile ty then + match access_mode ty with + | By_value chunk => + match bf with + | Full => Some chunk + | Bits _ _ _ _ => None + end + | _ => None + end else None. -Definition make_set (id: ident) (l: expr) : statement := - match chunk_for_volatile_type (typeof l) with +(** Generate a [Sset] or [Sbuiltin] operation as appropriate + to dereference a l-value [l] and store its result in temporary variable [id]. *) + +Definition make_set (bf: bitfield) (id: ident) (l: expr) : statement := + match chunk_for_volatile_type (typeof l) bf with | None => Sset id l | Some chunk => let typtr := Tpointer (typeof l) noattr in @@ -165,13 +208,15 @@ Definition make_set (id: ident) (l: expr) : statement := Definition transl_valof (ty: type) (l: expr) : mon (list statement * expr) := if type_is_volatile ty - then do t <- gensym ty; ret (make_set t l :: nil, Etempvar t ty) + then do t <- gensym ty; + do bf <- is_bitfield_access l; + ret (make_set bf t l :: nil, Etempvar t ty) else ret (nil, l). (** Translation of an assignment. *) -Definition make_assign (l r: expr) : statement := - match chunk_for_volatile_type (typeof l) with +Definition make_assign (bf: bitfield) (l r: expr) : statement := + match chunk_for_volatile_type (typeof l) bf with | None => Sassign l r | Some chunk => @@ -181,6 +226,30 @@ Definition make_assign (l r: expr) : statement := (Eaddrof l typtr :: r :: nil) end. +(** Translation of the value of an assignment expression. + For non-bitfield assignments, it's the value of the right-hand side + converted to the type of the left-hand side. + For assignments to bitfields, an additional normalization to + the width and signedness of the bitfield is required. *) + +Definition make_normalize (sz: intsize) (sg: signedness) (width: Z) (r: expr) := + let intconst (n: Z) := Econst_int (Int.repr n) type_int32s in + if intsize_eq sz IBool || signedness_eq sg Unsigned then + let mask := two_p width - 1 in + Ebinop Oand r (intconst mask) (typeof r) + else + let amount := Int.zwordsize - width in + Ebinop Oshr + (Ebinop Oshl r (intconst amount) type_int32s) + (intconst amount) + (typeof r). + +Definition make_assign_value (bf: bitfield) (r: expr): expr := + match bf with + | Full => r + | Bits sz sg pos width => make_normalize sz sg width r + end. + (** Translation of expressions. Return a pair [(sl, a)] of a list of statements [sl] and a pure expression [a]. - If the [dst] argument is [For_val], the statements [sl] @@ -229,7 +298,7 @@ Definition sd_seqbool_set (ty: type) (sd: set_destination) := Fixpoint transl_expr (dst: destination) (a: Csyntax.expr) : mon (list statement * expr) := match a with - | Csyntax.Eloc b ofs ty => + | Csyntax.Eloc b ofs bf ty => error (msg "SimplExpr.transl_expr: Eloc") | Csyntax.Evar x ty => ret (finish dst nil (Evar x ty)) @@ -335,16 +404,17 @@ Fixpoint transl_expr (dst: destination) (a: Csyntax.expr) : mon (list statement | Csyntax.Eassign l1 r2 ty => do (sl1, a1) <- transl_expr For_val l1; do (sl2, a2) <- transl_expr For_val r2; + do bf <- is_bitfield_access a1; let ty1 := Csyntax.typeof l1 in let ty2 := Csyntax.typeof r2 in match dst with | For_val | For_set _ => do t <- gensym ty1; ret (finish dst - (sl1 ++ sl2 ++ Sset t (Ecast a2 ty1) :: make_assign a1 (Etempvar t ty1) :: nil) - (Etempvar t ty1)) + (sl1 ++ sl2 ++ Sset t (Ecast a2 ty1) :: make_assign bf a1 (Etempvar t ty1) :: nil) + (make_assign_value bf (Etempvar t ty1))) | For_effects => - ret (sl1 ++ sl2 ++ make_assign a1 a2 :: nil, + ret (sl1 ++ sl2 ++ make_assign bf a1 a2 :: nil, dummy_expr) end | Csyntax.Eassignop op l1 r2 tyres ty => @@ -352,31 +422,33 @@ Fixpoint transl_expr (dst: destination) (a: Csyntax.expr) : mon (list statement do (sl1, a1) <- transl_expr For_val l1; do (sl2, a2) <- transl_expr For_val r2; do (sl3, a3) <- transl_valof ty1 a1; + do bf <- is_bitfield_access a1; match dst with | For_val | For_set _ => do t <- gensym ty1; ret (finish dst (sl1 ++ sl2 ++ sl3 ++ Sset t (Ecast (Ebinop op a3 a2 tyres) ty1) :: - make_assign a1 (Etempvar t ty1) :: nil) - (Etempvar t ty1)) + make_assign bf a1 (Etempvar t ty1) :: nil) + (make_assign_value bf (Etempvar t ty1))) | For_effects => - ret (sl1 ++ sl2 ++ sl3 ++ make_assign a1 (Ebinop op a3 a2 tyres) :: nil, + ret (sl1 ++ sl2 ++ sl3 ++ make_assign bf a1 (Ebinop op a3 a2 tyres) :: nil, dummy_expr) end | Csyntax.Epostincr id l1 ty => let ty1 := Csyntax.typeof l1 in do (sl1, a1) <- transl_expr For_val l1; + do bf <- is_bitfield_access a1; match dst with | For_val | For_set _ => do t <- gensym ty1; ret (finish dst - (sl1 ++ make_set t a1 :: - make_assign a1 (transl_incrdecr id (Etempvar t ty1) ty1) :: nil) + (sl1 ++ make_set bf t a1 :: + make_assign bf a1 (transl_incrdecr id (Etempvar t ty1) ty1) :: nil) (Etempvar t ty1)) | For_effects => do (sl2, a2) <- transl_valof ty1 a1; - ret (sl1 ++ sl2 ++ make_assign a1 (transl_incrdecr id a2 ty1) :: nil, + ret (sl1 ++ sl2 ++ make_assign bf a1 (transl_incrdecr id a2 ty1) :: nil, dummy_expr) end | Csyntax.Ecomma r1 r2 ty => @@ -424,12 +496,6 @@ Definition transl_expression (r: Csyntax.expr) : mon (statement * expr) := Definition transl_expr_stmt (r: Csyntax.expr) : mon statement := do (sl, a) <- transl_expr For_effects r; ret (makeseq sl). -(* -Definition transl_if (r: Csyntax.expr) (s1 s2: statement) : mon statement := - do (sl, a) <- transl_expr For_val r; - ret (makeseq (sl ++ makeif a s1 s2 :: nil)). -*) - Definition transl_if (r: Csyntax.expr) (s1 s2: statement) : mon statement := do (sl, a) <- transl_expr For_val r; ret (makeseq (sl ++ makeif a s1 s2 :: nil)). @@ -533,8 +599,12 @@ Definition transl_fundef (fd: Csyntax.fundef) : res fundef := OK (External ef targs tres cc) end. +End SIMPL_EXPR. + +Local Open Scope error_monad_scope. + Definition transl_program (p: Csyntax.program) : res program := - do p1 <- AST.transform_partial_program transl_fundef p; + do p1 <- AST.transform_partial_program (transl_fundef p.(prog_comp_env)) p; OK {| prog_defs := AST.prog_defs p1; prog_public := AST.prog_public p1; prog_main := AST.prog_main p1; diff --git a/cfrontend/SimplExprproof.v b/cfrontend/SimplExprproof.v index 9a3f32ec..67bf0e51 100644 --- a/cfrontend/SimplExprproof.v +++ b/cfrontend/SimplExprproof.v @@ -22,7 +22,7 @@ Require Import SimplExpr SimplExprspec. (** ** Relational specification of the translation. *) Definition match_prog (p: Csyntax.program) (tp: Clight.program) := - match_program (fun ctx f tf => tr_fundef f tf) eq p tp + match_program_gen tr_fundef eq p p tp /\ prog_types tp = prog_types p. Lemma transf_program_match: @@ -30,8 +30,9 @@ Lemma transf_program_match: Proof. unfold transl_program; intros. monadInv H. split; auto. unfold program_of_program; simpl. destruct x; simpl. - eapply match_transform_partial_program_contextual. eexact EQ. - intros. apply transl_fundef_spec; auto. + eapply match_transform_partial_program2; eauto. +- intros. apply transl_fundef_spec; auto. +- intros. inv H. auto. Qed. (** ** Semantic preservation *) @@ -65,25 +66,19 @@ Proof (Genv.senv_match (proj1 TRANSL)). Lemma function_ptr_translated: forall b f, Genv.find_funct_ptr ge b = Some f -> - exists tf, - Genv.find_funct_ptr tge b = Some tf /\ tr_fundef f tf. -Proof. - intros. - edestruct (Genv.find_funct_ptr_match (proj1 TRANSL)) as (ctx & tf & A & B & C); eauto. -Qed. + exists cu tf, + Genv.find_funct_ptr tge b = Some tf /\ tr_fundef cu f tf /\ linkorder cu prog. +Proof (Genv.find_funct_ptr_match (proj1 TRANSL)). Lemma functions_translated: forall v f, Genv.find_funct ge v = Some f -> - exists tf, - Genv.find_funct tge v = Some tf /\ tr_fundef f tf. -Proof. - intros. - edestruct (Genv.find_funct_match (proj1 TRANSL)) as (ctx & tf & A & B & C); eauto. -Qed. + exists cu tf, + Genv.find_funct tge v = Some tf /\ tr_fundef cu f tf /\ linkorder cu prog. +Proof (Genv.find_funct_match (proj1 TRANSL)). Lemma type_of_fundef_preserved: - forall f tf, tr_fundef f tf -> + forall cu f tf, tr_fundef cu f tf -> type_of_fundef tf = Csyntax.type_of_fundef f. Proof. intros. inv H. @@ -92,7 +87,7 @@ Proof. Qed. Lemma function_return_preserved: - forall f tf, tr_function f tf -> + forall ce f tf, tr_function ce f tf -> fn_return tf = Csyntax.fn_return f. Proof. intros. inv H; auto. @@ -100,10 +95,16 @@ Qed. (** Properties of smart constructors. *) +Section TRANSLATION. + +Variable cunit: Csyntax.program. +Hypothesis LINKORDER: linkorder cunit prog. +Let ce := cunit.(prog_comp_env). + Lemma eval_Ederef': forall ge e le m a t l ofs, eval_expr ge e le m a (Vptr l ofs) -> - eval_lvalue ge e le m (Ederef' a t) l ofs. + eval_lvalue ge e le m (Ederef' a t) l ofs Full. Proof. intros. unfold Ederef'; destruct a; auto using eval_Ederef. destruct (type_eq t (typeof a)); auto using eval_Ederef. @@ -120,7 +121,7 @@ Qed. Lemma eval_Eaddrof': forall ge e le m a t l ofs, - eval_lvalue ge e le m a l ofs -> + eval_lvalue ge e le m a l ofs Full -> eval_expr ge e le m (Eaddrof' a t) (Vptr l ofs). Proof. intros. unfold Eaddrof'; destruct a; auto using eval_Eaddrof. @@ -134,12 +135,45 @@ Proof. unfold Eaddrof'; intros; destruct a; auto. destruct (type_eq t (typeof a)); auto. Qed. +Lemma eval_make_normalize: + forall ge e le m a n sz sg sg1 attr width, + 0 < width -> width <= bitsize_intsize sz -> + typeof a = Tint sz sg1 attr -> + eval_expr ge e le m a (Vint n) -> + eval_expr ge e le m (make_normalize sz sg width a) (Vint (bitfield_normalize sz sg width n)). +Proof. + intros. unfold make_normalize, bitfield_normalize. + assert (bitsize_intsize sz <= Int.zwordsize) by (destruct sz; compute; congruence). + destruct (intsize_eq sz IBool || signedness_eq sg Unsigned). +- rewrite Int.zero_ext_and by lia. econstructor. eauto. econstructor. + rewrite H1; simpl. unfold sem_and, sem_binarith. + assert (A: exists sg2, classify_binarith (Tint sz sg1 attr) type_int32s = bin_case_i sg2). + { unfold classify_binarith. unfold type_int32s. destruct sz, sg1; econstructor; eauto. } + destruct A as (sg2 & A); rewrite A. + unfold binarith_type. + assert (B: forall i sz0 sg0 attr0, + sem_cast (Vint i) (Tint sz0 sg0 attr0) (Tint I32 sg2 noattr) m = Some (Vint i)). + { intros. unfold sem_cast, classify_cast. destruct Archi.ptr64; reflexivity. } + unfold type_int32s; rewrite ! B. auto. +- rewrite Int.sign_ext_shr_shl by lia. + set (amount := Int.repr (Int.zwordsize - width)). + assert (LT: Int.ltu amount Int.iwordsize = true). + { unfold Int.ltu. rewrite Int.unsigned_repr_wordsize. apply zlt_true. + unfold amount; rewrite Int.unsigned_repr. lia. + assert (Int.zwordsize < Int.max_unsigned) by reflexivity. lia. } + econstructor. + econstructor. eauto. econstructor. + rewrite H1. unfold sem_binary_operation, sem_shl, sem_shift. rewrite LT. destruct sz, sg1; reflexivity. + econstructor. + unfold sem_binary_operation, sem_shr, sem_shift. rewrite LT. reflexivity. +Qed. + (** Translation of simple expressions. *) Lemma tr_simple_nil: - (forall le dst r sl a tmps, tr_expr le dst r sl a tmps -> + (forall le dst r sl a tmps, tr_expr ce le dst r sl a tmps -> dst = For_val \/ dst = For_effects -> simple r = true -> sl = nil) -/\(forall le rl sl al tmps, tr_exprlist le rl sl al tmps -> +/\(forall le rl sl al tmps, tr_exprlist ce le rl sl al tmps -> simplelist rl = true -> sl = nil). Proof. assert (A: forall dst a, dst = For_val \/ dst = For_effects -> final dst a = nil). @@ -160,52 +194,104 @@ Proof. Qed. Lemma tr_simple_expr_nil: - forall le dst r sl a tmps, tr_expr le dst r sl a tmps -> + forall le dst r sl a tmps, tr_expr ce le dst r sl a tmps -> dst = For_val \/ dst = For_effects -> simple r = true -> sl = nil. Proof (proj1 tr_simple_nil). Lemma tr_simple_exprlist_nil: - forall le rl sl al tmps, tr_exprlist le rl sl al tmps -> + forall le rl sl al tmps, tr_exprlist ce le rl sl al tmps -> simplelist rl = true -> sl = nil. Proof (proj2 tr_simple_nil). (** Translation of [deref_loc] and [assign_loc] operations. *) Remark deref_loc_translated: - forall ty m b ofs t v, - Csem.deref_loc ge ty m b ofs t v -> - match chunk_for_volatile_type ty with - | None => t = E0 /\ Clight.deref_loc ty m b ofs v - | Some chunk => volatile_load tge chunk m b ofs t v + forall ty m b ofs bf t v, + Csem.deref_loc ge ty m b ofs bf t v -> + match chunk_for_volatile_type ty bf with + | None => t = E0 /\ Clight.deref_loc ty m b ofs bf v + | Some chunk => bf = Full /\ volatile_load tge chunk m b ofs t v end. Proof. intros. unfold chunk_for_volatile_type. inv H. - (* By_value, not volatile *) +- (* By_value, not volatile *) rewrite H1. split; auto. eapply deref_loc_value; eauto. - (* By_value, volatile *) - rewrite H0; rewrite H1. eapply volatile_load_preserved with (ge1 := ge); auto. apply senv_preserved. - (* By reference *) +- (* By_value, volatile *) + rewrite H0, H1. split; auto. eapply volatile_load_preserved with (ge1 := ge); auto. apply senv_preserved. +- (* By reference *) rewrite H0. destruct (type_is_volatile ty); split; auto; eapply deref_loc_reference; eauto. - (* By copy *) +- (* By copy *) rewrite H0. destruct (type_is_volatile ty); split; auto; eapply deref_loc_copy; eauto. +- (* Bitfield *) + destruct (type_is_volatile ty); [destruct (access_mode ty)|]; auto using deref_loc_bitfield. Qed. Remark assign_loc_translated: - forall ty m b ofs v t m', - Csem.assign_loc ge ty m b ofs v t m' -> - match chunk_for_volatile_type ty with - | None => t = E0 /\ Clight.assign_loc tge ty m b ofs v m' - | Some chunk => volatile_store tge chunk m b ofs v t m' + forall ty m b ofs bf v t m' v', + Csem.assign_loc ge ty m b ofs bf v t m' v' -> + match chunk_for_volatile_type ty bf with + | None => t = E0 /\ Clight.assign_loc tge ty m b ofs bf v m' + | Some chunk => bf = Full /\ volatile_store tge chunk m b ofs v t m' end. Proof. intros. unfold chunk_for_volatile_type. inv H. - (* By_value, not volatile *) +- (* By_value, not volatile *) rewrite H1. split; auto. eapply assign_loc_value; eauto. - (* By_value, volatile *) - rewrite H0; rewrite H1. eapply volatile_store_preserved with (ge1 := ge); auto. apply senv_preserved. - (* By copy *) +- (* By_value, volatile *) + rewrite H0, H1. split; auto. eapply volatile_store_preserved with (ge1 := ge); auto. apply senv_preserved. +- (* By copy *) rewrite H0. rewrite <- comp_env_preserved in *. destruct (type_is_volatile ty); split; auto; eapply assign_loc_copy; eauto. +- (* Bitfield *) + destruct (type_is_volatile ty); [destruct (access_mode ty)|]; eauto using assign_loc_bitfield. +Qed. + +(** Bitfield accesses *) + +Lemma is_bitfield_access_sound: forall e le m a b ofs bf bf', + eval_lvalue tge e le m a b ofs bf -> + tr_is_bitfield_access ce a bf' -> + bf' = bf. +Proof. + assert (A: forall id co co', + tge.(genv_cenv)!id = Some co -> ce!id = Some co' -> + co' = co /\ complete_members ce (co_members co) = true). + { intros. rewrite comp_env_preserved in H. + assert (ge.(Csem.genv_cenv) ! id = Some co') by (apply LINKORDER; auto). + replace co' with co in * by congruence. + split; auto. apply co_consistent_complete. + eapply build_composite_env_consistent. eapply prog_comp_env_eq. eauto. + } + induction 1; simpl; auto. +- rewrite H0. intros (co' & delta' & E1 & E2). rewrite comp_env_preserved in H2. + exploit A; eauto. intros (E3 & E4). subst co'. + assert (field_offset ge i (co_members co) = field_offset ce i (co_members co)). + { apply field_offset_stable. apply LINKORDER. auto. } + congruence. +- rewrite H0. intros (co' & delta' & E1 & E2). rewrite comp_env_preserved in H2. + exploit A; eauto. intros (E3 & E4). subst co'. + assert (union_field_offset ge i (co_members co) = union_field_offset ce i (co_members co)). + { apply union_field_offset_stable. apply LINKORDER. auto. } + congruence. +Qed. + +Lemma make_assign_value_sound: + forall ty m b ofs bf v t m' v', + Csem.assign_loc ge ty m b ofs bf v t m' v' -> + forall tge e le m'' r, + typeof r = ty -> + eval_expr tge e le m'' r v -> + eval_expr tge e le m'' (make_assign_value bf r) v'. +Proof. + unfold make_assign_value; destruct 1; intros; auto. + inv H. eapply eval_make_normalize; eauto; lia. +Qed. + +Lemma typeof_make_assign_value: forall bf r, + typeof (make_assign_value bf r) = typeof r. +Proof. + intros. destruct bf; simpl; auto. unfold make_normalize. + destruct (intsize_eq sz IBool || signedness_eq sg Unsigned); auto. Qed. (** Evaluation of simple expressions and of their translation *) @@ -215,7 +301,7 @@ Lemma tr_simple: (forall r v, eval_simple_rvalue ge e m r v -> forall le dst sl a tmps, - tr_expr le dst r sl a tmps -> + tr_expr ce le dst r sl a tmps -> match dst with | For_val => sl = nil /\ Csyntax.typeof r = typeof a /\ eval_expr tge e le m a v | For_effects => sl = nil @@ -225,11 +311,11 @@ Lemma tr_simple: /\ eval_expr tge e le m b v end) /\ - (forall l b ofs, - eval_simple_lvalue ge e m l b ofs -> + (forall l b ofs bf, + eval_simple_lvalue ge e m l b ofs bf -> forall le sl a tmps, - tr_expr le For_val l sl a tmps -> - sl = nil /\ Csyntax.typeof l = typeof a /\ eval_lvalue tge e le m a b ofs). + tr_expr ce le For_val l sl a tmps -> + sl = nil /\ Csyntax.typeof l = typeof a /\ eval_lvalue tge e le m a b ofs bf). Proof. Opaque makeif. intros e m. @@ -306,7 +392,7 @@ Lemma tr_simple_rvalue: forall e m r v, eval_simple_rvalue ge e m r v -> forall le dst sl a tmps, - tr_expr le dst r sl a tmps -> + tr_expr ce le dst r sl a tmps -> match dst with | For_val => sl = nil /\ Csyntax.typeof r = typeof a /\ eval_expr tge e le m a v | For_effects => sl = nil @@ -320,18 +406,18 @@ Proof. Qed. Lemma tr_simple_lvalue: - forall e m l b ofs, - eval_simple_lvalue ge e m l b ofs -> + forall e m l b ofs bf, + eval_simple_lvalue ge e m l b ofs bf -> forall le sl a tmps, - tr_expr le For_val l sl a tmps -> - sl = nil /\ Csyntax.typeof l = typeof a /\ eval_lvalue tge e le m a b ofs. + tr_expr ce le For_val l sl a tmps -> + sl = nil /\ Csyntax.typeof l = typeof a /\ eval_lvalue tge e le m a b ofs bf. Proof. intros e m. exact (proj2 (tr_simple e m)). Qed. Lemma tr_simple_exprlist: forall le rl sl al tmps, - tr_exprlist le rl sl al tmps -> + tr_exprlist ce le rl sl al tmps -> forall e m tyl vl, eval_simple_list ge e m rl tyl vl -> sl = nil /\ eval_exprlist tge e le m al tyl vl. @@ -362,29 +448,29 @@ Lemma tr_expr_leftcontext_rec: ( forall from to C, leftcontext from to C -> forall le e dst sl a tmps, - tr_expr le dst (C e) sl a tmps -> + tr_expr ce le dst (C e) sl a tmps -> exists dst', exists sl1, exists sl2, exists a', exists tmp', - tr_expr le dst' e sl1 a' tmp' + tr_expr ce le dst' e sl1 a' tmp' /\ sl = sl1 ++ sl2 /\ incl tmp' tmps /\ (forall le' e' sl3, - tr_expr le' dst' e' sl3 a' tmp' -> + tr_expr ce le' dst' e' sl3 a' tmp' -> (forall id, ~In id tmp' -> le'!id = le!id) -> Csyntax.typeof e' = Csyntax.typeof e -> - tr_expr le' dst (C e') (sl3 ++ sl2) a tmps) + tr_expr ce le' dst (C e') (sl3 ++ sl2) a tmps) ) /\ ( forall from C, leftcontextlist from C -> forall le e sl a tmps, - tr_exprlist le (C e) sl a tmps -> + tr_exprlist ce le (C e) sl a tmps -> exists dst', exists sl1, exists sl2, exists a', exists tmp', - tr_expr le dst' e sl1 a' tmp' + tr_expr ce le dst' e sl1 a' tmp' /\ sl = sl1 ++ sl2 /\ incl tmp' tmps /\ (forall le' e' sl3, - tr_expr le' dst' e' sl3 a' tmp' -> + tr_expr ce le' dst' e' sl3 a' tmp' -> (forall id, ~In id tmp' -> le'!id = le!id) -> Csyntax.typeof e' = Csyntax.typeof e -> - tr_exprlist le' (C e') (sl3 ++ sl2) a tmps) + tr_exprlist ce le' (C e') (sl3 ++ sl2) a tmps) ). Proof. @@ -553,7 +639,7 @@ Ltac UNCHANGED := red; auto. intros. rewrite <- app_ass. econstructor. apply S; auto. eapply tr_expr_invariant; eauto. UNCHANGED. - auto. auto. auto. + auto. auto. auto. auto. + (* for val *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. TR. subst sl1. rewrite app_ass. eauto. @@ -561,7 +647,7 @@ Ltac UNCHANGED := intros. rewrite <- app_ass. econstructor. apply S; auto. eapply tr_expr_invariant; eauto. UNCHANGED. auto. auto. auto. auto. auto. auto. - eapply typeof_context; eauto. + eapply typeof_context. eauto. auto. eauto. auto. - (* assign right *) inv H2. @@ -573,7 +659,7 @@ Ltac UNCHANGED := intros. rewrite <- app_ass. change (sl3 ++ sl2') with (nil ++ (sl3 ++ sl2')). rewrite app_ass. econstructor. eapply tr_expr_invariant; eauto. UNCHANGED. - apply S; auto. auto. auto. auto. + apply S; auto. auto. auto. auto. auto. + (* for val *) assert (sl1 = nil) by (eapply tr_simple_expr_nil; eauto). subst sl1; simpl. exploit H1; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. @@ -583,7 +669,7 @@ Ltac UNCHANGED := econstructor. eapply tr_expr_invariant; eauto. UNCHANGED. apply S; auto. auto. auto. auto. auto. auto. auto. auto. - eapply typeof_context; eauto. + eapply typeof_context; eauto. auto. - (* assignop left *) inv H1. + (* for effects *) @@ -593,7 +679,7 @@ Ltac UNCHANGED := intros. rewrite <- app_ass. econstructor. apply S; auto. eapply tr_expr_invariant; eauto. UNCHANGED. symmetry; eapply typeof_context; eauto. eauto. - auto. auto. auto. auto. auto. auto. + auto. auto. auto. auto. auto. auto. auto. + (* for val *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. TR. subst sl1. rewrite app_ass. eauto. @@ -601,7 +687,7 @@ Ltac UNCHANGED := intros. rewrite <- app_ass. econstructor. apply S; auto. eapply tr_expr_invariant; eauto. UNCHANGED. eauto. auto. auto. auto. auto. auto. auto. auto. auto. auto. auto. - eapply typeof_context; eauto. + eapply typeof_context; eauto. auto. - (* assignop right *) inv H2. + (* for effects *) @@ -611,7 +697,7 @@ Ltac UNCHANGED := red; auto. intros. rewrite <- app_ass. change (sl0 ++ sl2') with (nil ++ sl0 ++ sl2'). rewrite app_ass. econstructor. eapply tr_expr_invariant; eauto. UNCHANGED. - apply S; auto. auto. eauto. auto. auto. auto. auto. auto. auto. + apply S; auto. auto. eauto. auto. auto. auto. auto. auto. auto. auto. + (* for val *) assert (sl1 = nil) by (eapply tr_simple_expr_nil; eauto). subst sl1; simpl. exploit H1; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. @@ -619,7 +705,7 @@ Ltac UNCHANGED := red; auto. intros. rewrite <- app_ass. change (sl0 ++ sl2') with (nil ++ sl0 ++ sl2'). rewrite app_ass. econstructor. eapply tr_expr_invariant; eauto. UNCHANGED. - apply S; auto. eauto. auto. auto. auto. auto. auto. auto. auto. auto. auto. auto. auto. + apply S; auto. eauto. auto. auto. auto. auto. auto. auto. auto. auto. auto. auto. auto. auto. - (* postincr *) inv H1. + (* for effects *) @@ -725,35 +811,35 @@ Qed. Theorem tr_expr_leftcontext: forall C le r dst sl a tmps, leftcontext RV RV C -> - tr_expr le dst (C r) sl a tmps -> + tr_expr ce le dst (C r) sl a tmps -> exists dst', exists sl1, exists sl2, exists a', exists tmp', - tr_expr le dst' r sl1 a' tmp' + tr_expr ce le dst' r sl1 a' tmp' /\ sl = sl1 ++ sl2 /\ incl tmp' tmps /\ (forall le' r' sl3, - tr_expr le' dst' r' sl3 a' tmp' -> + tr_expr ce le' dst' r' sl3 a' tmp' -> (forall id, ~In id tmp' -> le'!id = le!id) -> Csyntax.typeof r' = Csyntax.typeof r -> - tr_expr le' dst (C r') (sl3 ++ sl2) a tmps). + tr_expr ce le' dst (C r') (sl3 ++ sl2) a tmps). Proof. intros. eapply (proj1 tr_expr_leftcontext_rec); eauto. Qed. Theorem tr_top_leftcontext: forall e le m dst rtop sl a tmps, - tr_top tge e le m dst rtop sl a tmps -> + tr_top ce tge e le m dst rtop sl a tmps -> forall r C, rtop = C r -> leftcontext RV RV C -> exists dst', exists sl1, exists sl2, exists a', exists tmp', - tr_top tge e le m dst' r sl1 a' tmp' + tr_top ce tge e le m dst' r sl1 a' tmp' /\ sl = sl1 ++ sl2 /\ incl tmp' tmps /\ (forall le' m' r' sl3, - tr_expr le' dst' r' sl3 a' tmp' -> + tr_expr ce le' dst' r' sl3 a' tmp' -> (forall id, ~In id tmp' -> le'!id = le!id) -> Csyntax.typeof r' = Csyntax.typeof r -> - tr_top tge e le' m' dst (C r') (sl3 ++ sl2) a tmps). + tr_top ce tge e le' m' dst (C r') (sl3 ++ sl2) a tmps). Proof. induction 1; intros. (* val for val *) @@ -835,17 +921,18 @@ Proof. Qed. Lemma step_make_set: - forall id a ty m b ofs t v e le f k, - Csem.deref_loc ge ty m b ofs t v -> - eval_lvalue tge e le m a b ofs -> + forall id a ty m b ofs bf t v e le f k, + Csem.deref_loc ge ty m b ofs bf t v -> + eval_lvalue tge e le m a b ofs bf -> typeof a = ty -> - step1 tge (State f (make_set id a) k e le m) + step1 tge (State f (make_set bf id a) k e le m) t (State f Sskip k e (PTree.set id v le) m). Proof. intros. exploit deref_loc_translated; eauto. rewrite <- H1. - unfold make_set. destruct (chunk_for_volatile_type (typeof a)) as [chunk|]. + unfold make_set. destruct (chunk_for_volatile_type (typeof a) bf) as [chunk|]. (* volatile case *) - intros. change (PTree.set id v le) with (set_opttemp (Some id) v le). econstructor. + intros [A B]. subst bf. + change (PTree.set id v le) with (set_opttemp (Some id) v le). econstructor. econstructor. constructor. eauto. simpl. unfold sem_cast. simpl. eauto. constructor. simpl. econstructor; eauto. @@ -854,19 +941,19 @@ Proof. Qed. Lemma step_make_assign: - forall a1 a2 ty m b ofs t v m' v2 e le f k, - Csem.assign_loc ge ty m b ofs v t m' -> - eval_lvalue tge e le m a1 b ofs -> + forall a1 a2 ty m b ofs bf t v m' v' v2 e le f k, + Csem.assign_loc ge ty m b ofs bf v t m' v' -> + eval_lvalue tge e le m a1 b ofs bf -> eval_expr tge e le m a2 v2 -> sem_cast v2 (typeof a2) ty m = Some v -> typeof a1 = ty -> - step1 tge (State f (make_assign a1 a2) k e le m) + step1 tge (State f (make_assign bf a1 a2) k e le m) t (State f Sskip k e le m'). Proof. intros. exploit assign_loc_translated; eauto. rewrite <- H3. - unfold make_assign. destruct (chunk_for_volatile_type (typeof a1)) as [chunk|]. + unfold make_assign. destruct (chunk_for_volatile_type (typeof a1) bf) as [chunk|]. (* volatile case *) - intros. change le with (set_opttemp None Vundef le) at 2. econstructor. + intros [A B]. subst bf. change le with (set_opttemp None Vundef le) at 2. econstructor. econstructor. constructor. eauto. simpl. unfold sem_cast. simpl. eauto. econstructor; eauto. rewrite H3; eauto. constructor. @@ -900,10 +987,10 @@ Proof. Qed. Lemma step_tr_rvalof: - forall ty m b ofs t v e le a sl a' tmp f k, - Csem.deref_loc ge ty m b ofs t v -> - eval_lvalue tge e le m a b ofs -> - tr_rvalof ty a sl a' tmp -> + forall ty m b ofs bf t v e le a sl a' tmp f k, + Csem.deref_loc ge ty m b ofs bf t v -> + eval_lvalue tge e le m a b ofs bf -> + tr_rvalof ce ty a sl a' tmp -> typeof a = ty -> exists le', star step1 tge (State f Sskip (Kseqlist sl k) e le m) @@ -920,141 +1007,149 @@ Proof. split. eapply eval_Elvalue; eauto. auto. (* volatile *) - intros. exists (PTree.set t0 v le); split. + intros. + exploit is_bitfield_access_sound; eauto. intros EQ; subst bf0. + exists (PTree.set t0 v le); split. simpl. eapply star_two. econstructor. eapply step_make_set; eauto. traceEq. split. constructor. apply PTree.gss. split. auto. intros. apply PTree.gso. congruence. Qed. +End TRANSLATION. + + (** Matching between continuations *) -Inductive match_cont : Csem.cont -> cont -> Prop := - | match_Kstop: - match_cont Csem.Kstop Kstop - | match_Kseq: forall s k ts tk, - tr_stmt s ts -> - match_cont k tk -> - match_cont (Csem.Kseq s k) (Kseq ts tk) - | match_Kwhile2: forall r s k s' ts tk, - tr_if r Sskip Sbreak s' -> - tr_stmt s ts -> - match_cont k tk -> - match_cont (Csem.Kwhile2 r s k) - (Kloop1 (Ssequence s' ts) Sskip tk) - | match_Kdowhile1: forall r s k s' ts tk, - tr_if r Sskip Sbreak s' -> - tr_stmt s ts -> - match_cont k tk -> - match_cont (Csem.Kdowhile1 r s k) - (Kloop1 ts s' tk) - | match_Kfor3: forall r s3 s k ts3 s' ts tk, - tr_if r Sskip Sbreak s' -> - tr_stmt s3 ts3 -> - tr_stmt s ts -> - match_cont k tk -> - match_cont (Csem.Kfor3 r s3 s k) - (Kloop1 (Ssequence s' ts) ts3 tk) - | match_Kfor4: forall r s3 s k ts3 s' ts tk, - tr_if r Sskip Sbreak s' -> - tr_stmt s3 ts3 -> - tr_stmt s ts -> - match_cont k tk -> - match_cont (Csem.Kfor4 r s3 s k) - (Kloop2 (Ssequence s' ts) ts3 tk) - | match_Kswitch2: forall k tk, - match_cont k tk -> - match_cont (Csem.Kswitch2 k) (Kswitch tk) - | match_Kcall: forall f e C ty k optid tf le sl tk a dest tmps, - tr_function f tf -> - leftcontext RV RV C -> - (forall v m, tr_top tge e (set_opttemp optid v le) m dest (C (Csyntax.Eval v ty)) sl a tmps) -> - match_cont_exp dest a k tk -> - match_cont (Csem.Kcall f e C ty k) - (Kcall optid tf e le (Kseqlist sl tk)) -(* - | match_Kcall_some: forall f e C ty k dst tf le sl tk a dest tmps, - transl_function f = Errors.OK tf -> +Inductive match_cont : composite_env -> Csem.cont -> cont -> Prop := + | match_Kstop: forall ce, + match_cont ce Csem.Kstop Kstop + | match_Kseq: forall ce s k ts tk, + tr_stmt ce s ts -> + match_cont ce k tk -> + match_cont ce (Csem.Kseq s k) (Kseq ts tk) + | match_Kwhile2: forall ce r s k s' ts tk, + tr_if ce r Sskip Sbreak s' -> + tr_stmt ce s ts -> + match_cont ce k tk -> + match_cont ce (Csem.Kwhile2 r s k) + (Kloop1 (Ssequence s' ts) Sskip tk) + | match_Kdowhile1: forall ce r s k s' ts tk, + tr_if ce r Sskip Sbreak s' -> + tr_stmt ce s ts -> + match_cont ce k tk -> + match_cont ce (Csem.Kdowhile1 r s k) + (Kloop1 ts s' tk) + | match_Kfor3: forall ce r s3 s k ts3 s' ts tk, + tr_if ce r Sskip Sbreak s' -> + tr_stmt ce s3 ts3 -> + tr_stmt ce s ts -> + match_cont ce k tk -> + match_cont ce (Csem.Kfor3 r s3 s k) + (Kloop1 (Ssequence s' ts) ts3 tk) + | match_Kfor4: forall ce r s3 s k ts3 s' ts tk, + tr_if ce r Sskip Sbreak s' -> + tr_stmt ce s3 ts3 -> + tr_stmt ce s ts -> + match_cont ce k tk -> + match_cont ce (Csem.Kfor4 r s3 s k) + (Kloop2 (Ssequence s' ts) ts3 tk) + | match_Kswitch2: forall ce k tk, + match_cont ce k tk -> + match_cont ce (Csem.Kswitch2 k) (Kswitch tk) + | match_Kcall: forall f e C ty k optid tf le sl tk a dest tmps cu ce, + linkorder cu prog -> + tr_function cu.(prog_comp_env) f tf -> leftcontext RV RV C -> - (forall v m, tr_top tge e (PTree.set dst v le) m dest (C (C.Eval v ty)) sl a tmps) -> - match_cont_exp dest a k tk -> - match_cont (Csem.Kcall f e C ty k) - (Kcall (Some dst) tf e le (Kseqlist sl tk)) -*) - -with match_cont_exp : destination -> expr -> Csem.cont -> cont -> Prop := - | match_Kdo: forall k a tk, - match_cont k tk -> - match_cont_exp For_effects a (Csem.Kdo k) tk - | match_Kifthenelse_empty: forall a k tk, - match_cont k tk -> - match_cont_exp For_val a (Csem.Kifthenelse Csyntax.Sskip Csyntax.Sskip k) (Kseq Sskip tk) - | match_Kifthenelse_1: forall a s1 s2 k ts1 ts2 tk, - tr_stmt s1 ts1 -> tr_stmt s2 ts2 -> - match_cont k tk -> - match_cont_exp For_val a (Csem.Kifthenelse s1 s2 k) (Kseq (Sifthenelse a ts1 ts2) tk) - | match_Kwhile1: forall r s k s' a ts tk, - tr_if r Sskip Sbreak s' -> - tr_stmt s ts -> - match_cont k tk -> - match_cont_exp For_val a + (forall v m, tr_top cu.(prog_comp_env) tge e (set_opttemp optid v le) m dest (C (Csyntax.Eval v ty)) sl a tmps) -> + match_cont_exp cu.(prog_comp_env) dest a k tk -> + match_cont ce (Csem.Kcall f e C ty k) + (Kcall optid tf e le (Kseqlist sl tk)) + +with match_cont_exp : composite_env -> destination -> expr -> Csem.cont -> cont -> Prop := + | match_Kdo: forall ce k a tk, + match_cont ce k tk -> + match_cont_exp ce For_effects a (Csem.Kdo k) tk + | match_Kifthenelse_empty: forall ce a k tk, + match_cont ce k tk -> + match_cont_exp ce For_val a (Csem.Kifthenelse Csyntax.Sskip Csyntax.Sskip k) (Kseq Sskip tk) + | match_Kifthenelse_1: forall ce a s1 s2 k ts1 ts2 tk, + tr_stmt ce s1 ts1 -> tr_stmt ce s2 ts2 -> + match_cont ce k tk -> + match_cont_exp ce For_val a (Csem.Kifthenelse s1 s2 k) (Kseq (Sifthenelse a ts1 ts2) tk) + | match_Kwhile1: forall ce r s k s' a ts tk, + tr_if ce r Sskip Sbreak s' -> + tr_stmt ce s ts -> + match_cont ce k tk -> + match_cont_exp ce For_val a (Csem.Kwhile1 r s k) (Kseq (makeif a Sskip Sbreak) (Kseq ts (Kloop1 (Ssequence s' ts) Sskip tk))) - | match_Kdowhile2: forall r s k s' a ts tk, - tr_if r Sskip Sbreak s' -> - tr_stmt s ts -> - match_cont k tk -> - match_cont_exp For_val a + | match_Kdowhile2: forall ce r s k s' a ts tk, + tr_if ce r Sskip Sbreak s' -> + tr_stmt ce s ts -> + match_cont ce k tk -> + match_cont_exp ce For_val a (Csem.Kdowhile2 r s k) (Kseq (makeif a Sskip Sbreak) (Kloop2 ts s' tk)) - | match_Kfor2: forall r s3 s k s' a ts3 ts tk, - tr_if r Sskip Sbreak s' -> - tr_stmt s3 ts3 -> - tr_stmt s ts -> - match_cont k tk -> - match_cont_exp For_val a + | match_Kfor2: forall ce r s3 s k s' a ts3 ts tk, + tr_if ce r Sskip Sbreak s' -> + tr_stmt ce s3 ts3 -> + tr_stmt ce s ts -> + match_cont ce k tk -> + match_cont_exp ce For_val a (Csem.Kfor2 r s3 s k) (Kseq (makeif a Sskip Sbreak) (Kseq ts (Kloop1 (Ssequence s' ts) ts3 tk))) - | match_Kswitch1: forall ls k a tls tk, - tr_lblstmts ls tls -> - match_cont k tk -> - match_cont_exp For_val a (Csem.Kswitch1 ls k) (Kseq (Sswitch a tls) tk) - | match_Kreturn: forall k a tk, - match_cont k tk -> - match_cont_exp For_val a (Csem.Kreturn k) (Kseq (Sreturn (Some a)) tk). - -Lemma match_cont_call: - forall k tk, - match_cont k tk -> - match_cont (Csem.call_cont k) (call_cont tk). + | match_Kswitch1: forall ce ls k a tls tk, + tr_lblstmts ce ls tls -> + match_cont ce k tk -> + match_cont_exp ce For_val a (Csem.Kswitch1 ls k) (Kseq (Sswitch a tls) tk) + | match_Kreturn: forall ce k a tk, + match_cont ce k tk -> + match_cont_exp ce For_val a (Csem.Kreturn k) (Kseq (Sreturn (Some a)) tk). + +Lemma match_cont_is_call_cont: + forall ce k tk, + match_cont ce k tk -> Csem.is_call_cont k -> + forall ce', match_cont ce' k tk. Proof. - induction 1; simpl; auto. constructor. econstructor; eauto. + destruct 1; simpl; intros; try contradiction; econstructor; eauto. +Qed. + +Lemma match_cont_call_cont: + forall ce k tk, + match_cont ce k tk -> + forall ce', match_cont ce' (Csem.call_cont k) (call_cont tk). +Proof. + induction 1; simpl; auto; intros; econstructor; eauto. Qed. (** Matching between states *) Inductive match_states: Csem.state -> state -> Prop := - | match_exprstates: forall f r k e m tf sl tk le dest a tmps, - tr_function f tf -> - tr_top tge e le m dest r sl a tmps -> - match_cont_exp dest a k tk -> + | match_exprstates: forall f r k e m tf sl tk le dest a tmps cu + (LINK: linkorder cu prog) + (TRF: tr_function cu.(prog_comp_env) f tf) + (TR: tr_top cu.(prog_comp_env) tge e le m dest r sl a tmps) + (MK: match_cont_exp cu.(prog_comp_env) dest a k tk), match_states (Csem.ExprState f r k e m) (State tf Sskip (Kseqlist sl tk) e le m) - | match_regularstates: forall f s k e m tf ts tk le, - tr_function f tf -> - tr_stmt s ts -> - match_cont k tk -> + | match_regularstates: forall f s k e m tf ts tk le cu + (LINK: linkorder cu prog) + (TRF: tr_function cu.(prog_comp_env) f tf) + (TR: tr_stmt cu.(prog_comp_env) s ts) + (MK: match_cont cu.(prog_comp_env) k tk), match_states (Csem.State f s k e m) (State tf ts tk e le m) - | match_callstates: forall fd args k m tfd tk, - tr_fundef fd tfd -> - match_cont k tk -> + | match_callstates: forall fd args k m tfd tk cu + (LINK: linkorder cu prog) + (TR: tr_fundef cu fd tfd) + (MK: forall ce, match_cont ce k tk), match_states (Csem.Callstate fd args k m) (Callstate tfd args tk m) - | match_returnstates: forall res k m tk, - match_cont k tk -> + | match_returnstates: forall res k m tk + (MK: forall ce, match_cont ce k tk), match_states (Csem.Returnstate res k m) (Returnstate res tk m) | match_stuckstate: forall S, @@ -1063,21 +1158,22 @@ Inductive match_states: Csem.state -> state -> Prop := (** Additional results on translation of statements *) Lemma tr_select_switch: - forall n ls tls, - tr_lblstmts ls tls -> - tr_lblstmts (Csem.select_switch n ls) (select_switch n tls). + forall ce n ls tls, + tr_lblstmts ce ls tls -> + tr_lblstmts ce (Csem.select_switch n ls) (select_switch n tls). Proof. + intros ce. assert (DFL: forall ls tls, - tr_lblstmts ls tls -> - tr_lblstmts (Csem.select_switch_default ls) (select_switch_default tls)). + tr_lblstmts ce ls tls -> + tr_lblstmts ce (Csem.select_switch_default ls) (select_switch_default tls)). { induction 1; simpl. constructor. destruct c; auto. constructor; auto. } assert (CASE: forall n ls tls, - tr_lblstmts ls tls -> + tr_lblstmts ce ls tls -> match Csem.select_switch_case n ls with | None => select_switch_case n tls = None | Some ls' => - exists tls', select_switch_case n tls = Some tls' /\ tr_lblstmts ls' tls' + exists tls', select_switch_case n tls = Some tls' /\ tr_lblstmts ce ls' tls' end). { induction 1; simpl; intros. auto. @@ -1091,9 +1187,9 @@ Proof. Qed. Lemma tr_seq_of_labeled_statement: - forall ls tls, - tr_lblstmts ls tls -> - tr_stmt (Csem.seq_of_labeled_statement ls) (seq_of_labeled_statement tls). + forall ce ls tls, + tr_lblstmts ce ls tls -> + tr_stmt ce (Csem.seq_of_labeled_statement ls) (seq_of_labeled_statement tls). Proof. induction 1; simpl; constructor; auto. Qed. @@ -1102,6 +1198,7 @@ Qed. Section FIND_LABEL. +Variable ce: composite_env. Variable lbl: label. Definition nolabel (s: statement) : Prop := @@ -1137,21 +1234,21 @@ Proof. Qed. Lemma make_set_nolabel: - forall t a, nolabel (make_set t a). + forall bf t a, nolabel (make_set bf t a). Proof. unfold make_set; intros; red; intros. - destruct (chunk_for_volatile_type (typeof a)); auto. + destruct (chunk_for_volatile_type (typeof a) bf); auto. Qed. Lemma make_assign_nolabel: - forall l r, nolabel (make_assign l r). + forall bf l r, nolabel (make_assign bf l r). Proof. unfold make_assign; intros; red; intros. - destruct (chunk_for_volatile_type (typeof l)); auto. + destruct (chunk_for_volatile_type (typeof l) bf); auto. Qed. Lemma tr_rvalof_nolabel: - forall ty a sl a' tmp, tr_rvalof ty a sl a' tmp -> nolabel_list sl. + forall ce ty a sl a' tmp, tr_rvalof ce ty a sl a' tmp -> nolabel_list sl. Proof. destruct 1; simpl; intuition. apply make_set_nolabel. Qed. @@ -1177,16 +1274,16 @@ Ltac NoLabelTac := | [ H: _ -> nolabel_list ?x |- nolabel_list ?x ] => apply H; NoLabelTac | [ |- nolabel (makeseq _) ] => apply makeseq_nolabel; NoLabelTac | [ |- nolabel (makeif _ _ _) ] => apply makeif_nolabel; NoLabelTac - | [ |- nolabel (make_set _ _) ] => apply make_set_nolabel - | [ |- nolabel (make_assign _ _) ] => apply make_assign_nolabel + | [ |- nolabel (make_set _ _ _) ] => apply make_set_nolabel + | [ |- nolabel (make_assign _ _ _) ] => apply make_assign_nolabel | [ |- nolabel _ ] => red; intros; simpl; auto | [ |- _ /\ _ ] => split; NoLabelTac | _ => auto end. Lemma tr_find_label_expr: - (forall le dst r sl a tmps, tr_expr le dst r sl a tmps -> nolabel_list sl) -/\(forall le rl sl al tmps, tr_exprlist le rl sl al tmps -> nolabel_list sl). + (forall le dst r sl a tmps, tr_expr ce le dst r sl a tmps -> nolabel_list sl) +/\(forall le rl sl al tmps, tr_exprlist ce le rl sl al tmps -> nolabel_list sl). Proof. apply tr_expr_exprlist; intros; NoLabelTac. apply nolabel_do_set. @@ -1200,14 +1297,14 @@ Qed. Lemma tr_find_label_top: forall e le m dst r sl a tmps, - tr_top tge e le m dst r sl a tmps -> nolabel_list sl. + tr_top ce tge e le m dst r sl a tmps -> nolabel_list sl. Proof. induction 1; intros; NoLabelTac. eapply (proj1 tr_find_label_expr); eauto. Qed. Lemma tr_find_label_expression: - forall r s a, tr_expression r s a -> forall k, find_label lbl s k = None. + forall r s a, tr_expression ce r s a -> forall k, find_label lbl s k = None. Proof. intros. inv H. assert (nolabel (makeseq sl)). apply makeseq_nolabel. @@ -1216,7 +1313,7 @@ Proof. Qed. Lemma tr_find_label_expr_stmt: - forall r s, tr_expr_stmt r s -> forall k, find_label lbl s k = None. + forall r s, tr_expr_stmt ce r s -> forall k, find_label lbl s k = None. Proof. intros. inv H. assert (nolabel (makeseq sl)). apply makeseq_nolabel. @@ -1226,7 +1323,7 @@ Qed. Lemma tr_find_label_if: forall r s, - tr_if r Sskip Sbreak s -> + tr_if ce r Sskip Sbreak s -> forall k, find_label lbl s k = None. Proof. intros. inv H. @@ -1241,29 +1338,29 @@ Qed. Lemma tr_find_label: forall s k ts tk - (TR: tr_stmt s ts) - (MC: match_cont k tk), + (TR: tr_stmt ce s ts) + (MC: match_cont ce k tk), match Csem.find_label lbl s k with | None => find_label lbl ts tk = None | Some (s', k') => exists ts', exists tk', find_label lbl ts tk = Some (ts', tk') - /\ tr_stmt s' ts' - /\ match_cont k' tk' + /\ tr_stmt ce s' ts' + /\ match_cont ce k' tk' end with tr_find_label_ls: forall s k ts tk - (TR: tr_lblstmts s ts) - (MC: match_cont k tk), + (TR: tr_lblstmts ce s ts) + (MC: match_cont ce k tk), match Csem.find_label_ls lbl s k with | None => find_label_ls lbl ts tk = None | Some (s', k') => exists ts', exists tk', find_label_ls lbl ts tk = Some (ts', tk') - /\ tr_stmt s' ts' - /\ match_cont k' tk' + /\ tr_stmt ce s' ts' + /\ match_cont ce k' tk' end. Proof. induction s; intros; inversion TR; subst; clear TR; simpl. @@ -1362,7 +1459,7 @@ The following measure decreases for these stuttering steps. *) Fixpoint esize (a: Csyntax.expr) : nat := match a with - | Csyntax.Eloc _ _ _ => 1%nat + | Csyntax.Eloc _ _ _ _ => 1%nat | Csyntax.Evar _ _ => 1%nat | Csyntax.Ederef r1 _ => S(esize r1) | Csyntax.Efield l1 _ _ => S(esize l1) @@ -1423,12 +1520,12 @@ Qed. (** Forward simulation for expressions. *) Lemma tr_val_gen: - forall le dst v ty a tmp, + forall ce le dst v ty a tmp, typeof a = ty -> (forall tge e le' m, (forall id, In id tmp -> le'!id = le!id) -> eval_expr tge e le' m a v) -> - tr_expr le dst (Csyntax.Eval v ty) (final dst a) a tmp. + tr_expr ce le dst (Csyntax.Eval v ty) (final dst a) a tmp. Proof. intros. destruct dst; simpl; econstructor; auto. Qed. @@ -1441,43 +1538,53 @@ Lemma estep_simulation: (star step1 tge S1' t S2' /\ measure S2 < measure S1)%nat) /\ match_states S2 S2'. Proof. + +Ltac NOTIN := + match goal with + | [ H1: In ?x ?l, H2: list_disjoint ?l _ |- ~In ?x _ ] => + red; intro; elim (H2 x x); auto; fail + | [ H1: In ?x ?l, H2: list_disjoint _ ?l |- ~In ?x _ ] => + red; intro; elim (H2 x x); auto; fail + end. + induction 1; intros; inv MS. -(* expr *) - assert (tr_expr le dest r sl a tmps). - inv H9. contradiction. auto. +- (* expr *) + assert (tr_expr (prog_comp_env cu) le dest r sl a tmps). + { inv TR. contradiction. auto. } exploit tr_simple_rvalue; eauto. destruct dest. - (* for val *) ++ (* for val *) intros [SL1 [TY1 EV1]]. subst sl. econstructor; split. - right; split. apply star_refl. destruct r; simpl; (contradiction || omega). + right; split. apply star_refl. destruct r; simpl; (contradiction || lia). econstructor; eauto. instantiate (1 := tmps). apply tr_top_val_val; auto. - (* for effects *) ++ (* for effects *) intros SL1. subst sl. econstructor; split. - right; split. apply star_refl. destruct r; simpl; (contradiction || omega). + right; split. apply star_refl. destruct r; simpl; (contradiction || lia). econstructor; eauto. instantiate (1 := tmps). apply tr_top_base. constructor. - (* for set *) - inv H10. -(* rval volatile *) - exploit tr_top_leftcontext; eauto. clear H11. ++ (* for set *) + inv MK. +- (* rval volatile *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H2. inv H7; try congruence. exploit tr_simple_lvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl. + exploit is_bitfield_access_sound; eauto. intros EQ; subst bf0. econstructor; split. left. eapply plus_two. constructor. eapply step_make_set; eauto. traceEq. econstructor; eauto. change (final dst' (Etempvar t0 (Csyntax.typeof l)) ++ sl2) with (nil ++ (final dst' (Etempvar t0 (Csyntax.typeof l)) ++ sl2)). apply S. apply tr_val_gen. auto. - intros. constructor. rewrite H5; auto. apply PTree.gss. - intros. apply PTree.gso. red; intros; subst; elim H5; auto. + intros. constructor. rewrite H7; auto. apply PTree.gss. + intros. apply PTree.gso. red; intros; subst; elim H7; auto. auto. -(* seqand true *) - exploit tr_top_leftcontext; eauto. clear H9. +- (* seqand true *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H2. - (* for val *) ++ (* for val *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. econstructor; split. @@ -1488,7 +1595,7 @@ Proof. eapply match_exprstates; eauto. apply S. apply tr_paren_val with (a1 := a2); auto. apply tr_expr_monotone with tmp2; eauto. auto. auto. - (* for effects *) ++ (* for effects *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. econstructor; split. @@ -1499,7 +1606,7 @@ Proof. eapply match_exprstates; eauto. apply S. apply tr_paren_effects with (a1 := a2); auto. apply tr_expr_monotone with tmp2; eauto. auto. auto. - (* for set *) ++ (* for set *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. econstructor; split. @@ -1510,11 +1617,11 @@ Proof. eapply match_exprstates; eauto. apply S. apply tr_paren_set with (a1 := a2) (t := sd_temp sd); auto. apply tr_expr_monotone with tmp2; eauto. auto. auto. -(* seqand false *) - exploit tr_top_leftcontext; eauto. clear H9. +- (* seqand false *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H2. - (* for val *) ++ (* for val *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. econstructor; split. @@ -1526,7 +1633,7 @@ Proof. intros. constructor. rewrite H2. apply PTree.gss. auto. intros. apply PTree.gso. congruence. auto. - (* for effects *) ++ (* for effects *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. econstructor; split. @@ -1536,7 +1643,7 @@ Proof. eapply match_exprstates; eauto. change sl2 with (nil ++ sl2). apply S. econstructor; eauto. auto. auto. - (* for set *) ++ (* for set *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. econstructor; split. @@ -1546,11 +1653,11 @@ Proof. rewrite <- Kseqlist_app. eapply match_exprstates; eauto. apply S. econstructor; eauto. intros. constructor. auto. auto. -(* seqor true *) - exploit tr_top_leftcontext; eauto. clear H9. +- (* seqor true *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H2. - (* for val *) ++ (* for val *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. econstructor; split. @@ -1562,7 +1669,7 @@ Proof. intros. constructor. rewrite H2. apply PTree.gss. auto. intros. apply PTree.gso. congruence. auto. - (* for effects *) ++ (* for effects *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. econstructor; split. @@ -1572,7 +1679,7 @@ Proof. eapply match_exprstates; eauto. change sl2 with (nil ++ sl2). apply S. econstructor; eauto. auto. auto. - (* for set *) ++ (* for set *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. econstructor; split. @@ -1582,11 +1689,11 @@ Proof. rewrite <- Kseqlist_app. eapply match_exprstates; eauto. apply S. econstructor; eauto. intros. constructor. auto. auto. -(* seqand false *) - exploit tr_top_leftcontext; eauto. clear H9. +- (* seqand false *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H2. - (* for val *) ++ (* for val *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. econstructor; split. @@ -1597,7 +1704,7 @@ Proof. eapply match_exprstates; eauto. apply S. apply tr_paren_val with (a1 := a2); auto. apply tr_expr_monotone with tmp2; eauto. auto. auto. - (* for effects *) ++ (* for effects *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. econstructor; split. @@ -1608,7 +1715,7 @@ Proof. eapply match_exprstates; eauto. apply S. apply tr_paren_effects with (a1 := a2); auto. apply tr_expr_monotone with tmp2; eauto. auto. auto. - (* for set *) ++ (* for set *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. econstructor; split. @@ -1619,11 +1726,11 @@ Proof. eapply match_exprstates; eauto. apply S. apply tr_paren_set with (a1 := a2) (t := sd_temp sd); auto. apply tr_expr_monotone with tmp2; eauto. auto. auto. -(* condition *) - exploit tr_top_leftcontext; eauto. clear H9. +- (* condition *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H2. - (* for value *) ++ (* for value *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. destruct b. econstructor; split. @@ -1640,7 +1747,7 @@ Proof. rewrite <- Kseqlist_app. eapply match_exprstates; eauto. apply S. econstructor; eauto. apply tr_expr_monotone with tmp3; eauto. auto. auto. - (* for effects *) ++ (* for effects *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. destruct b. econstructor; split. @@ -1649,7 +1756,7 @@ Proof. apply push_seq. reflexivity. traceEq. rewrite <- Kseqlist_app. - econstructor. eauto. apply S. + econstructor; eauto. apply S. econstructor; eauto. apply tr_expr_monotone with tmp2; eauto. econstructor; eauto. auto. auto. @@ -1659,11 +1766,11 @@ Proof. apply push_seq. reflexivity. traceEq. rewrite <- Kseqlist_app. - econstructor. eauto. apply S. + econstructor; eauto. apply S. econstructor; eauto. apply tr_expr_monotone with tmp3; eauto. econstructor; eauto. - auto. auto. - (* for set *) + auto. ++ (* for set *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. destruct b. econstructor; split. @@ -1672,40 +1779,42 @@ Proof. apply push_seq. reflexivity. traceEq. rewrite <- Kseqlist_app. - econstructor. eauto. apply S. + econstructor; eauto. apply S. econstructor; eauto. apply tr_expr_monotone with tmp2; eauto. econstructor; eauto. - auto. auto. + auto. econstructor; split. left. eapply plus_left. constructor. eapply star_trans. apply step_makeif with (b := false) (v1 := v); auto. congruence. apply push_seq. reflexivity. traceEq. rewrite <- Kseqlist_app. - econstructor. eauto. apply S. + econstructor; eauto. apply S. econstructor; eauto. apply tr_expr_monotone with tmp3; eauto. econstructor; eauto. - auto. auto. -(* assign *) - exploit tr_top_leftcontext; eauto. clear H12. + auto. +- (* assign *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H4. - (* for effects *) ++ (* for effects *) exploit tr_simple_rvalue; eauto. intros [SL2 [TY2 EV2]]. exploit tr_simple_lvalue; eauto. intros [SL1 [TY1 EV1]]. + assert (bf0 = bf) by (eapply is_bitfield_access_sound; eauto). subst; simpl Kseqlist. econstructor; split. left. eapply plus_left. constructor. apply star_one. eapply step_make_assign; eauto. rewrite <- TY2; eauto. traceEq. - econstructor. auto. change sl2 with (nil ++ sl2). apply S. - constructor. auto. auto. auto. - (* for value *) + econstructor; eauto. change sl2 with (nil ++ sl2). apply S. + constructor. auto. auto. ++ (* for value *) exploit tr_simple_rvalue; eauto. intros [SL2 [TY2 EV2]]. exploit tr_simple_lvalue. eauto. - eapply tr_expr_invariant with (le' := PTree.set t0 v' le). eauto. + eapply tr_expr_invariant with (le' := PTree.set t0 v1 le). eauto. intros. apply PTree.gso. intuition congruence. intros [SL1 [TY1 EV1]]. + assert (bf0 = bf) by (eapply is_bitfield_access_sound; eauto). subst; simpl Kseqlist. econstructor; split. left. eapply plus_left. constructor. @@ -1714,22 +1823,24 @@ Proof. apply star_one. eapply step_make_assign; eauto. constructor. apply PTree.gss. simpl. eapply cast_idempotent; eauto. reflexivity. reflexivity. traceEq. - econstructor. auto. apply S. - apply tr_val_gen. auto. intros. constructor. - rewrite H4; auto. apply PTree.gss. + econstructor; eauto. apply S. + apply tr_val_gen. rewrite typeof_make_assign_value; auto. + intros. eapply make_assign_value_sound; eauto. + constructor. rewrite H4; auto. apply PTree.gss. intros. apply PTree.gso. intuition congruence. - auto. auto. -(* assignop *) - exploit tr_top_leftcontext; eauto. clear H15. + auto. +- (* assignop *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H6. - (* for effects *) ++ (* for effects *) exploit tr_simple_lvalue; eauto. intros [SL1 [TY1 EV1]]. exploit step_tr_rvalof; eauto. intros [le' [EXEC [EV3 [TY3 INV]]]]. exploit tr_simple_lvalue. eauto. eapply tr_expr_invariant with (le := le) (le' := le'). eauto. intros. apply INV. NOTIN. intros [? [? EV1']]. exploit tr_simple_rvalue. eauto. eapply tr_expr_invariant with (le := le) (le' := le'). eauto. intros. apply INV. NOTIN. simpl. intros [SL2 [TY2 EV2]]. + assert (bf0 = bf) by (eapply is_bitfield_access_sound; eauto). subst; simpl Kseqlist. econstructor; split. left. eapply star_plus_trans. rewrite app_ass. rewrite Kseqlist_app. eexact EXEC. @@ -1737,9 +1848,9 @@ Proof. econstructor. eexact EV3. eexact EV2. rewrite TY3; rewrite <- TY1; rewrite <- TY2; rewrite comp_env_preserved; auto. reflexivity. traceEq. - econstructor. auto. change sl2 with (nil ++ sl2). apply S. - constructor. auto. auto. auto. - (* for value *) + econstructor; eauto. change sl2 with (nil ++ sl2). apply S. + constructor. auto. auto. ++ (* for value *) exploit tr_simple_lvalue; eauto. intros [SL1 [TY1 EV1]]. exploit step_tr_rvalof; eauto. intros [le' [EXEC [EV3 [TY3 INV]]]]. exploit tr_simple_lvalue. eauto. eapply tr_expr_invariant with (le := le) (le' := le'). eauto. @@ -1750,6 +1861,7 @@ Proof. eapply tr_expr_invariant with (le := le) (le' := PTree.set t v4 le'). eauto. intros. rewrite PTree.gso. apply INV. NOTIN. intuition congruence. intros [? [? EV1'']]. + assert (bf0 = bf) by (eapply is_bitfield_access_sound; eauto). subst; simpl Kseqlist. econstructor; split. left. rewrite app_ass. rewrite Kseqlist_app. @@ -1761,44 +1873,46 @@ Proof. econstructor. eapply step_make_assign; eauto. constructor. apply PTree.gss. simpl. eapply cast_idempotent; eauto. reflexivity. traceEq. - econstructor. auto. apply S. - apply tr_val_gen. auto. intros. constructor. - rewrite H10; auto. apply PTree.gss. + econstructor; eauto. apply S. + apply tr_val_gen. rewrite typeof_make_assign_value; auto. + intros. eapply make_assign_value_sound; eauto. + constructor. rewrite H10; auto. apply PTree.gss. intros. rewrite PTree.gso. apply INV. red; intros; elim H10; auto. intuition congruence. - auto. auto. -(* assignop stuck *) - exploit tr_top_leftcontext; eauto. clear H12. + auto. +- (* assignop stuck *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H4. - (* for effects *) ++ (* for effects *) exploit tr_simple_lvalue; eauto. intros [SL1 [TY1 EV1]]. exploit tr_simple_rvalue; eauto. intros [SL2 [TY2 EV2]]. exploit step_tr_rvalof; eauto. intros [le' [EXEC [EV3 [TY3 INV]]]]. subst; simpl Kseqlist. econstructor; split. right; split. rewrite app_ass. rewrite Kseqlist_app. eexact EXEC. - simpl. omega. + simpl. lia. constructor. - (* for value *) ++ (* for value *) exploit tr_simple_lvalue; eauto. intros [SL1 [TY1 EV1]]. exploit tr_simple_rvalue; eauto. intros [SL2 [TY2 EV2]]. exploit step_tr_rvalof; eauto. intros [le' [EXEC [EV3 [TY3 INV]]]]. subst; simpl Kseqlist. econstructor; split. right; split. rewrite app_ass. rewrite Kseqlist_app. eexact EXEC. - simpl. omega. + simpl. lia. constructor. -(* postincr *) - exploit tr_top_leftcontext; eauto. clear H14. +- (* postincr *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H5. - (* for effects *) ++ (* for effects *) exploit tr_simple_lvalue; eauto. intros [SL1 [TY1 EV1]]. exploit step_tr_rvalof; eauto. intros [le' [EXEC [EV3 [TY3 INV]]]]. exploit tr_simple_lvalue. eauto. eapply tr_expr_invariant with (le := le) (le' := le'). eauto. intros. apply INV. NOTIN. intros [? [? EV1']]. + assert (bf0 = bf) by (eapply is_bitfield_access_sound; eauto). subst; simpl Kseqlist. econstructor; split. left. rewrite app_ass; rewrite Kseqlist_app. @@ -1810,14 +1924,15 @@ Proof. econstructor. eauto. constructor. rewrite TY3; rewrite <- TY1; rewrite comp_env_preserved. simpl; eauto. destruct id; auto. reflexivity. traceEq. - econstructor. auto. change sl2 with (nil ++ sl2). apply S. - constructor. auto. auto. auto. - (* for value *) + econstructor; eauto. change sl2 with (nil ++ sl2). apply S. + constructor. auto. auto. ++ (* for value *) exploit tr_simple_lvalue; eauto. intros [SL1 [TY1 EV1]]. exploit tr_simple_lvalue. eauto. eapply tr_expr_invariant with (le' := PTree.set t v1 le). eauto. intros. apply PTree.gso. intuition congruence. intros [SL2 [TY2 EV2]]. + assert (bf0 = bf) by (eapply is_bitfield_access_sound; eauto). subst; simpl Kseqlist. econstructor; split. left. eapply plus_four. constructor. @@ -1831,47 +1946,48 @@ Proof. rewrite comp_env_preserved; simpl; eauto. destruct id; auto. traceEq. - econstructor. auto. apply S. + econstructor; eauto. apply S. apply tr_val_gen. auto. intros. econstructor; eauto. rewrite H5; auto. apply PTree.gss. intros. apply PTree.gso. intuition congruence. - auto. auto. -(* postincr stuck *) - exploit tr_top_leftcontext; eauto. clear H11. + auto. +- (* postincr stuck *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H3. - (* for effects *) ++ (* for effects *) exploit tr_simple_lvalue; eauto. intros [SL1 [TY1 EV1]]. exploit step_tr_rvalof; eauto. intros [le' [EXEC [EV3 [TY3 INV]]]]. subst. simpl Kseqlist. econstructor; split. right; split. rewrite app_ass; rewrite Kseqlist_app. eexact EXEC. - simpl; omega. + simpl; lia. constructor. - (* for value *) ++ (* for value *) exploit tr_simple_lvalue; eauto. intros [SL1 [TY1 EV1]]. + assert (bf0 = bf) by (eapply is_bitfield_access_sound; eauto). subst. simpl Kseqlist. econstructor; split. left. eapply plus_two. constructor. eapply step_make_set; eauto. traceEq. constructor. -(* comma *) - exploit tr_top_leftcontext; eauto. clear H9. +- (* comma *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H1. exploit tr_simple_rvalue; eauto. simpl; intro SL1. subst sl0; simpl Kseqlist. econstructor; split. right; split. apply star_refl. simpl. apply plus_lt_compat_r. - apply (leftcontext_size _ _ _ H). simpl. omega. + apply (leftcontext_size _ _ _ H). simpl. lia. econstructor; eauto. apply S. eapply tr_expr_monotone; eauto. auto. auto. -(* paren *) - exploit tr_top_leftcontext; eauto. clear H9. +- (* paren *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H2. - (* for value *) ++ (* for value *) exploit tr_simple_rvalue; eauto. intros [b [SL1 [TY1 EV1]]]. subst sl1; simpl Kseqlist. econstructor; split. @@ -1882,14 +1998,14 @@ Proof. constructor. auto. intros. constructor. rewrite H2; auto. apply PTree.gss. intros. apply PTree.gso. intuition congruence. auto. - (* for effects *) ++ (* for effects *) econstructor; split. right; split. apply star_refl. simpl. apply plus_lt_compat_r. - apply (leftcontext_size _ _ _ H). simpl. omega. + apply (leftcontext_size _ _ _ H). simpl. lia. econstructor; eauto. exploit tr_simple_rvalue; eauto. simpl. intros A. subst sl1. apply S. constructor; auto. auto. auto. - (* for set *) ++ (* for set *) exploit tr_simple_rvalue; eauto. simpl. intros [b [SL1 [TY1 EV1]]]. subst sl1. simpl Kseqlist. econstructor; split. @@ -1901,46 +2017,46 @@ Proof. intros. apply PTree.gso. congruence. auto. -(* call *) - exploit tr_top_leftcontext; eauto. clear H12. +- (* call *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H5. - (* for effects *) ++ (* for effects *) exploit tr_simple_rvalue; eauto. intros [SL1 [TY1 EV1]]. exploit tr_simple_exprlist; eauto. intros [SL2 EV2]. subst. simpl Kseqlist. - exploit functions_translated; eauto. intros [tfd [J K]]. + exploit functions_translated; eauto. intros (cu' & tfd & J & K & L). econstructor; split. left. eapply plus_left. constructor. apply star_one. econstructor; eauto. rewrite <- TY1; eauto. exploit type_of_fundef_preserved; eauto. congruence. traceEq. - constructor; auto. econstructor; eauto. + econstructor. eexact L. eauto. econstructor. eexact LINK. auto. auto. intros. change sl2 with (nil ++ sl2). apply S. - constructor. auto. auto. - (* for value *) + constructor. auto. auto. auto. ++ (* for value *) exploit tr_simple_rvalue; eauto. intros [SL1 [TY1 EV1]]. exploit tr_simple_exprlist; eauto. intros [SL2 EV2]. subst. simpl Kseqlist. - exploit functions_translated; eauto. intros [tfd [J K]]. + exploit functions_translated; eauto. intros (cu' & tfd & J & K & L). econstructor; split. left. eapply plus_left. constructor. apply star_one. econstructor; eauto. rewrite <- TY1; eauto. exploit type_of_fundef_preserved; eauto. congruence. traceEq. - constructor; auto. econstructor; eauto. + econstructor. eexact L. eauto. econstructor. eexact LINK. auto. auto. intros. apply S. destruct dst'; constructor. auto. intros. constructor. rewrite H5; auto. apply PTree.gss. auto. intros. constructor. rewrite H5; auto. apply PTree.gss. intros. apply PTree.gso. intuition congruence. - auto. + auto. auto. -(* builtin *) - exploit tr_top_leftcontext; eauto. clear H9. +- (* builtin *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H2. - (* for effects *) ++ (* for effects *) exploit tr_simple_exprlist; eauto. intros [SL EV]. subst. simpl Kseqlist. econstructor; split. @@ -1950,7 +2066,7 @@ Proof. traceEq. econstructor; eauto. change sl2 with (nil ++ sl2). apply S. constructor. simpl; auto. auto. - (* for value *) ++ (* for value *) exploit tr_simple_exprlist; eauto. intros [SL EV]. subst. simpl Kseqlist. econstructor; split. @@ -1968,8 +2084,8 @@ Qed. (** Forward simulation for statements. *) Lemma tr_top_val_for_val_inv: - forall e le m v ty sl a tmps, - tr_top tge e le m For_val (Csyntax.Eval v ty) sl a tmps -> + forall ce e le m v ty sl a tmps, + tr_top ce tge e le m For_val (Csyntax.Eval v ty) sl a tmps -> sl = nil /\ typeof a = ty /\ eval_expr tge e le m a v. Proof. intros. inv H. auto. inv H0. auto. @@ -2011,264 +2127,263 @@ Lemma sstep_simulation: /\ match_states S2 S2'. Proof. induction 1; intros; inv MS. -(* do 1 *) - inv H6. inv H0. +- (* do 1 *) + inv TR. inv H0. econstructor; split. right; split. apply push_seq. - simpl. omega. + simpl. lia. econstructor; eauto. constructor. auto. -(* do 2 *) - inv H7. inv H6. inv H. +- (* do 2 *) + inv MK. inv TR. inv H. econstructor; split. - right; split. apply star_refl. simpl. omega. + right; split. apply star_refl. simpl. lia. econstructor; eauto. constructor. -(* seq *) - inv H6. econstructor; split. left. apply plus_one. constructor. +- (* seq *) + inv TR. econstructor; split. left. apply plus_one. constructor. econstructor; eauto. constructor; auto. -(* skip seq *) - inv H6; inv H7. econstructor; split. +- (* skip seq *) + inv TR; inv MK. econstructor; split. left. apply plus_one; constructor. econstructor; eauto. -(* continue seq *) - inv H6; inv H7. econstructor; split. +- (* continue seq *) + inv TR; inv MK. econstructor; split. left. apply plus_one; constructor. econstructor; eauto. constructor. -(* break seq *) - inv H6; inv H7. econstructor; split. +- (* break seq *) + inv TR; inv MK. econstructor; split. left. apply plus_one; constructor. econstructor; eauto. constructor. -(* ifthenelse *) - inv H6. -(* ifthenelse empty *) +- (* ifthenelse *) + inv TR. ++ (* ifthenelse empty *) inv H3. econstructor; split. left. eapply plus_left. constructor. apply push_seq. econstructor; eauto. econstructor; eauto. econstructor; eauto. -(* ifthenelse non empty *) ++ (* ifthenelse non empty *) inv H2. econstructor; split. left. eapply plus_left. constructor. apply push_seq. traceEq. econstructor; eauto. econstructor; eauto. -(* ifthenelse *) - inv H8. -(* ifthenelse empty *) +- (* ifthenelse *) + inv MK. ++ (* ifthenelse empty *) exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. econstructor; split; simpl. right. destruct b; econstructor; eauto. eapply star_left. apply step_skip_seq. econstructor. traceEq. eapply star_left. apply step_skip_seq. econstructor. traceEq. destruct b; econstructor; eauto. econstructor; eauto. econstructor; eauto. - (* ifthenelse non empty *) ++ (* ifthenelse non empty *) exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. econstructor; split. left. eapply plus_two. constructor. apply step_ifthenelse with (v1 := v) (b := b); auto. traceEq. destruct b; econstructor; eauto. -(* while *) - inv H6. inv H1. econstructor; split. +- (* while *) + inv TR. inv H1. econstructor; split. left. eapply plus_left. constructor. eapply star_left. constructor. apply push_seq. reflexivity. traceEq. rewrite Kseqlist_app. - econstructor; eauto. simpl. econstructor; eauto. econstructor; eauto. -(* while false *) - inv H8. + econstructor; eauto. simpl. econstructor; eauto. econstructor; eauto. +- (* while false *) + inv MK. exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. econstructor; split. left. simpl. eapply plus_left. constructor. eapply star_trans. apply step_makeif with (v1 := v) (b := false); auto. eapply star_two. constructor. apply step_break_loop1. reflexivity. reflexivity. traceEq. - constructor; auto. constructor. -(* while true *) - inv H8. + econstructor; eauto. constructor. +- (* while true *) + inv MK. exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. econstructor; split. left. simpl. eapply plus_left. constructor. eapply star_right. apply step_makeif with (v1 := v) (b := true); auto. constructor. reflexivity. traceEq. - constructor; auto. constructor; auto. -(* skip-or-continue while *) - assert (ts = Sskip \/ ts = Scontinue). destruct H; subst s0; inv H7; auto. - inv H8. + econstructor; eauto. constructor; auto. +- (* skip-or-continue while *) + assert (ts = Sskip \/ ts = Scontinue). { destruct H; subst s0; inv TR; auto. } + inv MK. econstructor; split. left. eapply plus_two. apply step_skip_or_continue_loop1; auto. apply step_skip_loop2. traceEq. - constructor; auto. constructor; auto. -(* break while *) - inv H6. inv H7. + econstructor; eauto. constructor; auto. +- (* break while *) + inv TR. inv MK. econstructor; split. left. apply plus_one. apply step_break_loop1. - constructor; auto. constructor. + econstructor; eauto. constructor. -(* dowhile *) - inv H6. +- (* dowhile *) + inv TR. econstructor; split. left. apply plus_one. apply step_loop. - constructor; auto. constructor; auto. -(* skip_or_continue dowhile *) - assert (ts = Sskip \/ ts = Scontinue). destruct H; subst s0; inv H7; auto. - inv H8. inv H4. + econstructor; eauto. constructor; auto. +- (* skip_or_continue dowhile *) + assert (ts = Sskip \/ ts = Scontinue). { destruct H; subst s0; inv TR; auto. } + inv MK. inv H5. econstructor; split. left. eapply plus_left. apply step_skip_or_continue_loop1. auto. apply push_seq. traceEq. rewrite Kseqlist_app. econstructor; eauto. simpl. econstructor; auto. econstructor; eauto. -(* dowhile false *) - inv H8. +- (* dowhile false *) + inv MK. exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. econstructor; split. left. simpl. eapply plus_left. constructor. eapply star_right. apply step_makeif with (v1 := v) (b := false); auto. constructor. reflexivity. traceEq. - constructor; auto. constructor. -(* dowhile true *) - inv H8. + econstructor; eauto. constructor. +- (* dowhile true *) + inv MK. exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. econstructor; split. left. simpl. eapply plus_left. constructor. eapply star_right. apply step_makeif with (v1 := v) (b := true); auto. constructor. reflexivity. traceEq. - constructor; auto. constructor; auto. -(* break dowhile *) - inv H6. inv H7. + econstructor; eauto. constructor; auto. +- (* break dowhile *) + inv TR. inv MK. econstructor; split. left. apply plus_one. apply step_break_loop1. - constructor; auto. constructor. + econstructor; eauto. constructor. -(* for start *) - inv H7. congruence. +- (* for start *) + inv TR. congruence. econstructor; split. left; apply plus_one. constructor. econstructor; eauto. constructor; auto. econstructor; eauto. -(* for *) - inv H6; try congruence. inv H2. +- (* for *) + inv TR; try congruence. inv H2. econstructor; split. left. eapply plus_left. apply step_loop. eapply star_left. constructor. apply push_seq. reflexivity. traceEq. rewrite Kseqlist_app. econstructor; eauto. simpl. constructor; auto. econstructor; eauto. -(* for false *) - inv H8. exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. +- (* for false *) + inv MK. exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. econstructor; split. left. simpl. eapply plus_left. constructor. eapply star_trans. apply step_makeif with (v1 := v) (b := false); auto. eapply star_two. constructor. apply step_break_loop1. reflexivity. reflexivity. traceEq. - constructor; auto. constructor. -(* for true *) - inv H8. exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. + econstructor; eauto. constructor. +- (* for true *) + inv MK. exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. econstructor; split. left. simpl. eapply plus_left. constructor. eapply star_right. apply step_makeif with (v1 := v) (b := true); auto. constructor. reflexivity. traceEq. - constructor; auto. constructor; auto. -(* skip_or_continue for3 *) - assert (ts = Sskip \/ ts = Scontinue). destruct H; subst x; inv H7; auto. - inv H8. + econstructor; eauto. constructor; auto. +- (* skip_or_continue for3 *) + assert (ts = Sskip \/ ts = Scontinue). { destruct H; subst x; inv TR; auto. } + inv MK. econstructor; split. left. apply plus_one. apply step_skip_or_continue_loop1. auto. econstructor; eauto. econstructor; auto. -(* break for3 *) - inv H6. inv H7. +- (* break for3 *) + inv TR. inv MK. econstructor; split. left. apply plus_one. apply step_break_loop1. econstructor; eauto. constructor. -(* skip for4 *) - inv H6. inv H7. +- (* skip for4 *) + inv TR. inv MK. econstructor; split. left. apply plus_one. constructor. econstructor; eauto. constructor; auto. - -(* return none *) - inv H7. econstructor; split. +- (* return none *) + inv TR. econstructor; split. left. apply plus_one. econstructor; eauto. rewrite blocks_of_env_preserved; eauto. - constructor. apply match_cont_call; auto. -(* return some 1 *) - inv H6. inv H0. econstructor; split. + econstructor. intros; eapply match_cont_call_cont; eauto. +- (* return some 1 *) + inv TR. inv H0. econstructor; split. left; eapply plus_left. constructor. apply push_seq. traceEq. econstructor; eauto. constructor. auto. -(* return some 2 *) - inv H9. exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. +- (* return some 2 *) + inv MK. exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. econstructor; split. left. eapply plus_two. constructor. econstructor. eauto. erewrite function_return_preserved; eauto. rewrite blocks_of_env_preserved; eauto. eauto. traceEq. - constructor. apply match_cont_call; auto. -(* skip return *) - inv H8. - assert (is_call_cont tk). inv H9; simpl in *; auto. + econstructor. intros; eapply match_cont_call_cont; eauto. +- (* skip return *) + inv TR. + assert (is_call_cont tk). { inv MK; simpl in *; auto. } econstructor; split. left. apply plus_one. apply step_skip_call; eauto. rewrite blocks_of_env_preserved; eauto. - constructor. auto. + econstructor. intros; eapply match_cont_is_call_cont; eauto. -(* switch *) - inv H6. inv H1. +- (* switch *) + inv TR. inv H1. econstructor; split. left; eapply plus_left. constructor. apply push_seq. traceEq. econstructor; eauto. constructor; auto. -(* expr switch *) - inv H8. exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. +- (* expr switch *) + inv MK. exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. econstructor; split. left; eapply plus_two. constructor. econstructor; eauto. traceEq. econstructor; eauto. apply tr_seq_of_labeled_statement. apply tr_select_switch. auto. constructor; auto. -(* skip-or-break switch *) - assert (ts = Sskip \/ ts = Sbreak). destruct H; subst x; inv H7; auto. - inv H8. +- (* skip-or-break switch *) + assert (ts = Sskip \/ ts = Sbreak). { destruct H; subst x; inv TR; auto. } + inv MK. econstructor; split. left; apply plus_one. apply step_skip_break_switch. auto. - constructor; auto. constructor. + econstructor; eauto. constructor. -(* continue switch *) - inv H6. inv H7. +- (* continue switch *) + inv TR. inv MK. econstructor; split. left; apply plus_one. apply step_continue_switch. - constructor; auto. constructor. + econstructor; eauto. constructor. -(* label *) - inv H6. econstructor; split. +- (* label *) + inv TR. econstructor; split. left; apply plus_one. constructor. - constructor; auto. + econstructor; eauto. -(* goto *) - inv H7. - inversion H6; subst. - exploit tr_find_label. eauto. apply match_cont_call. eauto. +- (* goto *) + inv TR. + inversion TRF; subst. + exploit tr_find_label. eauto. eapply match_cont_call_cont; eauto. instantiate (1 := lbl). rewrite H. intros [ts' [tk' [P [Q R]]]]. econstructor; split. left. apply plus_one. econstructor; eauto. econstructor; eauto. -(* internal function *) - inv H7. inversion H3; subst. +- (* internal function *) + inv TR. inversion H3; subst. econstructor; split. left; apply plus_one. eapply step_internal_function. econstructor. rewrite H6; rewrite H7; auto. rewrite H6; rewrite H7. eapply alloc_variables_preserved; eauto. rewrite H6. eapply bind_parameters_preserved; eauto. eauto. - constructor; auto. + econstructor; eauto. -(* external function *) - inv H5. +- (* external function *) + inv TR. econstructor; split. left; apply plus_one. econstructor; eauto. eapply external_call_symbols_preserved; eauto. apply senv_preserved. - constructor; auto. + econstructor; eauto. -(* return *) - inv H3. +- (* return *) + specialize (MK (PTree.empty _)). inv MK. econstructor; split. left; apply plus_one. constructor. econstructor; eauto. @@ -2295,7 +2410,7 @@ Lemma transl_initial_states: exists S', Clight.initial_state tprog S' /\ match_states S S'. Proof. intros. inv H. - exploit function_ptr_translated; eauto. intros [tf [FIND TR]]. + exploit function_ptr_translated; eauto. intros (cu & tf & FIND & TR & L). econstructor; split. econstructor. eapply (Genv.init_mem_match (proj1 TRANSL)); eauto. @@ -2303,15 +2418,15 @@ Proof. rewrite symbols_preserved. eauto. destruct TRANSL. destruct H as (A & B & C). simpl in B. auto. eexact FIND. - rewrite <- H3. apply type_of_fundef_preserved. auto. - constructor. auto. constructor. + rewrite <- H3. eapply type_of_fundef_preserved; eauto. + econstructor; eauto. intros; constructor. Qed. Lemma transl_final_states: forall S S' r, match_states S S' -> Csem.final_state S r -> Clight.final_state S' r. Proof. - intros. inv H0. inv H. inv H4. constructor. + intros. inv H0. inv H. specialize (MK (PTree.empty _)). inv MK. constructor. Qed. Theorem transl_program_correct: @@ -2331,13 +2446,13 @@ End PRESERVATION. Instance TransfSimplExprLink : TransfLink match_prog. Proof. - red; intros. eapply Ctypes.link_match_program; eauto. + red; intros. eapply Ctypes.link_match_program_gen; eauto. - intros. Local Transparent Linker_fundef. simpl in *; unfold link_fundef in *. inv H3; inv H4; try discriminate. - destruct ef; inv H2. exists (Internal tf); split; auto. constructor; auto. - destruct ef; inv H2. exists (Internal tf); split; auto. constructor; auto. + destruct ef; inv H2. exists (Internal tf); split; auto. left; constructor; auto. + destruct ef; inv H2. exists (Internal tf); split; auto. right; constructor; auto. destruct (external_function_eq ef ef0 && typelist_eq targs targs0 && type_eq tres tres0 && calling_convention_eq cconv cconv0); inv H2. - exists (External ef targs tres cconv); split; auto. constructor. + exists (External ef targs tres cconv); split; auto. left; constructor. Qed. diff --git a/cfrontend/SimplExprspec.v b/cfrontend/SimplExprspec.v index 98425311..b689bdeb 100644 --- a/cfrontend/SimplExprspec.v +++ b/cfrontend/SimplExprspec.v @@ -18,6 +18,8 @@ Require Import Ctypes Cop Csyntax Clight SimplExpr. Section SPEC. +Variable ce: composite_env. + Local Open Scope gensym_monad_scope. (** * Relational specification of the translation. *) @@ -40,13 +42,28 @@ Definition final (dst: destination) (a: expr) : list statement := | For_set sd => do_set sd a end. +Definition tr_is_bitfield_access (l: expr) (bf: bitfield) : Prop := + match l with + | Efield r f _ => + exists co ofs, + match typeof r with + | Tstruct id _ => + ce!id = Some co /\ field_offset ce f (co_members co) = OK (ofs, bf) + | Tunion id _ => + ce!id = Some co /\ union_field_offset ce f (co_members co) = OK (ofs, bf) + | _ => False + end + | _ => bf = Full + end. + Inductive tr_rvalof: type -> expr -> list statement -> expr -> list ident -> Prop := | tr_rvalof_nonvol: forall ty a tmp, type_is_volatile ty = false -> tr_rvalof ty a nil a tmp - | tr_rvalof_vol: forall ty a t tmp, + | tr_rvalof_vol: forall ty a t bf tmp, type_is_volatile ty = true -> In t tmp -> - tr_rvalof ty a (make_set t a :: nil) (Etempvar t ty) tmp. + tr_is_bitfield_access a bf -> + tr_rvalof ty a (make_set bf t a :: nil) (Etempvar t ty) tmp. Inductive tr_expr: temp_env -> destination -> Csyntax.expr -> list statement -> expr -> list ident -> Prop := | tr_var: forall le dst id ty tmp, @@ -200,15 +217,16 @@ Inductive tr_expr: temp_env -> destination -> Csyntax.expr -> list statement -> tr_expr le (For_set sd) (Csyntax.Econdition e1 e2 e3 ty) (sl1 ++ makeif a1 (makeseq sl2) (makeseq sl3) :: nil) any tmp - | tr_assign_effects: forall le e1 e2 ty sl1 a1 tmp1 sl2 a2 tmp2 any tmp, + | tr_assign_effects: forall le e1 e2 ty sl1 a1 tmp1 sl2 a2 tmp2 bf any tmp, tr_expr le For_val e1 sl1 a1 tmp1 -> tr_expr le For_val e2 sl2 a2 tmp2 -> list_disjoint tmp1 tmp2 -> incl tmp1 tmp -> incl tmp2 tmp -> + tr_is_bitfield_access a1 bf -> tr_expr le For_effects (Csyntax.Eassign e1 e2 ty) - (sl1 ++ sl2 ++ make_assign a1 a2 :: nil) + (sl1 ++ sl2 ++ make_assign bf a1 a2 :: nil) any tmp - | tr_assign_val: forall le dst e1 e2 ty sl1 a1 tmp1 sl2 a2 tmp2 t tmp ty1 ty2, + | tr_assign_val: forall le dst e1 e2 ty sl1 a1 tmp1 sl2 a2 tmp2 t tmp ty1 ty2 bf, tr_expr le For_val e1 sl1 a1 tmp1 -> tr_expr le For_val e2 sl2 a2 tmp2 -> incl tmp1 tmp -> incl tmp2 tmp -> @@ -216,23 +234,25 @@ Inductive tr_expr: temp_env -> destination -> Csyntax.expr -> list statement -> In t tmp -> ~In t tmp1 -> ~In t tmp2 -> ty1 = Csyntax.typeof e1 -> ty2 = Csyntax.typeof e2 -> + tr_is_bitfield_access a1 bf -> tr_expr le dst (Csyntax.Eassign e1 e2 ty) (sl1 ++ sl2 ++ Sset t (Ecast a2 ty1) :: - make_assign a1 (Etempvar t ty1) :: - final dst (Etempvar t ty1)) - (Etempvar t ty1) tmp - | tr_assignop_effects: forall le op e1 e2 tyres ty ty1 sl1 a1 tmp1 sl2 a2 tmp2 sl3 a3 tmp3 any tmp, + make_assign bf a1 (Etempvar t ty1) :: + final dst (make_assign_value bf (Etempvar t ty1))) + (make_assign_value bf (Etempvar t ty1)) tmp + | tr_assignop_effects: forall le op e1 e2 tyres ty ty1 sl1 a1 tmp1 sl2 a2 tmp2 bf sl3 a3 tmp3 any tmp, tr_expr le For_val e1 sl1 a1 tmp1 -> tr_expr le For_val e2 sl2 a2 tmp2 -> ty1 = Csyntax.typeof e1 -> tr_rvalof ty1 a1 sl3 a3 tmp3 -> list_disjoint tmp1 tmp2 -> list_disjoint tmp1 tmp3 -> list_disjoint tmp2 tmp3 -> incl tmp1 tmp -> incl tmp2 tmp -> incl tmp3 tmp -> + tr_is_bitfield_access a1 bf -> tr_expr le For_effects (Csyntax.Eassignop op e1 e2 tyres ty) - (sl1 ++ sl2 ++ sl3 ++ make_assign a1 (Ebinop op a3 a2 tyres) :: nil) + (sl1 ++ sl2 ++ sl3 ++ make_assign bf a1 (Ebinop op a3 a2 tyres) :: nil) any tmp - | tr_assignop_val: forall le dst op e1 e2 tyres ty sl1 a1 tmp1 sl2 a2 tmp2 sl3 a3 tmp3 t tmp ty1, + | tr_assignop_val: forall le dst op e1 e2 tyres ty sl1 a1 tmp1 sl2 a2 tmp2 sl3 a3 tmp3 t bf tmp ty1, tr_expr le For_val e1 sl1 a1 tmp1 -> tr_expr le For_val e2 sl2 a2 tmp2 -> tr_rvalof ty1 a1 sl3 a3 tmp3 -> @@ -240,28 +260,31 @@ Inductive tr_expr: temp_env -> destination -> Csyntax.expr -> list statement -> incl tmp1 tmp -> incl tmp2 tmp -> incl tmp3 tmp -> In t tmp -> ~In t tmp1 -> ~In t tmp2 -> ~In t tmp3 -> ty1 = Csyntax.typeof e1 -> + tr_is_bitfield_access a1 bf -> tr_expr le dst (Csyntax.Eassignop op e1 e2 tyres ty) (sl1 ++ sl2 ++ sl3 ++ Sset t (Ecast (Ebinop op a3 a2 tyres) ty1) :: - make_assign a1 (Etempvar t ty1) :: - final dst (Etempvar t ty1)) - (Etempvar t ty1) tmp - | tr_postincr_effects: forall le id e1 ty ty1 sl1 a1 tmp1 sl2 a2 tmp2 any tmp, + make_assign bf a1 (Etempvar t ty1) :: + final dst (make_assign_value bf (Etempvar t ty1))) + (make_assign_value bf (Etempvar t ty1)) tmp + | tr_postincr_effects: forall le id e1 ty ty1 sl1 a1 tmp1 sl2 a2 tmp2 bf any tmp, tr_expr le For_val e1 sl1 a1 tmp1 -> tr_rvalof ty1 a1 sl2 a2 tmp2 -> ty1 = Csyntax.typeof e1 -> incl tmp1 tmp -> incl tmp2 tmp -> list_disjoint tmp1 tmp2 -> + tr_is_bitfield_access a1 bf -> tr_expr le For_effects (Csyntax.Epostincr id e1 ty) - (sl1 ++ sl2 ++ make_assign a1 (transl_incrdecr id a2 ty1) :: nil) + (sl1 ++ sl2 ++ make_assign bf a1 (transl_incrdecr id a2 ty1) :: nil) any tmp - | tr_postincr_val: forall le dst id e1 ty sl1 a1 tmp1 t ty1 tmp, + | tr_postincr_val: forall le dst id e1 ty sl1 a1 tmp1 bf t ty1 tmp, tr_expr le For_val e1 sl1 a1 tmp1 -> incl tmp1 tmp -> In t tmp -> ~In t tmp1 -> ty1 = Csyntax.typeof e1 -> + tr_is_bitfield_access a1 bf -> tr_expr le dst (Csyntax.Epostincr id e1 ty) - (sl1 ++ make_set t a1 :: - make_assign a1 (transl_incrdecr id (Etempvar t ty1) ty1) :: + (sl1 ++ make_set bf t a1 :: + make_assign bf a1 (transl_incrdecr id (Etempvar t ty1) ty1) :: final dst (Etempvar t ty1)) (Etempvar t ty1) tmp | tr_comma: forall le dst e1 e2 ty sl1 a1 tmp1 sl2 a2 tmp2 tmp, @@ -746,14 +769,31 @@ Proof. intros. apply tr_expr_monotone with tmps; auto. apply add_dest_incl. Qed. +Lemma is_bitfield_access_meets_spec: forall l g bf g' I, + is_bitfield_access ce l g = Res bf g' I -> + tr_is_bitfield_access l bf. +Proof. + unfold is_bitfield_access; intros; red. destruct l; try (monadInv H; auto). + assert (AUX: forall fn id, + is_bitfield_access_aux ce fn id i g = Res bf g' I -> + exists co ofs, + ce!id = Some co /\ fn ce i (co_members co) = OK (ofs, bf)). + { unfold is_bitfield_access_aux; intros. + destruct ce!id as [co|]; try discriminate. + destruct (fn ce i (co_members co)) as [[ofs1 bf1]|] eqn:FN; inv H0. + exists co, ofs1; auto. } + destruct (typeof l); try discriminate; apply AUX; auto. +Qed. + Lemma transl_valof_meets_spec: forall ty a g sl b g' I, - transl_valof ty a g = Res (sl, b) g' I -> + transl_valof ce ty a g = Res (sl, b) g' I -> exists tmps, tr_rvalof ty a sl b tmps /\ contained tmps g g'. Proof. unfold transl_valof; intros. destruct (type_is_volatile ty) eqn:?; monadInv H. - exists (x :: nil); split; eauto with gensym. econstructor; eauto with coqlib. + exists (x :: nil); split; eauto with gensym. + econstructor; eauto using is_bitfield_access_meets_spec with coqlib. exists (@nil ident); split; eauto with gensym. constructor; auto. Qed. @@ -763,12 +803,12 @@ Combined Scheme expr_exprlist_ind from expr_ind2, exprlist_ind2. Lemma transl_meets_spec: (forall r dst g sl a g' I, - transl_expr dst r g = Res (sl, a) g' I -> + transl_expr ce dst r g = Res (sl, a) g' I -> dest_below dst g -> exists tmps, (forall le, tr_expr le dst r sl a (add_dest dst tmps)) /\ contained tmps g g') /\ (forall rl g sl al g' I, - transl_exprlist rl g = Res (sl, al) g' I -> + transl_exprlist ce rl g = Res (sl, al) g' I -> exists tmps, (forall le, tr_exprlist le rl sl al tmps) /\ contained tmps g g'). Proof. apply expr_exprlist_ind; simpl add_dest; intros. @@ -920,9 +960,10 @@ Opaque makeif. - (* assign *) monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. exploit H0; eauto. intros [tmp2 [Csyntax D]]. - destruct dst; monadInv EQ2; simpl add_dest in *. + apply is_bitfield_access_meets_spec in EQ0. + destruct dst; monadInv EQ3; simpl add_dest in *. + (* for value *) - exists (x1 :: tmp1 ++ tmp2); split. + exists (x2 :: tmp1 ++ tmp2); split. intros. eapply tr_assign_val with (dst := For_val); eauto with gensym. apply contained_cons. eauto with gensym. apply contained_app; eauto with gensym. @@ -931,7 +972,7 @@ Opaque makeif. econstructor; eauto with gensym. apply contained_app; eauto with gensym. + (* for set *) - exists (x1 :: tmp1 ++ tmp2); split. + exists (x2 :: tmp1 ++ tmp2); split. repeat rewrite app_ass. simpl. intros. eapply tr_assign_val with (dst := For_set sd); eauto with gensym. apply contained_cons. eauto with gensym. @@ -940,37 +981,39 @@ Opaque makeif. monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. exploit H0; eauto. intros [tmp2 [Csyntax D]]. exploit transl_valof_meets_spec; eauto. intros [tmp3 [E F]]. - destruct dst; monadInv EQ3; simpl add_dest in *. + apply is_bitfield_access_meets_spec in EQ2. + destruct dst; monadInv EQ4; simpl add_dest in *. + (* for value *) - exists (x2 :: tmp1 ++ tmp2 ++ tmp3); split. - intros. eapply tr_assignop_val with (dst := For_val); eauto with gensym. - apply contained_cons. eauto with gensym. - apply contained_app; eauto with gensym. + exists (x3 :: tmp1 ++ tmp2 ++ tmp3); split. + intros. eapply tr_assignop_val with (dst := For_val); eauto 6 with gensym. + apply contained_cons. eauto 6 with gensym. + apply contained_app; eauto 6 with gensym. + (* for effects *) exists (tmp1 ++ tmp2 ++ tmp3); split. econstructor; eauto with gensym. apply contained_app; eauto with gensym. + (* for set *) - exists (x2 :: tmp1 ++ tmp2 ++ tmp3); split. + exists (x3 :: tmp1 ++ tmp2 ++ tmp3); split. repeat rewrite app_ass. simpl. - intros. eapply tr_assignop_val with (dst := For_set sd); eauto with gensym. - apply contained_cons. eauto with gensym. - apply contained_app; eauto with gensym. + intros. eapply tr_assignop_val with (dst := For_set sd); eauto 6 with gensym. + apply contained_cons. eauto 6 with gensym. + apply contained_app; eauto 6 with gensym. - (* postincr *) monadInv H0. exploit H; eauto. intros [tmp1 [A B]]. - destruct dst; monadInv EQ0; simpl add_dest in *. + apply is_bitfield_access_meets_spec in EQ1. + destruct dst; monadInv EQ2; simpl add_dest in *. + (* for value *) - exists (x0 :: tmp1); split. + exists (x1 :: tmp1); split. econstructor; eauto with gensym. apply contained_cons; eauto with gensym. + (* for effects *) - exploit transl_valof_meets_spec; eauto. intros [tmp2 [Csyntax D]]. + exploit transl_valof_meets_spec; eauto. intros [tmp2 [C D]]. exists (tmp1 ++ tmp2); split. econstructor; eauto with gensym. eauto with gensym. + (* for set *) repeat rewrite app_ass; simpl. - exists (x0 :: tmp1); split. + exists (x1 :: tmp1); split. econstructor; eauto with gensym. apply contained_cons; eauto with gensym. - (* comma *) @@ -1032,7 +1075,7 @@ Qed. Lemma transl_expr_meets_spec: forall r dst g sl a g' I, - transl_expr dst r g = Res (sl, a) g' I -> + transl_expr ce dst r g = Res (sl, a) g' I -> dest_below dst g -> exists tmps, forall ge e le m, tr_top ge e le m dst r sl a tmps. Proof. @@ -1042,7 +1085,7 @@ Qed. Lemma transl_expression_meets_spec: forall r g s a g' I, - transl_expression r g = Res (s, a) g' I -> + transl_expression ce r g = Res (s, a) g' I -> tr_expression r s a. Proof. intros. monadInv H. exploit transl_expr_meets_spec; eauto. @@ -1051,7 +1094,7 @@ Qed. Lemma transl_expr_stmt_meets_spec: forall r g s g' I, - transl_expr_stmt r g = Res s g' I -> + transl_expr_stmt ce r g = Res s g' I -> tr_expr_stmt r s. Proof. intros. monadInv H. exploit transl_expr_meets_spec; eauto. @@ -1060,7 +1103,7 @@ Qed. Lemma transl_if_meets_spec: forall r s1 s2 g s g' I, - transl_if r s1 s2 g = Res s g' I -> + transl_if ce r s1 s2 g = Res s g' I -> tr_if r s1 s2 s. Proof. intros. monadInv H. exploit transl_expr_meets_spec; eauto. @@ -1068,9 +1111,9 @@ Proof. Qed. Lemma transl_stmt_meets_spec: - forall s g ts g' I, transl_stmt s g = Res ts g' I -> tr_stmt s ts + forall s g ts g' I, transl_stmt ce s g = Res ts g' I -> tr_stmt s ts with transl_lblstmt_meets_spec: - forall s g ts g' I, transl_lblstmt s g = Res ts g' I -> tr_lblstmts s ts. + forall s g ts g' I, transl_lblstmt ce s g = Res ts g' I -> tr_lblstmts s ts. Proof. generalize transl_expression_meets_spec transl_expr_stmt_meets_spec transl_if_meets_spec; intros T1 T2 T3. Opaque transl_expression transl_expr_stmt. @@ -1099,32 +1142,32 @@ Inductive tr_function: Csyntax.function -> Clight.function -> Prop := fn_vars tf = Csyntax.fn_vars f -> tr_function f tf. -Inductive tr_fundef: Csyntax.fundef -> Clight.fundef -> Prop := - | tr_internal: forall f tf, - tr_function f tf -> - tr_fundef (Internal f) (Internal tf) - | tr_external: forall ef targs tres cconv, - tr_fundef (External ef targs tres cconv) (External ef targs tres cconv). - Lemma transl_function_spec: forall f tf, - transl_function f = OK tf -> + transl_function ce f = OK tf -> tr_function f tf. Proof. unfold transl_function; intros. - destruct (transl_stmt (Csyntax.fn_body f) (initial_generator tt)) eqn:T; inv H. + destruct (transl_stmt ce (Csyntax.fn_body f) (initial_generator tt)) eqn:T; inv H. constructor; auto. simpl. eapply transl_stmt_meets_spec; eauto. Qed. +End SPEC. + +Inductive tr_fundef (p: Csyntax.program): Csyntax.fundef -> Clight.fundef -> Prop := + | tr_internal: forall f tf, + tr_function p.(prog_comp_env) f tf -> + tr_fundef p (Internal f) (Internal tf) + | tr_external: forall ef targs tres cconv, + tr_fundef p (External ef targs tres cconv) (External ef targs tres cconv). + Lemma transl_fundef_spec: - forall fd tfd, - transl_fundef fd = OK tfd -> - tr_fundef fd tfd. + forall p fd tfd, + transl_fundef p.(prog_comp_env) fd = OK tfd -> + tr_fundef p fd tfd. Proof. unfold transl_fundef; intros. destruct fd; Errors.monadInv H. + constructor. eapply transl_function_spec; eauto. + constructor. Qed. - -End SPEC. diff --git a/cfrontend/SimplLocals.v b/cfrontend/SimplLocals.v index f54aa60d..0a164e29 100644 --- a/cfrontend/SimplLocals.v +++ b/cfrontend/SimplLocals.v @@ -18,7 +18,7 @@ Require FSetAVL. Require Import Coqlib Ordered Errors. Require Import AST Linking. Require Import Ctypes Cop Clight. -Require Compopts. +Require Compopts Conventions1. Open Scope error_monad_scope. Open Scope string_scope. @@ -157,15 +157,20 @@ with simpl_lblstmt (cenv: compilenv) (ls: labeled_statements) : res labeled_stat end. (** Function parameters that are not lifted to temporaries must be - stored in the corresponding local variable at function entry. *) + stored in the corresponding local variable at function entry. + The other function parameters may need to be normalized to their types, + to support interoperability with code generated by other C compilers. *) Fixpoint store_params (cenv: compilenv) (params: list (ident * type)) (s: statement): statement := match params with | nil => s | (id, ty) :: params' => - if VSet.mem id cenv - then store_params cenv params' s + if VSet.mem id cenv then + if Conventions1.parameter_needs_normalization (rettype_of_type ty) + then Ssequence (Sset id (make_cast (Etempvar id ty) ty)) + (store_params cenv params' s) + else store_params cenv params' s else Ssequence (Sassign (Evar id ty) (Etempvar id ty)) (store_params cenv params' s) end. diff --git a/cfrontend/SimplLocalsproof.v b/cfrontend/SimplLocalsproof.v index 2dd34389..e4b759c4 100644 --- a/cfrontend/SimplLocalsproof.v +++ b/cfrontend/SimplLocalsproof.v @@ -173,10 +173,10 @@ Proof. eapply H1; eauto. destruct (f' b) as [[b' delta]|] eqn:?; auto. exploit H2; eauto. unfold Mem.valid_block. intros [A B]. - xomegaContradiction. + extlia. intros. destruct (f b) as [[b'' delta']|] eqn:?. eauto. exploit H2; eauto. unfold Mem.valid_block. intros [A B]. - xomegaContradiction. + extlia. Qed. (** Properties of values resulting from a cast *) @@ -391,7 +391,7 @@ Lemma match_envs_assign_lifted: e!id = Some(b, ty) -> val_casted v ty -> Val.inject f v tv -> - assign_loc ge ty m b Ptrofs.zero v m' -> + assign_loc ge ty m b Ptrofs.zero Full v m' -> VSet.mem id cenv = true -> match_envs f cenv e le m' lo hi te (PTree.set id tv tle) tlo thi. Proof. @@ -606,7 +606,7 @@ Proof. generalize (alloc_variables_nextblock _ _ _ _ _ _ H0). intros A B C. subst b. split. apply Ple_refl. eapply Pos.lt_le_trans; eauto. rewrite B. apply Plt_succ. auto. - right. exploit Mem.nextblock_alloc; eauto. intros B. rewrite B in A. xomega. + right. exploit Mem.nextblock_alloc; eauto. intros B. rewrite B in A. extlia. Qed. Lemma alloc_variables_injective: @@ -622,12 +622,12 @@ Proof. repeat rewrite PTree.gsspec; intros. destruct (peq id1 id); destruct (peq id2 id). congruence. - inv H6. exploit Mem.alloc_result; eauto. exploit H2; eauto. unfold block; xomega. - inv H7. exploit Mem.alloc_result; eauto. exploit H2; eauto. unfold block; xomega. + inv H6. exploit Mem.alloc_result; eauto. exploit H2; eauto. unfold block; extlia. + inv H7. exploit Mem.alloc_result; eauto. exploit H2; eauto. unfold block; extlia. eauto. intros. rewrite PTree.gsspec in H6. destruct (peq id0 id). inv H6. - exploit Mem.alloc_result; eauto. exploit Mem.nextblock_alloc; eauto. unfold block; xomega. - exploit H2; eauto. exploit Mem.nextblock_alloc; eauto. unfold block; xomega. + exploit Mem.alloc_result; eauto. exploit Mem.nextblock_alloc; eauto. unfold block; extlia. + exploit H2; eauto. exploit Mem.nextblock_alloc; eauto. unfold block; extlia. Qed. Lemma match_alloc_variables: @@ -719,7 +719,7 @@ Proof. eapply Mem.valid_new_block; eauto. eapply Q; eauto. unfold Mem.valid_block in *. exploit Mem.nextblock_alloc. eexact A. exploit Mem.alloc_result. eexact A. - unfold block; xomega. + unfold block; extlia. split. intros. destruct (ident_eq id0 id). (* same var *) subst id0. @@ -760,7 +760,7 @@ Proof. destruct ty; try destruct i; try destruct s; try destruct f; inv H; auto; unfold Mptr; simpl; destruct Archi.ptr64; auto. } - omega. + lia. Qed. Definition env_initial_value (e: env) (m: mem) := @@ -778,7 +778,7 @@ Proof. apply IHalloc_variables. red; intros. rewrite PTree.gsspec in H2. destruct (peq id0 id). inv H2. eapply Mem.load_alloc_same'; eauto. - omega. rewrite Z.add_0_l. eapply sizeof_by_value; eauto. + lia. rewrite Z.add_0_l. eapply sizeof_by_value; eauto. apply Z.divide_0_r. eapply Mem.load_alloc_other; eauto. Qed. @@ -985,7 +985,7 @@ Proof. (* flat *) exploit alloc_variables_range. eexact A. eauto. rewrite PTree.gempty. intros [P|P]. congruence. - exploit K; eauto. unfold Mem.valid_block. xomega. + exploit K; eauto. unfold Mem.valid_block. extlia. intros [id0 [ty0 [U [V W]]]]. split; auto. destruct (ident_eq id id0). congruence. assert (b' <> b'). @@ -1004,13 +1004,13 @@ Proof. Qed. Lemma assign_loc_inject: - forall f ty m loc ofs v m' tm loc' ofs' v', - assign_loc ge ty m loc ofs v m' -> + forall f ty m loc ofs bf v m' tm loc' ofs' v', + assign_loc ge ty m loc ofs bf v m' -> Val.inject f (Vptr loc ofs) (Vptr loc' ofs') -> Val.inject f v v' -> Mem.inject f m tm -> exists tm', - assign_loc tge ty tm loc' ofs' v' tm' + assign_loc tge ty tm loc' ofs' bf v' tm' /\ Mem.inject f m' tm' /\ (forall b chunk v, f b = None -> Mem.load chunk m b 0 = Some v -> Mem.load chunk m' b 0 = Some v). @@ -1032,34 +1032,34 @@ Proof. + (* special case size = 0 *) assert (bytes = nil). { exploit (Mem.loadbytes_empty m bsrc (Ptrofs.unsigned osrc) (sizeof tge ty)). - omega. congruence. } + lia. congruence. } subst. destruct (Mem.range_perm_storebytes tm bdst' (Ptrofs.unsigned (Ptrofs.add odst (Ptrofs.repr delta))) nil) as [tm' SB]. - simpl. red; intros; omegaContradiction. + simpl. red; intros; extlia. exists tm'. split. eapply assign_loc_copy; eauto. - intros; omegaContradiction. - intros; omegaContradiction. - rewrite e; right; omega. - apply Mem.loadbytes_empty. omega. + intros; extlia. + intros; extlia. + rewrite e; right; lia. + apply Mem.loadbytes_empty. lia. split. eapply Mem.storebytes_empty_inject; eauto. intros. rewrite <- H0. eapply Mem.load_storebytes_other; eauto. left. congruence. + (* general case size > 0 *) exploit Mem.loadbytes_length; eauto. intros LEN. assert (SZPOS: sizeof tge ty > 0). - { generalize (sizeof_pos tge ty); omega. } + { generalize (sizeof_pos tge ty); lia. } assert (RPSRC: Mem.range_perm m bsrc (Ptrofs.unsigned osrc) (Ptrofs.unsigned osrc + sizeof tge ty) Cur Nonempty). eapply Mem.range_perm_implies. eapply Mem.loadbytes_range_perm; eauto. auto with mem. assert (RPDST: Mem.range_perm m bdst (Ptrofs.unsigned odst) (Ptrofs.unsigned odst + sizeof tge ty) Cur Nonempty). replace (sizeof tge ty) with (Z.of_nat (List.length bytes)). eapply Mem.range_perm_implies. eapply Mem.storebytes_range_perm; eauto. auto with mem. - rewrite LEN. apply Z2Nat.id. omega. + rewrite LEN. apply Z2Nat.id. lia. assert (PSRC: Mem.perm m bsrc (Ptrofs.unsigned osrc) Cur Nonempty). - apply RPSRC. omega. + apply RPSRC. lia. assert (PDST: Mem.perm m bdst (Ptrofs.unsigned odst) Cur Nonempty). - apply RPDST. omega. + apply RPDST. lia. exploit Mem.address_inject. eauto. eexact PSRC. eauto. intros EQ1. exploit Mem.address_inject. eauto. eexact PDST. eauto. intros EQ2. exploit Mem.loadbytes_inject; eauto. intros [bytes2 [A B]]. @@ -1078,15 +1078,25 @@ Proof. split. auto. intros. rewrite <- H0. eapply Mem.load_storebytes_other; eauto. left. congruence. +- (* bitfield *) + inv H3. + exploit Mem.loadv_inject; eauto. intros (vc' & LD' & INJ). inv INJ. + exploit Mem.storev_mapped_inject; eauto. intros [tm' [A B]]. + inv H1. + exists tm'; split. eapply assign_loc_bitfield; eauto. econstructor; eauto. + split. auto. + intros. rewrite <- H3. eapply Mem.load_store_other; eauto. + left. inv H0. congruence. Qed. Lemma assign_loc_nextblock: - forall ge ty m b ofs v m', - assign_loc ge ty m b ofs v m' -> Mem.nextblock m' = Mem.nextblock m. + forall ge ty m b ofs bf v m', + assign_loc ge ty m b ofs bf v m' -> Mem.nextblock m' = Mem.nextblock m. Proof. induction 1. simpl in H0. eapply Mem.nextblock_store; eauto. eapply Mem.nextblock_storebytes; eauto. + inv H. eapply Mem.nextblock_store; eauto. Qed. Theorem store_params_correct: @@ -1108,23 +1118,37 @@ Theorem store_params_correct: /\ match_envs j cenv e le m' lo hi te tle tlo thi /\ Mem.nextblock tm' = Mem.nextblock tm. Proof. +Local Opaque Conventions1.parameter_needs_normalization. induction 1; simpl; intros until targs; intros NOREPET CASTED VINJ MENV MINJ TLE LE. - (* base case *) +- (* base case *) inv VINJ. exists tle2; exists tm; split. apply star_refl. split. auto. split. auto. split. apply match_envs_temps_exten with tle1; auto. auto. - (* inductive case *) +- (* inductive case *) inv NOREPET. inv CASTED. inv VINJ. exploit me_vars; eauto. instantiate (1 := id); intros MV. - destruct (VSet.mem id cenv) eqn:?. - (* lifted to temp *) - eapply IHbind_parameters with (tle1 := PTree.set id v' tle1); eauto. - eapply match_envs_assign_lifted; eauto. - inv MV; try congruence. rewrite ENV in H; inv H. - inv H0; try congruence. - unfold Mem.storev in H2. eapply Mem.store_unmapped_inject; eauto. - intros. repeat rewrite PTree.gsspec. destruct (peq id0 id). auto. - apply TLE. intuition. - (* still in memory *) + destruct (VSet.mem id cenv) eqn:LIFTED. ++ (* lifted to temp *) + exploit (IHbind_parameters s tm (PTree.set id v' tle1) (PTree.set id v' tle2)). + eauto. eauto. eauto. + eapply match_envs_assign_lifted; eauto. + inv MV; try congruence. rewrite ENV in H; inv H. + inv H0; try congruence. + unfold Mem.storev in H2. eapply Mem.store_unmapped_inject; eauto. + intros. repeat rewrite PTree.gsspec. destruct (peq id0 id). auto. + apply TLE. intuition. + eauto. + intros (tle & tm' & U & V & X & Y & Z). + exists tle, tm'; split; [|auto]. + destruct (Conventions1.parameter_needs_normalization (rettype_of_type ty)); [|assumption]. + assert (A: tle!id = Some v'). + { erewrite bind_parameter_temps_inv by eauto. apply PTree.gss. } + eapply star_left. constructor. + eapply star_left. econstructor. eapply make_cast_correct. + constructor; eauto. apply cast_val_casted; auto. eapply val_casted_inject; eauto. + rewrite PTree.gsident by auto. + eapply star_left. constructor. eassumption. + traceEq. traceEq. traceEq. ++ (* still in memory *) inv MV; try congruence. rewrite ENV in H; inv H. exploit assign_loc_inject; eauto. intros [tm1 [A [B C]]]. @@ -1154,7 +1178,7 @@ Proof. reflexivity. reflexivity. eexact U. traceEq. - rewrite (assign_loc_nextblock _ _ _ _ _ _ _ A) in Z. auto. + rewrite (assign_loc_nextblock _ _ _ _ _ _ _ _ A) in Z. auto. Qed. Lemma bind_parameters_nextblock: @@ -1244,7 +1268,7 @@ Proof. destruct (Mem.range_perm_free m b lo hi) as [m1 A]; auto. rewrite A. apply IHl; auto. intros. red; intros. eapply Mem.perm_free_1; eauto. - exploit H1; eauto. intros [B|B]. auto. right; omega. + exploit H1; eauto. intros [B|B]. auto. right; lia. eapply H; eauto. Qed. @@ -1276,11 +1300,11 @@ Proof. change id' with (fst (id', (b', ty'))). apply List.in_map; auto. } assert (Mem.perm m b0 0 Max Nonempty). { apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable. - eapply PERMS; eauto. omega. auto with mem. } + eapply PERMS; eauto. lia. auto with mem. } assert (Mem.perm m b0' 0 Max Nonempty). { apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable. - eapply PERMS; eauto. omega. auto with mem. } - exploit Mem.mi_no_overlap; eauto. intros [A|A]. auto. omegaContradiction. + eapply PERMS; eauto. lia. auto with mem. } + exploit Mem.mi_no_overlap; eauto. intros [A|A]. auto. extlia. Qed. Lemma free_list_right_inject: @@ -1326,7 +1350,7 @@ Local Opaque ge tge. unfold block_of_binding in EQ; inv EQ. exploit me_mapped; eauto. eapply PTree.elements_complete; eauto. intros [b [A B]]. - change 0 with (0 + 0). replace (sizeof ge ty) with (sizeof ge ty + 0) by omega. + change 0 with (0 + 0). replace (sizeof ge ty) with (sizeof ge ty + 0) by lia. eapply Mem.range_perm_inject; eauto. eapply free_blocks_of_env_perm_2; eauto. - (* no overlap *) @@ -1343,7 +1367,7 @@ Local Opaque ge tge. intros [[id [b' ty]] [EQ IN]]. unfold block_of_binding in EQ. inv EQ. exploit me_flat; eauto. apply PTree.elements_complete; eauto. intros [P Q]. subst delta. eapply free_blocks_of_env_perm_1 with (m := m); eauto. - rewrite <- comp_env_preserved. omega. + rewrite <- comp_env_preserved. lia. Qed. (** Matching global environments *) @@ -1386,19 +1410,22 @@ Proof. Qed. Lemma deref_loc_inject: - forall ty loc ofs v loc' ofs', - deref_loc ty m loc ofs v -> + forall ty loc ofs bf v loc' ofs', + deref_loc ty m loc ofs bf v -> Val.inject f (Vptr loc ofs) (Vptr loc' ofs') -> - exists tv, deref_loc ty tm loc' ofs' tv /\ Val.inject f v tv. + exists tv, deref_loc ty tm loc' ofs' bf tv /\ Val.inject f v tv. Proof. intros. inv H. - (* by value *) +- (* by value *) exploit Mem.loadv_inject; eauto. intros [tv [A B]]. exists tv; split; auto. eapply deref_loc_value; eauto. - (* by reference *) +- (* by reference *) exists (Vptr loc' ofs'); split; auto. eapply deref_loc_reference; eauto. - (* by copy *) +- (* by copy *) exists (Vptr loc' ofs'); split; auto. eapply deref_loc_copy; eauto. +- (* bitfield *) + inv H1. exploit Mem.loadv_inject; eauto. intros [tc [A B]]. inv B. + econstructor; split. eapply deref_loc_bitfield. econstructor; eauto. constructor. Qed. Lemma eval_simpl_expr: @@ -1408,11 +1435,11 @@ Lemma eval_simpl_expr: exists tv, eval_expr tge te tle tm (simpl_expr cenv a) tv /\ Val.inject f v tv with eval_simpl_lvalue: - forall a b ofs, - eval_lvalue ge e le m a b ofs -> + forall a b ofs bf, + eval_lvalue ge e le m a b ofs bf -> compat_cenv (addr_taken_expr a) cenv -> match a with Evar id ty => VSet.mem id cenv = false | _ => True end -> - exists b', exists ofs', eval_lvalue tge te tle tm (simpl_expr cenv a) b' ofs' /\ Val.inject f (Vptr b ofs) (Vptr b' ofs'). + exists b', exists ofs', eval_lvalue tge te tle tm (simpl_expr cenv a) b' ofs' bf /\ Val.inject f (Vptr b ofs) (Vptr b' ofs'). Proof. destruct 1; simpl; intros. @@ -1458,7 +1485,7 @@ Proof. subst a. simpl. rewrite OPT. exploit me_vars; eauto. instantiate (1 := id). intros MV. inv H; inv MV; try congruence. - rewrite ENV in H6; inv H6. + rewrite ENV in H7; inv H7. inv H0; try congruence. assert (chunk0 = chunk). simpl in H. congruence. subst chunk0. assert (v0 = v). unfold Mem.loadv in H2. rewrite Ptrofs.unsigned_zero in H2. congruence. subst v0. @@ -1502,7 +1529,8 @@ Proof. exploit eval_simpl_expr; eauto. intros [tv [A B]]. inversion B. subst. econstructor; econstructor; split. - eapply eval_Efield_union; eauto. rewrite typeof_simpl_expr; eauto. auto. + eapply eval_Efield_union; eauto. rewrite typeof_simpl_expr; eauto. + econstructor; eauto. repeat rewrite Ptrofs.add_assoc. decEq. apply Ptrofs.add_commut. Qed. Lemma eval_simpl_exprlist: @@ -1577,34 +1605,36 @@ Proof. induction 1; intros LOAD INCR INJ1 INJ2; econstructor; eauto. (* globalenvs *) inv H. constructor; intros; eauto. - assert (f b1 = Some (b2, delta)). rewrite <- H; symmetry; eapply INJ2; eauto. xomega. + assert (f b1 = Some (b2, delta)). rewrite <- H; symmetry; eapply INJ2; eauto. extlia. eapply IMAGE; eauto. (* call *) eapply match_envs_invariant; eauto. - intros. apply LOAD; auto. xomega. - intros. apply INJ1; auto; xomega. - intros. eapply INJ2; eauto; xomega. + intros. apply LOAD; auto. extlia. + intros. apply INJ1; auto; extlia. + intros. eapply INJ2; eauto; extlia. eapply IHmatch_cont; eauto. - intros; apply LOAD; auto. inv H0; xomega. - intros; apply INJ1. inv H0; xomega. - intros; eapply INJ2; eauto. inv H0; xomega. + intros; apply LOAD; auto. inv H0; extlia. + intros; apply INJ1. inv H0; extlia. + intros; eapply INJ2; eauto. inv H0; extlia. Qed. (** Invariance by assignment to location "above" *) Lemma match_cont_assign_loc: - forall f cenv k tk m bound tbound ty loc ofs v m', + forall f cenv k tk m bound tbound ty loc ofs bf v m', match_cont f cenv k tk m bound tbound -> - assign_loc ge ty m loc ofs v m' -> + assign_loc ge ty m loc ofs bf v m' -> Ple bound loc -> match_cont f cenv k tk m' bound tbound. Proof. intros. eapply match_cont_invariant; eauto. intros. rewrite <- H4. inv H0. - (* scalar *) - simpl in H6. eapply Mem.load_store_other; eauto. left. unfold block; xomega. - (* block copy *) - eapply Mem.load_storebytes_other; eauto. left. unfold block; xomega. +- (* scalar *) + simpl in H6. eapply Mem.load_store_other; eauto. left. unfold block; extlia. +- (* block copy *) + eapply Mem.load_storebytes_other; eauto. left. unfold block; extlia. +- (* bitfield *) + inv H5. eapply Mem.load_store_other; eauto. left. unfold block; extlia. Qed. (** Invariance by external calls *) @@ -1622,9 +1652,9 @@ Proof. intros. eapply Mem.load_unchanged_on; eauto. red in H2. intros. destruct (f b) as [[b' delta] | ] eqn:?. auto. destruct (f' b) as [[b' delta] | ] eqn:?; auto. - exploit H2; eauto. unfold Mem.valid_block. intros [A B]. xomegaContradiction. + exploit H2; eauto. unfold Mem.valid_block. intros [A B]. extlia. red in H2. intros. destruct (f b) as [[b'' delta''] | ] eqn:?. auto. - exploit H2; eauto. unfold Mem.valid_block. intros [A B]. xomegaContradiction. + exploit H2; eauto. unfold Mem.valid_block. intros [A B]. extlia. Qed. (** Invariance by change of bounds *) @@ -1636,7 +1666,7 @@ Lemma match_cont_incr_bounds: Ple bound bound' -> Ple tbound tbound' -> match_cont f cenv k tk m bound' tbound'. Proof. - induction 1; intros; econstructor; eauto; xomega. + induction 1; intros; econstructor; eauto; extlia. Qed. (** [match_cont] and call continuations. *) @@ -1690,7 +1720,7 @@ Proof. inv H; auto. destruct a. destruct p. destruct (Mem.free m b z0 z) as [m1|] eqn:?; try discriminate. transitivity (Mem.load chunk m1 b' 0). eauto. - eapply Mem.load_free. eauto. left. assert (Plt b' b) by eauto. unfold block; xomega. + eapply Mem.load_free. eauto. left. assert (Plt b' b) by eauto. unfold block; extlia. Qed. Lemma match_cont_free_env: @@ -1708,9 +1738,9 @@ Proof. intros. rewrite <- H7. eapply free_list_load; eauto. unfold blocks_of_env; intros. exploit list_in_map_inv; eauto. intros [[id [b1 ty]] [P Q]]. simpl in P. inv P. - exploit me_range; eauto. eapply PTree.elements_complete; eauto. xomega. - rewrite (free_list_nextblock _ _ _ H3). inv H; xomega. - rewrite (free_list_nextblock _ _ _ H4). inv H; xomega. + exploit me_range; eauto. eapply PTree.elements_complete; eauto. extlia. + rewrite (free_list_nextblock _ _ _ H3). inv H; extlia. + rewrite (free_list_nextblock _ _ _ H4). inv H; extlia. Qed. (** Matching of global environments *) @@ -1979,7 +2009,7 @@ Lemma find_label_store_params: forall s k params, find_label lbl (store_params cenv params s) k = find_label lbl s k. Proof. induction params; simpl. auto. - destruct a as [id ty]. destruct (VSet.mem id cenv); auto. + destruct a as [id ty]. destruct (VSet.mem id cenv); [destruct Conventions1.parameter_needs_normalization|]; auto. Qed. Lemma find_label_add_debug_vars: @@ -2018,7 +2048,7 @@ Proof. eapply step_Sset_debug. eauto. rewrite typeof_simpl_expr. eauto. econstructor; eauto with compat. eapply match_envs_assign_lifted; eauto. eapply cast_val_is_casted; eauto. - eapply match_cont_assign_loc; eauto. exploit me_range; eauto. xomega. + eapply match_cont_assign_loc; eauto. exploit me_range; eauto. extlia. inv MV; try congruence. inv H2; try congruence. unfold Mem.storev in H3. eapply Mem.store_unmapped_inject; eauto. congruence. erewrite assign_loc_nextblock; eauto. @@ -2068,7 +2098,7 @@ Proof. eapply match_envs_set_opttemp; eauto. eapply match_envs_extcall; eauto. eapply match_cont_extcall; eauto. - inv MENV; xomega. inv MENV; xomega. + inv MENV; extlia. inv MENV; extlia. eapply Ple_trans; eauto. eapply external_call_nextblock; eauto. eapply Ple_trans; eauto. eapply external_call_nextblock; eauto. @@ -2212,11 +2242,11 @@ Proof. eapply bind_parameters_load; eauto. intros. exploit alloc_variables_range. eexact H1. eauto. unfold empty_env. rewrite PTree.gempty. intros [?|?]. congruence. - red; intros; subst b'. xomega. + red; intros; subst b'. extlia. eapply alloc_variables_load; eauto. apply compat_cenv_for. - rewrite (bind_parameters_nextblock _ _ _ _ _ _ H2). xomega. - rewrite T; xomega. + rewrite (bind_parameters_nextblock _ _ _ _ _ _ H2). extlia. + rewrite T; extlia. (* external function *) monadInv TRFD. inv FUNTY. @@ -2227,7 +2257,7 @@ Proof. apply plus_one. econstructor; eauto. eapply external_call_symbols_preserved; eauto. apply senv_preserved. econstructor; eauto. intros. apply match_cont_incr_bounds with (Mem.nextblock m) (Mem.nextblock tm). - eapply match_cont_extcall; eauto. xomega. xomega. + eapply match_cont_extcall; eauto. extlia. extlia. eapply external_call_nextblock; eauto. eapply external_call_nextblock; eauto. @@ -2262,7 +2292,7 @@ Proof. eapply Genv.find_symbol_not_fresh; eauto. eapply Genv.find_funct_ptr_not_fresh; eauto. eapply Genv.find_var_info_not_fresh; eauto. - xomega. xomega. + extlia. extlia. eapply Genv.initmem_inject; eauto. constructor. Qed. diff --git a/common/AST.v b/common/AST.v index ddd10ede..2259d74c 100644 --- a/common/AST.v +++ b/common/AST.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -61,7 +62,7 @@ Definition typesize (ty: typ) : Z := end. Lemma typesize_pos: forall ty, typesize ty > 0. -Proof. destruct ty; simpl; omega. Qed. +Proof. destruct ty; simpl; lia. Qed. Lemma typesize_Tptr: typesize Tptr = if Archi.ptr64 then 8 else 4. Proof. unfold Tptr; destruct Archi.ptr64; auto. Qed. @@ -122,17 +123,17 @@ These signatures are used in particular to determine appropriate calling conventions for the function. *) Record calling_convention : Type := mkcallconv { - cc_vararg: bool; (**r variable-arity function *) - cc_unproto: bool; (**r old-style unprototyped function *) - cc_structret: bool (**r function returning a struct *) + cc_vararg: option Z; (**r variable-arity function (+ number of fixed args) *) + cc_unproto: bool; (**r old-style unprototyped function *) + cc_structret: bool (**r function returning a struct *) }. Definition cc_default := - {| cc_vararg := false; cc_unproto := false; cc_structret := false |}. + {| cc_vararg := None; cc_unproto := false; cc_structret := false |}. Definition calling_convention_eq (x y: calling_convention) : {x=y} + {x<>y}. Proof. - decide equality; apply bool_dec. + decide equality; try (apply bool_dec). decide equality; apply Z.eq_dec. Defined. Global Opaque calling_convention_eq. @@ -265,13 +266,13 @@ Fixpoint init_data_list_size (il: list init_data) {struct il} : Z := Lemma init_data_size_pos: forall i, init_data_size i >= 0. Proof. - destruct i; simpl; try xomega. destruct Archi.ptr64; omega. + destruct i; simpl; try extlia. destruct Archi.ptr64; lia. Qed. Lemma init_data_list_size_pos: forall il, init_data_list_size il >= 0. Proof. - induction il; simpl. omega. generalize (init_data_size_pos a); omega. + induction il; simpl. lia. generalize (init_data_size_pos a); lia. Qed. (** Information attached to global variables. *) diff --git a/common/Behaviors.v b/common/Behaviors.v index 92bd708f..1f7f6226 100644 --- a/common/Behaviors.v +++ b/common/Behaviors.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -24,6 +25,7 @@ Require Import Integers. Require Import Smallstep. Set Implicit Arguments. +Set Asymmetric Patterns. (** * Behaviors for program executions *) diff --git a/common/Builtins.v b/common/Builtins.v index 476b541e..facff726 100644 --- a/common/Builtins.v +++ b/common/Builtins.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/common/Builtins0.v b/common/Builtins0.v index d84c9112..384dde1e 100644 --- a/common/Builtins0.v +++ b/common/Builtins0.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -341,6 +342,7 @@ Inductive standard_builtin : Type := | BI_i16_bswap | BI_i32_bswap | BI_i64_bswap + | BI_unreachable | BI_i64_umulh | BI_i64_smulh | BI_i64_sdiv @@ -376,6 +378,7 @@ Definition standard_builtin_table : list (string * standard_builtin) := :: ("__builtin_bswap", BI_i32_bswap) :: ("__builtin_bswap32", BI_i32_bswap) :: ("__builtin_bswap64", BI_i64_bswap) + :: ("__builtin_unreachable", BI_unreachable) :: ("__compcert_i64_umulh", BI_i64_umulh) :: ("__compcert_i64_smulh", BI_i64_smulh) :: ("__compcert_i64_sdiv", BI_i64_sdiv) @@ -414,6 +417,8 @@ Definition standard_builtin_sig (b: standard_builtin) : signature := mksignature (Tlong :: nil) Tlong cc_default | BI_i16_bswap => mksignature (Tint :: nil) Tint cc_default + | BI_unreachable => + mksignature nil Tvoid cc_default | BI_i64_shl | BI_i64_shr | BI_i64_sar => mksignature (Tlong :: Tint :: nil) Tlong cc_default | BI_i64_dtos | BI_i64_dtou => @@ -448,6 +453,7 @@ Program Definition standard_builtin_sem (b: standard_builtin) : builtin_sem (sig | BI_i64_bswap => mkbuiltin_n1t Tlong Tlong (fun n => Int64.repr (decode_int (List.rev (encode_int 8%nat (Int64.unsigned n))))) + | BI_unreachable => mkbuiltin Tvoid (fun vargs => None) _ _ | BI_i64_umulh => mkbuiltin_n2t Tlong Tlong Tlong Int64.mulhu | BI_i64_smulh => mkbuiltin_n2t Tlong Tlong Tlong Int64.mulhs | BI_i64_sdiv => mkbuiltin_v2p Tlong Val.divls _ _ diff --git a/common/Determinism.v b/common/Determinism.v index 7fa01c2d..c8c90782 100644 --- a/common/Determinism.v +++ b/common/Determinism.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/common/Errors.v b/common/Errors.v index 6807735a..bf72f12b 100644 --- a/common/Errors.v +++ b/common/Errors.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/common/Events.v b/common/Events.v index 28bb992a..c4a6e7f9 100644 --- a/common/Events.v +++ b/common/Events.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -798,7 +799,7 @@ Proof. exists f; exists v'; exists m1'; intuition. constructor; auto. red; intros. congruence. (* trace length *) -- inv H; inv H0; simpl; omega. +- inv H; inv H0; simpl; lia. (* receptive *) - inv H. exploit volatile_load_receptive; eauto. intros [v2 A]. exists v2; exists m1; constructor; auto. @@ -925,7 +926,7 @@ Proof. eelim H3; eauto. exploit Mem.store_valid_access_3. eexact H0. intros [X Y]. apply Mem.perm_cur_max. apply Mem.perm_implies with Writable; auto with mem. - apply X. omega. + apply X. lia. Qed. Lemma volatile_store_receptive: @@ -960,7 +961,7 @@ Proof. exploit volatile_store_inject; eauto. intros [m2' [A [B [C D]]]]. exists f; exists Vundef; exists m2'; intuition. constructor; auto. red; intros; congruence. (* trace length *) -- inv H; inv H0; simpl; omega. +- inv H; inv H0; simpl; lia. (* receptive *) - assert (t1 = t2). inv H. eapply volatile_store_receptive; eauto. subst t2; exists vres1; exists m1; auto. @@ -1042,7 +1043,7 @@ Proof. subst b1. rewrite C in H2. inv H2. eauto with mem. rewrite D in H2 by auto. congruence. (* trace length *) -- inv H; simpl; omega. +- inv H; simpl; lia. (* receptive *) - assert (t1 = t2). inv H; inv H0; auto. subst t2. exists vres1; exists m1; auto. @@ -1122,21 +1123,21 @@ Proof. exploit Mem.address_inject; eauto. apply Mem.perm_implies with Freeable; auto with mem. apply P. instantiate (1 := lo). - generalize (size_chunk_pos Mptr); omega. + generalize (size_chunk_pos Mptr); lia. intro EQ. exploit Mem.free_parallel_inject; eauto. intros (m2' & C & D). exists f, Vundef, m2'; split. apply extcall_free_sem_ptr with (sz := sz) (m' := m2'). - rewrite EQ. rewrite <- A. f_equal. omega. + rewrite EQ. rewrite <- A. f_equal. lia. auto. auto. - rewrite ! EQ. rewrite <- C. f_equal; omega. + rewrite ! EQ. rewrite <- C. f_equal; lia. split. auto. split. auto. split. eapply Mem.free_unchanged_on; eauto. unfold loc_unmapped. intros; congruence. split. eapply Mem.free_unchanged_on; eauto. unfold loc_out_of_reach. intros. red; intros. eelim H2; eauto. apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable; auto with mem. - apply P. omega. + apply P. lia. split. auto. red; intros. congruence. + inv H2. inv H6. replace v' with Vnullptr. @@ -1145,7 +1146,7 @@ Proof. red; intros; congruence. unfold Vnullptr in *; destruct Archi.ptr64; inv H4; auto. (* trace length *) -- inv H; simpl; omega. +- inv H; simpl; lia. (* receptive *) - assert (t1 = t2) by (inv H; inv H0; auto). subst t2. exists vres1; exists m1; auto. @@ -1217,23 +1218,23 @@ Proof. destruct (zeq sz 0). + (* special case sz = 0 *) assert (bytes = nil). - { exploit (Mem.loadbytes_empty m1 bsrc (Ptrofs.unsigned osrc) sz). omega. congruence. } + { exploit (Mem.loadbytes_empty m1 bsrc (Ptrofs.unsigned osrc) sz). lia. congruence. } subst. destruct (Mem.range_perm_storebytes m1' b0 (Ptrofs.unsigned (Ptrofs.add odst (Ptrofs.repr delta0))) nil) as [m2' SB]. - simpl. red; intros; omegaContradiction. + simpl. red; intros; extlia. exists f, Vundef, m2'. split. econstructor; eauto. - intros; omegaContradiction. - intros; omegaContradiction. - right; omega. - apply Mem.loadbytes_empty. omega. + intros; extlia. + intros; extlia. + right; lia. + apply Mem.loadbytes_empty. lia. split. auto. split. eapply Mem.storebytes_empty_inject; eauto. split. eapply Mem.storebytes_unchanged_on; eauto. unfold loc_unmapped; intros. congruence. split. eapply Mem.storebytes_unchanged_on; eauto. - simpl; intros; omegaContradiction. + simpl; intros; extlia. split. apply inject_incr_refl. red; intros; congruence. + (* general case sz > 0 *) @@ -1243,11 +1244,11 @@ Proof. assert (RPDST: Mem.range_perm m1 bdst (Ptrofs.unsigned odst) (Ptrofs.unsigned odst + sz) Cur Nonempty). replace sz with (Z.of_nat (length bytes)). eapply Mem.range_perm_implies. eapply Mem.storebytes_range_perm; eauto. auto with mem. - rewrite LEN. apply Z2Nat.id. omega. + rewrite LEN. apply Z2Nat.id. lia. assert (PSRC: Mem.perm m1 bsrc (Ptrofs.unsigned osrc) Cur Nonempty). - apply RPSRC. omega. + apply RPSRC. lia. assert (PDST: Mem.perm m1 bdst (Ptrofs.unsigned odst) Cur Nonempty). - apply RPDST. omega. + apply RPDST. lia. exploit Mem.address_inject. eauto. eexact PSRC. eauto. intros EQ1. exploit Mem.address_inject. eauto. eexact PDST. eauto. intros EQ2. exploit Mem.loadbytes_inject; eauto. intros [bytes2 [A B]]. @@ -1258,7 +1259,7 @@ Proof. intros; eapply Mem.aligned_area_inject with (m := m1); eauto. eapply Mem.disjoint_or_equal_inject with (m := m1); eauto. apply Mem.range_perm_max with Cur; auto. - apply Mem.range_perm_max with Cur; auto. omega. + apply Mem.range_perm_max with Cur; auto. lia. split. constructor. split. auto. split. eapply Mem.storebytes_unchanged_on; eauto. unfold loc_unmapped; intros. @@ -1268,11 +1269,11 @@ Proof. apply Mem.perm_cur_max. apply Mem.perm_implies with Writable; auto with mem. eapply Mem.storebytes_range_perm; eauto. erewrite list_forall2_length; eauto. - omega. + lia. split. apply inject_incr_refl. red; intros; congruence. - (* trace length *) - intros; inv H. simpl; omega. + intros; inv H. simpl; lia. - (* receptive *) intros. assert (t1 = t2). inv H; inv H0; auto. subst t2. @@ -1318,7 +1319,7 @@ Proof. eapply eventval_list_match_inject; eauto. red; intros; congruence. (* trace length *) -- inv H; simpl; omega. +- inv H; simpl; lia. (* receptive *) - assert (t1 = t2). inv H; inv H0; auto. exists vres1; exists m1; congruence. @@ -1363,7 +1364,7 @@ Proof. eapply eventval_match_inject; eauto. red; intros; congruence. (* trace length *) -- inv H; simpl; omega. +- inv H; simpl; lia. (* receptive *) - assert (t1 = t2). inv H; inv H0; auto. subst t2. exists vres1; exists m1; auto. @@ -1404,7 +1405,7 @@ Proof. econstructor; eauto. red; intros; congruence. (* trace length *) -- inv H; simpl; omega. +- inv H; simpl; lia. (* receptive *) - inv H; inv H0. exists Vundef, m1; constructor. (* determ *) @@ -1458,7 +1459,7 @@ Proof. constructor; auto. red; intros; congruence. (* trace length *) -- inv H; simpl; omega. +- inv H; simpl; lia. (* receptive *) - inv H; inv H0. exists vres1, m1; constructor; auto. (* determ *) @@ -1582,7 +1583,7 @@ Proof. intros. destruct (plt (Mem.nextblock m2) (Mem.nextblock m1)). exploit external_call_valid_block; eauto. intros. eelim Plt_strict; eauto. - unfold Plt, Ple in *; zify; omega. + unfold Plt, Ple in *; zify; lia. Qed. (** Special case of [external_call_mem_inject_gen] (for backward compatibility) *) @@ -1697,7 +1698,7 @@ Qed. End EVAL_BUILTIN_ARG. -Hint Constructors eval_builtin_arg: barg. +Global Hint Constructors eval_builtin_arg: barg. (** Invariance by change of global environment. *) diff --git a/common/Globalenvs.v b/common/Globalenvs.v index d37fbd46..4c9e7889 100644 --- a/common/Globalenvs.v +++ b/common/Globalenvs.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -55,7 +56,7 @@ Function store_zeros (m: mem) (b: block) (p: Z) (n: Z) {wf (Zwf 0) n}: option me | None => None end. Proof. - intros. red. omega. + intros. red. lia. apply Zwf_well_founded. Qed. @@ -849,8 +850,8 @@ Proof. intros until n. functional induction (store_zeros m b p n); intros. - inv H; apply Mem.unchanged_on_refl. - apply Mem.unchanged_on_trans with m'. -+ eapply Mem.store_unchanged_on; eauto. simpl. intros. apply H0. omega. -+ apply IHo; auto. intros; apply H0; omega. ++ eapply Mem.store_unchanged_on; eauto. simpl. intros. apply H0. lia. ++ apply IHo; auto. intros; apply H0; lia. - discriminate. Qed. @@ -879,7 +880,7 @@ Proof. - destruct (store_init_data m b p a) as [m1|] eqn:?; try congruence. apply Mem.unchanged_on_trans with m1. eapply store_init_data_unchanged; eauto. intros; apply H0; tauto. - eapply IHil; eauto. intros; apply H0. generalize (init_data_size_pos a); omega. + eapply IHil; eauto. intros; apply H0. generalize (init_data_size_pos a); lia. Qed. (** Properties related to [loadbytes] *) @@ -887,7 +888,7 @@ Qed. Definition readbytes_as_zero (m: mem) (b: block) (ofs len: Z) : Prop := forall p n, ofs <= p -> p + Z.of_nat n <= ofs + len -> - Mem.loadbytes m b p (Z.of_nat n) = Some (list_repeat n (Byte Byte.zero)). + Mem.loadbytes m b p (Z.of_nat n) = Some (List.repeat (Byte Byte.zero) n). Lemma store_zeros_loadbytes: forall m b p n m', @@ -895,24 +896,24 @@ Lemma store_zeros_loadbytes: readbytes_as_zero m' b p n. Proof. intros until n; functional induction (store_zeros m b p n); red; intros. -- destruct n0. simpl. apply Mem.loadbytes_empty. omega. - rewrite Nat2Z.inj_succ in H1. omegaContradiction. +- destruct n0. simpl. apply Mem.loadbytes_empty. lia. + rewrite Nat2Z.inj_succ in H1. extlia. - destruct (zeq p0 p). - + subst p0. destruct n0. simpl. apply Mem.loadbytes_empty. omega. + + subst p0. destruct n0. simpl. apply Mem.loadbytes_empty. lia. rewrite Nat2Z.inj_succ in H1. rewrite Nat2Z.inj_succ. - replace (Z.succ (Z.of_nat n0)) with (1 + Z.of_nat n0) by omega. - change (list_repeat (S n0) (Byte Byte.zero)) - with ((Byte Byte.zero :: nil) ++ list_repeat n0 (Byte Byte.zero)). + replace (Z.succ (Z.of_nat n0)) with (1 + Z.of_nat n0) by lia. + change (List.repeat (Byte Byte.zero) (S n0)) + with ((Byte Byte.zero :: nil) ++ List.repeat (Byte Byte.zero) n0). apply Mem.loadbytes_concat. eapply Mem.loadbytes_unchanged_on with (P := fun b1 ofs1 => ofs1 = p). - eapply store_zeros_unchanged; eauto. intros; omega. - intros; omega. + eapply store_zeros_unchanged; eauto. intros; lia. + intros; lia. replace (Byte Byte.zero :: nil) with (encode_val Mint8unsigned Vzero). change 1 with (size_chunk Mint8unsigned). eapply Mem.loadbytes_store_same; eauto. unfold encode_val; unfold encode_int; unfold rev_if_be; destruct Archi.big_endian; reflexivity. - eapply IHo; eauto. omega. omega. omega. omega. - + eapply IHo; eauto. omega. omega. + eapply IHo; eauto. lia. lia. lia. lia. + + eapply IHo; eauto. lia. lia. - discriminate. Qed. @@ -924,11 +925,11 @@ Definition bytes_of_init_data (i: init_data): list memval := | Init_int64 n => inj_bytes (encode_int 8%nat (Int64.unsigned n)) | Init_float32 n => inj_bytes (encode_int 4%nat (Int.unsigned (Float32.to_bits n))) | Init_float64 n => inj_bytes (encode_int 8%nat (Int64.unsigned (Float.to_bits n))) - | Init_space n => list_repeat (Z.to_nat n) (Byte Byte.zero) + | Init_space n => List.repeat (Byte Byte.zero) (Z.to_nat n) | Init_addrof id ofs => match find_symbol ge id with | Some b => inj_value (if Archi.ptr64 then Q64 else Q32) (Vptr b ofs) - | None => list_repeat (if Archi.ptr64 then 8%nat else 4%nat) Undef + | None => List.repeat Undef (if Archi.ptr64 then 8%nat else 4%nat) end end. @@ -947,8 +948,8 @@ Proof. intros; destruct i; simpl in H; try apply (Mem.loadbytes_store_same _ _ _ _ _ _ H). - inv H. simpl. assert (EQ: Z.of_nat (Z.to_nat z) = Z.max z 0). - { destruct (zle 0 z). rewrite Z2Nat.id; xomega. destruct z; try discriminate. simpl. xomega. } - rewrite <- EQ. apply H0. omega. simpl. omega. + { destruct (zle 0 z). rewrite Z2Nat.id; extlia. destruct z; try discriminate. simpl. extlia. } + rewrite <- EQ. apply H0. lia. simpl. lia. - rewrite init_data_size_addrof. simpl. destruct (find_symbol ge i) as [b'|]; try discriminate. rewrite (Mem.loadbytes_store_same _ _ _ _ _ _ H). @@ -968,23 +969,23 @@ Lemma store_init_data_list_loadbytes: Mem.loadbytes m' b p (init_data_list_size il) = Some (bytes_of_init_data_list il). Proof. induction il as [ | i1 il]; simpl; intros. -- apply Mem.loadbytes_empty. omega. +- apply Mem.loadbytes_empty. lia. - generalize (init_data_size_pos i1) (init_data_list_size_pos il); intros P1 PL. destruct (store_init_data m b p i1) as [m1|] eqn:S; try discriminate. apply Mem.loadbytes_concat. eapply Mem.loadbytes_unchanged_on with (P := fun b1 ofs1 => ofs1 < p + init_data_size i1). eapply store_init_data_list_unchanged; eauto. - intros; omega. - intros; omega. + intros; lia. + intros; lia. eapply store_init_data_loadbytes; eauto. - red; intros; apply H0. omega. omega. + red; intros; apply H0. lia. lia. apply IHil with m1; auto. red; intros. eapply Mem.loadbytes_unchanged_on with (P := fun b1 ofs1 => p + init_data_size i1 <= ofs1). eapply store_init_data_unchanged; eauto. - intros; omega. - intros; omega. - apply H0. omega. omega. + intros; lia. + intros; lia. + apply H0. lia. lia. auto. auto. Qed. @@ -1011,7 +1012,7 @@ Remark read_as_zero_unchanged: read_as_zero m' b ofs len. Proof. intros; red; intros. eapply Mem.load_unchanged_on; eauto. - intros; apply H1. omega. + intros; apply H1. lia. Qed. Lemma store_zeros_read_as_zero: @@ -1020,7 +1021,7 @@ Lemma store_zeros_read_as_zero: read_as_zero m' b p n. Proof. intros; red; intros. - transitivity (Some(decode_val chunk (list_repeat (size_chunk_nat chunk) (Byte Byte.zero)))). + transitivity (Some(decode_val chunk (List.repeat (Byte Byte.zero) (size_chunk_nat chunk)))). apply Mem.loadbytes_load; auto. rewrite size_chunk_conv. eapply store_zeros_loadbytes; eauto. rewrite <- size_chunk_conv; auto. f_equal. destruct chunk; unfold decode_val; unfold decode_int; unfold rev_if_be; destruct Archi.big_endian; reflexivity. @@ -1068,7 +1069,7 @@ Proof. { intros. eapply Mem.load_unchanged_on with (P := fun b' ofs' => ofs' < p + size_chunk chunk). - eapply store_init_data_list_unchanged; eauto. intros; omega. + eapply store_init_data_list_unchanged; eauto. intros; lia. intros; tauto. eapply Mem.load_store_same; eauto. } @@ -1078,10 +1079,10 @@ Proof. exploit IHil; eauto. set (P := fun (b': block) ofs' => p + init_data_size a <= ofs'). apply read_as_zero_unchanged with (m := m) (P := P). - red; intros; apply H0; auto. generalize (init_data_size_pos a); omega. omega. + red; intros; apply H0; auto. generalize (init_data_size_pos a); lia. lia. eapply store_init_data_unchanged with (P := P); eauto. - intros; unfold P. omega. - intros; unfold P. omega. + intros; unfold P. lia. + intros; unfold P. lia. intro D. destruct a; simpl in Heqo. + split; auto. eapply (A Mint8unsigned (Vint i)); eauto. @@ -1093,10 +1094,10 @@ Proof. + split; auto. set (P := fun (b': block) ofs' => ofs' < p + init_data_size (Init_space z)). inv Heqo. apply read_as_zero_unchanged with (m := m1) (P := P). - red; intros. apply H0; auto. simpl. generalize (init_data_list_size_pos il); xomega. + red; intros. apply H0; auto. simpl. generalize (init_data_list_size_pos il); extlia. eapply store_init_data_list_unchanged; eauto. - intros; unfold P. omega. - intros; unfold P. simpl; xomega. + intros; unfold P. lia. + intros; unfold P. simpl; extlia. + rewrite init_data_size_addrof in *. split; auto. destruct (find_symbol ge i); try congruence. @@ -1195,11 +1196,11 @@ Proof. * destruct (Mem.alloc m 0 1) as [m1 b] eqn:ALLOC. exploit Mem.alloc_result; eauto. intros RES. rewrite H, <- RES. split. - eapply Mem.perm_drop_1; eauto. omega. + eapply Mem.perm_drop_1; eauto. lia. intros. assert (0 <= ofs < 1). { eapply Mem.perm_alloc_3; eauto. eapply Mem.perm_drop_4; eauto. } exploit Mem.perm_drop_2; eauto. intros ORD. - split. omega. inv ORD; auto. + split. lia. inv ORD; auto. * set (init := gvar_init v) in *. set (sz := init_data_list_size init) in *. destruct (Mem.alloc m 0 sz) as [m1 b] eqn:?. @@ -1442,7 +1443,7 @@ Proof. exploit alloc_global_neutral; eauto. assert (Ple (Pos.succ (Mem.nextblock m)) (Mem.nextblock m')). { rewrite EQ. apply advance_next_le. } - unfold Plt, Ple in *; zify; omega. + unfold Plt, Ple in *; zify; lia. Qed. End INITMEM_INJ. @@ -1563,9 +1564,9 @@ Lemma store_zeros_exists: Proof. intros until n. functional induction (store_zeros m b p n); intros PERM. - exists m; auto. -- apply IHo. red; intros. eapply Mem.perm_store_1; eauto. apply PERM. omega. +- apply IHo. red; intros. eapply Mem.perm_store_1; eauto. apply PERM. lia. - destruct (Mem.valid_access_store m Mint8unsigned b p Vzero) as (m' & STORE). - split. red; intros. apply Mem.perm_cur. apply PERM. simpl in H. omega. + split. red; intros. apply Mem.perm_cur. apply PERM. simpl in H. lia. simpl. apply Z.divide_1_l. congruence. Qed. @@ -1603,10 +1604,10 @@ Proof. - exists m; auto. - destruct H0. destruct (@store_init_data_exists m b p i1) as (m1 & S1); eauto. - red; intros. apply H. generalize (init_data_list_size_pos il); omega. + red; intros. apply H. generalize (init_data_list_size_pos il); lia. rewrite S1. apply IHil; eauto. - red; intros. erewrite <- store_init_data_perm by eauto. apply H. generalize (init_data_size_pos i1); omega. + red; intros. erewrite <- store_init_data_perm by eauto. apply H. generalize (init_data_size_pos i1); lia. Qed. Lemma alloc_global_exists: diff --git a/common/Linking.v b/common/Linking.v index ec828ea4..d23b1028 100644 --- a/common/Linking.v +++ b/common/Linking.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -123,7 +124,7 @@ Defined. Next Obligation. inv H; inv H0; constructor; auto. congruence. - simpl. generalize (init_data_list_size_pos z). xomega. + simpl. generalize (init_data_list_size_pos z). extlia. Defined. Next Obligation. revert H; unfold link_varinit. @@ -868,7 +869,7 @@ Infix ":::" := pass_cons (at level 60, right associativity) : linking_scope. Fixpoint compose_passes (l l': Language) (passes: Passes l l') : Pass l l' := match passes in Passes l l' return Pass l l' with | pass_nil l => pass_identity l - | pass_cons l1 l2 l3 pass1 passes => pass_compose pass1 (compose_passes passes) + | pass_cons pass1 passes => pass_compose pass1 (compose_passes passes) end. (** Some more lemmas about [nlist_forall2]. *) diff --git a/common/Memdata.v b/common/Memdata.v index f3016efe..1bd87169 100644 --- a/common/Memdata.v +++ b/common/Memdata.v @@ -7,10 +7,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -47,7 +48,7 @@ Definition size_chunk (chunk: memory_chunk) : Z := Lemma size_chunk_pos: forall chunk, size_chunk chunk > 0. Proof. - intros. destruct chunk; simpl; omega. + intros. destruct chunk; simpl; lia. Qed. Definition size_chunk_nat (chunk: memory_chunk) : nat := @@ -65,7 +66,7 @@ Proof. intros. generalize (size_chunk_pos chunk). rewrite size_chunk_conv. destruct (size_chunk_nat chunk). - simpl; intros; omegaContradiction. + simpl; intros; extlia. intros; exists n; auto. Qed. @@ -101,7 +102,7 @@ Definition align_chunk (chunk: memory_chunk) : Z := Lemma align_chunk_pos: forall chunk, align_chunk chunk > 0. Proof. - intro. destruct chunk; simpl; omega. + intro. destruct chunk; simpl; lia. Qed. Lemma align_chunk_Mptr: align_chunk Mptr = if Archi.ptr64 then 8 else 4. @@ -120,7 +121,7 @@ Lemma align_le_divides: align_chunk chunk1 <= align_chunk chunk2 -> (align_chunk chunk1 | align_chunk chunk2). Proof. intros. destruct chunk1; destruct chunk2; simpl in *; - solve [ omegaContradiction + solve [ extlia | apply Z.divide_refl | exists 2; reflexivity | exists 4; reflexivity @@ -216,12 +217,12 @@ Proof. simpl. rewrite Zmod_1_r. auto. Opaque Byte.wordsize. rewrite Nat2Z.inj_succ. simpl. - replace (Z.succ (Z.of_nat n) * 8) with (Z.of_nat n * 8 + 8) by omega. - rewrite two_p_is_exp; try omega. + replace (Z.succ (Z.of_nat n) * 8) with (Z.of_nat n * 8 + 8) by lia. + rewrite two_p_is_exp; try lia. rewrite Zmod_recombine. rewrite IHn. rewrite Z.add_comm. change (Byte.unsigned (Byte.repr x)) with (Byte.Z_mod_modulus x). rewrite Byte.Z_mod_modulus_eq. reflexivity. - apply two_p_gt_ZERO. omega. apply two_p_gt_ZERO. omega. + apply two_p_gt_ZERO. lia. apply two_p_gt_ZERO. lia. Qed. Lemma rev_if_be_involutive: @@ -280,15 +281,15 @@ Proof. intros; simpl; auto. intros until y. rewrite Nat2Z.inj_succ. - replace (Z.succ (Z.of_nat n) * 8) with (Z.of_nat n * 8 + 8) by omega. - rewrite two_p_is_exp; try omega. + replace (Z.succ (Z.of_nat n) * 8) with (Z.of_nat n * 8 + 8) by lia. + rewrite two_p_is_exp; try lia. intro EQM. simpl; decEq. apply Byte.eqm_samerepr. red. eapply eqmod_divides; eauto. apply Z.divide_factor_r. apply IHn. destruct EQM as [k EQ]. exists k. rewrite EQ. - rewrite <- Z_div_plus_full_l. decEq. change (two_p 8) with 256. ring. omega. + rewrite <- Z_div_plus_full_l. decEq. change (two_p 8) with 256. ring. lia. Qed. Lemma encode_int_8_mod: @@ -371,14 +372,14 @@ Definition encode_val (chunk: memory_chunk) (v: val) : list memval := | Vint n, (Mint8signed | Mint8unsigned) => inj_bytes (encode_int 1%nat (Int.unsigned n)) | Vint n, (Mint16signed | Mint16unsigned) => inj_bytes (encode_int 2%nat (Int.unsigned n)) | Vint n, Mint32 => inj_bytes (encode_int 4%nat (Int.unsigned n)) - | Vptr b ofs, Mint32 => if Archi.ptr64 then list_repeat 4%nat Undef else inj_value Q32 v + | Vptr b ofs, Mint32 => if Archi.ptr64 then List.repeat Undef 4%nat else inj_value Q32 v | Vlong n, Mint64 => inj_bytes (encode_int 8%nat (Int64.unsigned n)) - | Vptr b ofs, Mint64 => if Archi.ptr64 then inj_value Q64 v else list_repeat 8%nat Undef + | Vptr b ofs, Mint64 => if Archi.ptr64 then inj_value Q64 v else List.repeat Undef 8%nat | Vsingle n, Mfloat32 => inj_bytes (encode_int 4%nat (Int.unsigned (Float32.to_bits n))) | Vfloat n, Mfloat64 => inj_bytes (encode_int 8%nat (Int64.unsigned (Float.to_bits n))) | _, Many32 => inj_value Q32 v | _, Many64 => inj_value Q64 v - | _, _ => list_repeat (size_chunk_nat chunk) Undef + | _, _ => List.repeat Undef (size_chunk_nat chunk) end. Definition decode_val (chunk: memory_chunk) (vl: list memval) : val := @@ -517,9 +518,9 @@ Ltac solve_decode_encode_val_general := | |- context [ Int.repr(decode_int (encode_int 2 (Int.unsigned _))) ] => rewrite decode_encode_int_2 | |- context [ Int.repr(decode_int (encode_int 4 (Int.unsigned _))) ] => rewrite decode_encode_int_4 | |- context [ Int64.repr(decode_int (encode_int 8 (Int64.unsigned _))) ] => rewrite decode_encode_int_8 - | |- Vint (Int.sign_ext _ (Int.sign_ext _ _)) = Vint _ => f_equal; apply Int.sign_ext_idem; omega - | |- Vint (Int.zero_ext _ (Int.zero_ext _ _)) = Vint _ => f_equal; apply Int.zero_ext_idem; omega - | |- Vint (Int.sign_ext _ (Int.zero_ext _ _)) = Vint _ => f_equal; apply Int.sign_ext_zero_ext; omega + | |- Vint (Int.sign_ext _ (Int.sign_ext _ _)) = Vint _ => f_equal; apply Int.sign_ext_idem; lia + | |- Vint (Int.zero_ext _ (Int.zero_ext _ _)) = Vint _ => f_equal; apply Int.zero_ext_idem; lia + | |- Vint (Int.sign_ext _ (Int.zero_ext _ _)) = Vint _ => f_equal; apply Int.sign_ext_zero_ext; lia end. Lemma decode_encode_val_general: @@ -543,7 +544,7 @@ Lemma decode_encode_val_similar: v2 = Val.load_result chunk2 v1. Proof. intros until v2; intros TY SZ DE. - destruct chunk1; destruct chunk2; simpl in TY; try discriminate; simpl in SZ; try omegaContradiction; + destruct chunk1; destruct chunk2; simpl in TY; try discriminate; simpl in SZ; try extlia; destruct v1; auto. Qed. @@ -553,7 +554,7 @@ Lemma decode_val_rettype: Proof. intros. unfold decode_val. destruct (proj_bytes cl). -- destruct chunk; simpl; rewrite ? Int.sign_ext_idem, ? Int.zero_ext_idem by omega; auto. +- destruct chunk; simpl; rewrite ? Int.sign_ext_idem, ? Int.zero_ext_idem by lia; auto. - Local Opaque Val.load_result. destruct chunk; simpl; (exact I || apply Val.load_result_type || destruct Archi.ptr64; (exact I || apply Val.load_result_type)). @@ -653,7 +654,7 @@ Proof. exists j, mv = Fragment v q j /\ S j <> size_quantity_nat q). { induction n; simpl; intros. contradiction. destruct H0. - exists n; split; auto. omega. apply IHn; auto. omega. + exists n; split; auto. lia. apply IHn; auto. lia. } assert (B: forall q, q = quantity_chunk chunk -> @@ -663,7 +664,7 @@ Proof. Local Transparent inj_value. intros. unfold inj_value. destruct (size_quantity_nat_pos q) as [sz' EQ']. rewrite EQ'. simpl. constructor; auto. - intros; eapply A; eauto. omega. + intros; eapply A; eauto. lia. } assert (C: forall bl, match v with Vint _ => True | Vlong _ => True | Vfloat _ => True | Vsingle _ => True | _ => False end -> @@ -674,10 +675,10 @@ Local Transparent inj_value. constructor; auto. unfold inj_bytes; intros. exploit list_in_map_inv; eauto. intros (b & P & Q); exists b; auto. } - assert (D: shape_encoding chunk v (list_repeat (size_chunk_nat chunk) Undef)). + assert (D: shape_encoding chunk v (List.repeat Undef (size_chunk_nat chunk))). { intros. rewrite EQ; simpl; constructor; auto. - intros. eapply in_list_repeat; eauto. + intros. eapply repeat_spec; eauto. } generalize (encode_val_length chunk v). intros LEN. unfold encode_val; unfold encode_val in LEN; @@ -719,8 +720,8 @@ Proof. induction n; destruct mvs; simpl; intros; try discriminate. contradiction. destruct m; try discriminate. InvBooleans. apply beq_nat_true in H4. subst. - destruct H0. subst mv. exists n0; split; auto. omega. - eapply IHn; eauto. omega. + destruct H0. subst mv. exists n0; split; auto. lia. + eapply IHn; eauto. lia. } assert (U: forall mvs, shape_decoding chunk mvs (Val.load_result chunk Vundef)). { @@ -740,7 +741,7 @@ Proof. simpl. apply beq_nat_true in EQN. subst n q0. constructor. auto. destruct H0 as [E|[E|[E|E]]]; subst chunk; destruct q; auto || discriminate. congruence. - intros. eapply B; eauto. omega. + intros. eapply B; eauto. lia. } unfold decode_val. destruct (proj_bytes (mv1 :: mvl)) as [bl|] eqn:PB. @@ -882,21 +883,21 @@ Qed. Lemma repeat_Undef_inject_any: forall f vl, - list_forall2 (memval_inject f) (list_repeat (length vl) Undef) vl. + list_forall2 (memval_inject f) (List.repeat Undef (length vl)) vl. Proof. induction vl; simpl; constructor; auto. constructor. Qed. Lemma repeat_Undef_inject_encode_val: forall f chunk v, - list_forall2 (memval_inject f) (list_repeat (size_chunk_nat chunk) Undef) (encode_val chunk v). + list_forall2 (memval_inject f) (List.repeat Undef (size_chunk_nat chunk)) (encode_val chunk v). Proof. intros. rewrite <- (encode_val_length chunk v). apply repeat_Undef_inject_any. Qed. Lemma repeat_Undef_inject_self: forall f n, - list_forall2 (memval_inject f) (list_repeat n Undef) (list_repeat n Undef). + list_forall2 (memval_inject f) (List.repeat Undef n) (List.repeat Undef n). Proof. induction n; simpl; constructor; auto. constructor. Qed. @@ -915,7 +916,7 @@ Theorem encode_val_inject: Val.inject f v1 v2 -> list_forall2 (memval_inject f) (encode_val chunk v1) (encode_val chunk v2). Proof. -Local Opaque list_repeat. +Local Opaque List.repeat. intros. inversion H; subst; simpl; destruct chunk; auto using inj_bytes_inject, inj_value_inject, repeat_Undef_inject_self, repeat_Undef_inject_encode_val. - destruct Archi.ptr64; auto using inj_value_inject, repeat_Undef_inject_self. @@ -955,22 +956,22 @@ Proof. induction l1; simpl int_of_bytes; intros. simpl. ring. simpl length. rewrite Nat2Z.inj_succ. - replace (Z.succ (Z.of_nat (length l1)) * 8) with (Z.of_nat (length l1) * 8 + 8) by omega. + replace (Z.succ (Z.of_nat (length l1)) * 8) with (Z.of_nat (length l1) * 8 + 8) by lia. rewrite two_p_is_exp. change (two_p 8) with 256. rewrite IHl1. ring. - omega. omega. + lia. lia. Qed. Lemma int_of_bytes_range: forall l, 0 <= int_of_bytes l < two_p (Z.of_nat (length l) * 8). Proof. induction l; intros. - simpl. omega. + simpl. lia. simpl length. rewrite Nat2Z.inj_succ. - replace (Z.succ (Z.of_nat (length l)) * 8) with (Z.of_nat (length l) * 8 + 8) by omega. + replace (Z.succ (Z.of_nat (length l)) * 8) with (Z.of_nat (length l) * 8 + 8) by lia. rewrite two_p_is_exp. change (two_p 8) with 256. simpl int_of_bytes. generalize (Byte.unsigned_range a). - change Byte.modulus with 256. omega. - omega. omega. + change Byte.modulus with 256. lia. + lia. lia. Qed. Lemma length_proj_bytes: @@ -1014,7 +1015,7 @@ Proof. intros. apply Int.unsigned_repr. generalize (int_of_bytes_range l). rewrite H2. change (two_p (Z.of_nat 4 * 8)) with (Int.max_unsigned + 1). - omega. + lia. apply Val.lessdef_same. unfold decode_int, rev_if_be. destruct Archi.big_endian; rewrite B1; rewrite B2. + rewrite <- (rev_length b1) in L1. @@ -1036,18 +1037,18 @@ Lemma bytes_of_int_append: bytes_of_int n1 x1 ++ bytes_of_int n2 x2. Proof. induction n1; intros. -- simpl in *. f_equal. omega. +- simpl in *. f_equal. lia. - assert (E: two_p (Z.of_nat (S n1) * 8) = two_p (Z.of_nat n1 * 8) * 256). { rewrite Nat2Z.inj_succ. change 256 with (two_p 8). rewrite <- two_p_is_exp. - f_equal. omega. omega. omega. + f_equal. lia. lia. lia. } rewrite E in *. simpl. f_equal. apply Byte.eqm_samerepr. exists (x2 * two_p (Z.of_nat n1 * 8)). change Byte.modulus with 256. ring. rewrite Z.mul_assoc. rewrite Z_div_plus. apply IHn1. - apply Zdiv_interval_1. omega. apply two_p_gt_ZERO; omega. omega. - assumption. omega. + apply Zdiv_interval_1. lia. apply two_p_gt_ZERO; lia. lia. + assumption. lia. Qed. Lemma bytes_of_int64: diff --git a/common/Memory.v b/common/Memory.v index 9f9934c2..fa60455b 100644 --- a/common/Memory.v +++ b/common/Memory.v @@ -9,10 +9,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -208,11 +209,11 @@ Proof. induction lo using (well_founded_induction_type (Zwf_up_well_founded hi)). destruct (zlt lo hi). destruct (perm_dec m b lo k p). - destruct (H (lo + 1)). red. omega. - left; red; intros. destruct (zeq lo ofs). congruence. apply r. omega. - right; red; intros. elim n. red; intros; apply H0; omega. - right; red; intros. elim n. apply H0. omega. - left; red; intros. omegaContradiction. + destruct (H (lo + 1)). red. lia. + left; red; intros. destruct (zeq lo ofs). congruence. apply r. lia. + right; red; intros. elim n. red; intros; apply H0; lia. + right; red; intros. elim n. apply H0. lia. + left; red; intros. extlia. Defined. (** [valid_access m chunk b ofs p] holds if a memory access @@ -253,7 +254,7 @@ Theorem valid_access_valid_block: Proof. intros. destruct H. assert (perm m b ofs Cur Nonempty). - apply H. generalize (size_chunk_pos chunk). omega. + apply H. generalize (size_chunk_pos chunk). lia. eauto with mem. Qed. @@ -264,7 +265,7 @@ Lemma valid_access_perm: valid_access m chunk b ofs p -> perm m b ofs k p. Proof. - intros. destruct H. apply perm_cur. apply H. generalize (size_chunk_pos chunk). omega. + intros. destruct H. apply perm_cur. apply H. generalize (size_chunk_pos chunk). lia. Qed. Lemma valid_access_compat: @@ -310,9 +311,9 @@ Theorem valid_pointer_valid_access: Proof. intros. rewrite valid_pointer_nonempty_perm. split; intros. - split. simpl; red; intros. replace ofs0 with ofs by omega. auto. + split. simpl; red; intros. replace ofs0 with ofs by lia. auto. simpl. apply Z.divide_1_l. - destruct H. apply H. simpl. omega. + destruct H. apply H. simpl. lia. Qed. (** C allows pointers one past the last element of an array. These are not @@ -482,8 +483,8 @@ Proof. auto. simpl length in H. rewrite Nat2Z.inj_succ in H. transitivity (ZMap.get q (ZMap.set p a c)). - apply IHvl. intros. apply H. omega. - apply ZMap.gso. apply not_eq_sym. apply H. omega. + apply IHvl. intros. apply H. lia. + apply ZMap.gso. apply not_eq_sym. apply H. lia. Qed. Remark setN_outside: @@ -492,7 +493,7 @@ Remark setN_outside: ZMap.get q (setN vl p c) = ZMap.get q c. Proof. intros. apply setN_other. - intros. omega. + intros. lia. Qed. Remark getN_setN_same: @@ -502,7 +503,7 @@ Proof. induction vl; intros; simpl. auto. decEq. - rewrite setN_outside. apply ZMap.gss. omega. + rewrite setN_outside. apply ZMap.gss. lia. apply IHvl. Qed. @@ -512,7 +513,7 @@ Remark getN_exten: getN n p c1 = getN n p c2. Proof. induction n; intros. auto. rewrite Nat2Z.inj_succ in H. simpl. decEq. - apply H. omega. apply IHn. intros. apply H. omega. + apply H. lia. apply IHn. intros. apply H. lia. Qed. Remark getN_setN_disjoint: @@ -636,7 +637,7 @@ Qed. Theorem valid_access_empty: forall chunk b ofs p, ~valid_access empty chunk b ofs p. Proof. intros. red; intros. elim (perm_empty b ofs Cur p). apply H. - generalize (size_chunk_pos chunk); omega. + generalize (size_chunk_pos chunk); lia. Qed. (** ** Properties related to [load] *) @@ -801,7 +802,7 @@ Theorem loadbytes_empty: n <= 0 -> loadbytes m b ofs n = Some nil. Proof. intros. unfold loadbytes. rewrite pred_dec_true. rewrite Z_to_nat_neg; auto. - red; intros. omegaContradiction. + red; intros. extlia. Qed. Lemma getN_concat: @@ -809,9 +810,9 @@ Lemma getN_concat: getN (n1 + n2)%nat p c = getN n1 p c ++ getN n2 (p + Z.of_nat n1) c. Proof. induction n1; intros. - simpl. decEq. omega. + simpl. decEq. lia. rewrite Nat2Z.inj_succ. simpl. decEq. - replace (p + Z.succ (Z.of_nat n1)) with ((p + 1) + Z.of_nat n1) by omega. + replace (p + Z.succ (Z.of_nat n1)) with ((p + 1) + Z.of_nat n1) by lia. auto. Qed. @@ -825,12 +826,12 @@ Proof. unfold loadbytes; intros. destruct (range_perm_dec m b ofs (ofs + n1) Cur Readable); try congruence. destruct (range_perm_dec m b (ofs + n1) (ofs + n1 + n2) Cur Readable); try congruence. - rewrite pred_dec_true. rewrite Z2Nat.inj_add by omega. - rewrite getN_concat. rewrite Z2Nat.id by omega. + rewrite pred_dec_true. rewrite Z2Nat.inj_add by lia. + rewrite getN_concat. rewrite Z2Nat.id by lia. congruence. red; intros. - assert (ofs0 < ofs + n1 \/ ofs0 >= ofs + n1) by omega. - destruct H4. apply r; omega. apply r0; omega. + assert (ofs0 < ofs + n1 \/ ofs0 >= ofs + n1) by lia. + destruct H4. apply r; lia. apply r0; lia. Qed. Theorem loadbytes_split: @@ -845,13 +846,13 @@ Proof. unfold loadbytes; intros. destruct (range_perm_dec m b ofs (ofs + (n1 + n2)) Cur Readable); try congruence. - rewrite Z2Nat.inj_add in H by omega. rewrite getN_concat in H. - rewrite Z2Nat.id in H by omega. + rewrite Z2Nat.inj_add in H by lia. rewrite getN_concat in H. + rewrite Z2Nat.id in H by lia. repeat rewrite pred_dec_true. econstructor; econstructor. split. reflexivity. split. reflexivity. congruence. - red; intros; apply r; omega. - red; intros; apply r; omega. + red; intros; apply r; lia. + red; intros; apply r; lia. Qed. Theorem load_rep: @@ -871,13 +872,13 @@ Proof. revert ofs H; induction n; intros; simpl; auto. f_equal. rewrite Nat2Z.inj_succ in H. - replace ofs with (ofs+0) by omega. - apply H; omega. + replace ofs with (ofs+0) by lia. + apply H; lia. apply IHn. intros. rewrite <- Z.add_assoc. apply H. - rewrite Nat2Z.inj_succ. omega. + rewrite Nat2Z.inj_succ. lia. Qed. Theorem load_int64_split: @@ -892,7 +893,7 @@ Proof. exploit load_valid_access; eauto. intros [A B]. simpl in *. exploit load_loadbytes. eexact H. simpl. intros [bytes [LB EQ]]. change 8 with (4 + 4) in LB. - exploit loadbytes_split. eexact LB. omega. omega. + exploit loadbytes_split. eexact LB. lia. lia. intros (bytes1 & bytes2 & LB1 & LB2 & APP). change 4 with (size_chunk Mint32) in LB1. exploit loadbytes_load. eexact LB1. @@ -924,11 +925,11 @@ Proof. change (Int.unsigned (Int.repr 4)) with 4. apply Ptrofs.unsigned_repr. exploit (Zdivide_interval (Ptrofs.unsigned i) Ptrofs.modulus 8). - omega. apply Ptrofs.unsigned_range. auto. + lia. apply Ptrofs.unsigned_range. auto. exists (two_p (Ptrofs.zwordsize - 3)). unfold Ptrofs.modulus, Ptrofs.zwordsize, Ptrofs.wordsize. unfold Wordsize_Ptrofs.wordsize. destruct Archi.ptr64; reflexivity. - unfold Ptrofs.max_unsigned. omega. + unfold Ptrofs.max_unsigned. lia. Qed. Theorem loadv_int64_split: @@ -1085,7 +1086,7 @@ Qed. Theorem load_store_same: load chunk m2 b ofs = Some (Val.load_result chunk v). Proof. - apply load_store_similar_2; auto. omega. + apply load_store_similar_2; auto. lia. Qed. Theorem load_store_other: @@ -1137,9 +1138,9 @@ Proof. destruct H. congruence. destruct (zle n 0) as [z | n0]. rewrite (Z_to_nat_neg _ z). auto. - destruct H. omegaContradiction. + destruct H. extlia. apply getN_setN_outside. rewrite encode_val_length. rewrite <- size_chunk_conv. - rewrite Z2Nat.id. auto. omega. + rewrite Z2Nat.id. auto. lia. auto. red; intros. eauto with mem. rewrite pred_dec_false. auto. @@ -1152,11 +1153,11 @@ Lemma setN_in: In (ZMap.get q (setN vl p c)) vl. Proof. induction vl; intros. - simpl in H. omegaContradiction. + simpl in H. extlia. simpl length in H. rewrite Nat2Z.inj_succ in H. simpl. destruct (zeq p q). subst q. rewrite setN_outside. rewrite ZMap.gss. - auto with coqlib. omega. - right. apply IHvl. omega. + auto with coqlib. lia. + right. apply IHvl. lia. Qed. Lemma getN_in: @@ -1165,10 +1166,10 @@ Lemma getN_in: In (ZMap.get q c) (getN n p c). Proof. induction n; intros. - simpl in H; omegaContradiction. + simpl in H; extlia. rewrite Nat2Z.inj_succ in H. simpl. destruct (zeq p q). subst q. auto. - right. apply IHn. omega. + right. apply IHn. lia. Qed. End STORE. @@ -1205,28 +1206,28 @@ Proof. split. rewrite V', SIZE'. apply decode_val_shape. destruct (zeq ofs' ofs). - subst ofs'. left; split. auto. unfold c'. simpl. - rewrite setN_outside by omega. apply ZMap.gss. + rewrite setN_outside by lia. apply ZMap.gss. - right. destruct (zlt ofs ofs'). (* If ofs < ofs': the load reads (at ofs') a continuation byte from the write. ofs ofs' ofs+|chunk| [-------------------] write [-------------------] read *) -+ left; split. omega. unfold c'. simpl. apply setN_in. ++ left; split. lia. unfold c'. simpl. apply setN_in. assert (Z.of_nat (length (mv1 :: mvl)) = size_chunk chunk). { rewrite <- ENC; rewrite encode_val_length. rewrite size_chunk_conv; auto. } - simpl length in H3. rewrite Nat2Z.inj_succ in H3. omega. + simpl length in H3. rewrite Nat2Z.inj_succ in H3. lia. (* If ofs > ofs': the load reads (at ofs) the first byte from the write. ofs' ofs ofs'+|chunk'| [-------------------] write [----------------] read *) -+ right; split. omega. replace mv1 with (ZMap.get ofs c'). ++ right; split. lia. replace mv1 with (ZMap.get ofs c'). apply getN_in. assert (size_chunk chunk' = Z.succ (Z.of_nat sz')). { rewrite size_chunk_conv. rewrite SIZE'. rewrite Nat2Z.inj_succ; auto. } - omega. - unfold c'. simpl. rewrite setN_outside by omega. apply ZMap.gss. + lia. + unfold c'. simpl. rewrite setN_outside by lia. apply ZMap.gss. Qed. Definition compat_pointer_chunks (chunk1 chunk2: memory_chunk) : Prop := @@ -1313,10 +1314,10 @@ Theorem load_store_pointer_mismatch: Proof. intros. exploit load_store_overlap; eauto. - generalize (size_chunk_pos chunk'); omega. - generalize (size_chunk_pos chunk); omega. + generalize (size_chunk_pos chunk'); lia. + generalize (size_chunk_pos chunk); lia. intros (mv1 & mvl & mv1' & mvl' & ENC & DEC & CASES). - destruct CASES as [(A & B) | [(A & B) | (A & B)]]; try omegaContradiction. + destruct CASES as [(A & B) | [(A & B) | (A & B)]]; try extlia. inv ENC; inv DEC; auto. - elim H1. apply compat_pointer_chunks_true; auto. - contradiction. @@ -1338,8 +1339,8 @@ Proof. destruct (valid_access_dec m chunk1 b ofs Writable); destruct (valid_access_dec m chunk2 b ofs Writable); auto. f_equal. apply mkmem_ext; auto. congruence. - elim n. apply valid_access_compat with chunk1; auto. omega. - elim n. apply valid_access_compat with chunk2; auto. omega. + elim n. apply valid_access_compat with chunk1; auto. lia. + elim n. apply valid_access_compat with chunk2; auto. lia. Qed. Theorem store_signed_unsigned_8: @@ -1385,7 +1386,7 @@ Proof. destruct (valid_access_dec m Mfloat64 b ofs Writable); try discriminate. destruct (valid_access_dec m Mfloat64al32 b ofs Writable). rewrite <- H. f_equal. apply mkmem_ext; auto. - elim n. apply valid_access_compat with Mfloat64; auto. simpl; omega. + elim n. apply valid_access_compat with Mfloat64; auto. simpl; lia. Qed. Theorem storev_float64al32: @@ -1548,7 +1549,7 @@ Proof. rewrite pred_dec_true. rewrite storebytes_mem_contents. decEq. rewrite PMap.gsspec. destruct (peq b' b). subst b'. - apply getN_setN_disjoint. rewrite Z2Nat.id by omega. intuition congruence. + apply getN_setN_disjoint. rewrite Z2Nat.id by lia. intuition congruence. auto. red; auto with mem. apply pred_dec_false. @@ -1593,8 +1594,8 @@ Lemma setN_concat: setN (bytes1 ++ bytes2) ofs c = setN bytes2 (ofs + Z.of_nat (length bytes1)) (setN bytes1 ofs c). Proof. induction bytes1; intros. - simpl. decEq. omega. - simpl length. rewrite Nat2Z.inj_succ. simpl. rewrite IHbytes1. decEq. omega. + simpl. decEq. lia. + simpl length. rewrite Nat2Z.inj_succ. simpl. rewrite IHbytes1. decEq. lia. Qed. Theorem storebytes_concat: @@ -1613,8 +1614,8 @@ Proof. elim n. rewrite app_length. rewrite Nat2Z.inj_add. red; intros. destruct (zlt ofs0 (ofs + Z.of_nat(length bytes1))). - apply r. omega. - eapply perm_storebytes_2; eauto. apply r0. omega. + apply r. lia. + eapply perm_storebytes_2; eauto. apply r0. lia. Qed. Theorem storebytes_split: @@ -1627,10 +1628,10 @@ Proof. intros. destruct (range_perm_storebytes m b ofs bytes1) as [m1 ST1]. red; intros. exploit storebytes_range_perm; eauto. rewrite app_length. - rewrite Nat2Z.inj_add. omega. + rewrite Nat2Z.inj_add. lia. destruct (range_perm_storebytes m1 b (ofs + Z.of_nat (length bytes1)) bytes2) as [m2' ST2]. red; intros. eapply perm_storebytes_1; eauto. exploit storebytes_range_perm. - eexact H. instantiate (1 := ofs0). rewrite app_length. rewrite Nat2Z.inj_add. omega. + eexact H. instantiate (1 := ofs0). rewrite app_length. rewrite Nat2Z.inj_add. lia. auto. assert (Some m2 = Some m2'). rewrite <- H. eapply storebytes_concat; eauto. @@ -1738,7 +1739,7 @@ Theorem perm_alloc_2: Proof. unfold perm; intros. injection ALLOC; intros. rewrite <- H1; simpl. subst b. rewrite PMap.gss. unfold proj_sumbool. rewrite zle_true. - rewrite zlt_true. simpl. auto with mem. omega. omega. + rewrite zlt_true. simpl. auto with mem. lia. lia. Qed. Theorem perm_alloc_inv: @@ -1782,7 +1783,7 @@ Theorem valid_access_alloc_same: valid_access m2 chunk b ofs Freeable. Proof. intros. constructor; auto with mem. - red; intros. apply perm_alloc_2. omega. + red; intros. apply perm_alloc_2. lia. Qed. Local Hint Resolve valid_access_alloc_other valid_access_alloc_same: mem. @@ -1797,11 +1798,11 @@ Proof. intros. inv H. generalize (size_chunk_pos chunk); intro. destruct (eq_block b' b). subst b'. - assert (perm m2 b ofs Cur p). apply H0. omega. - assert (perm m2 b (ofs + size_chunk chunk - 1) Cur p). apply H0. omega. + assert (perm m2 b ofs Cur p). apply H0. lia. + assert (perm m2 b (ofs + size_chunk chunk - 1) Cur p). apply H0. lia. exploit perm_alloc_inv. eexact H2. rewrite dec_eq_true. intro. exploit perm_alloc_inv. eexact H3. rewrite dec_eq_true. intro. - intuition omega. + intuition lia. split; auto. red; intros. exploit perm_alloc_inv. apply H0. eauto. rewrite dec_eq_false; auto. Qed. @@ -1848,7 +1849,7 @@ Theorem load_alloc_same': Proof. intros. assert (exists v, load chunk m2 b ofs = Some v). apply valid_access_load. constructor; auto. - red; intros. eapply perm_implies. apply perm_alloc_2. omega. auto with mem. + red; intros. eapply perm_implies. apply perm_alloc_2. lia. auto with mem. destruct H2 as [v LOAD]. rewrite LOAD. decEq. eapply load_alloc_same; eauto. Qed. @@ -1958,7 +1959,7 @@ Theorem perm_free_2: Proof. intros. rewrite free_result. unfold perm, unchecked_free; simpl. rewrite PMap.gss. unfold proj_sumbool. rewrite zle_true. rewrite zlt_true. - simpl. tauto. omega. omega. + simpl. tauto. lia. lia. Qed. Theorem perm_free_3: @@ -1991,7 +1992,7 @@ Theorem valid_access_free_1: Proof. intros. inv H. constructor; auto with mem. red; intros. eapply perm_free_1; eauto. - destruct (zlt lo hi). intuition. right. omega. + destruct (zlt lo hi). intuition. right. lia. Qed. Theorem valid_access_free_2: @@ -2003,9 +2004,9 @@ Proof. generalize (size_chunk_pos chunk); intros. destruct (zlt ofs lo). elim (perm_free_2 lo Cur p). - omega. apply H3. omega. + lia. apply H3. lia. elim (perm_free_2 ofs Cur p). - omega. apply H3. omega. + lia. apply H3. lia. Qed. Theorem valid_access_free_inv_1: @@ -2031,7 +2032,7 @@ Proof. destruct (zlt lo hi); auto. destruct (zle (ofs + size_chunk chunk) lo); auto. destruct (zle hi ofs); auto. - elim (valid_access_free_2 chunk ofs p); auto. omega. + elim (valid_access_free_2 chunk ofs p); auto. lia. Qed. Theorem load_free: @@ -2069,7 +2070,7 @@ Proof. red; intros. eapply perm_free_3; eauto. rewrite pred_dec_false; auto. red; intros. elim n0; red; intros. - eapply perm_free_1; eauto. destruct H; auto. right; omega. + eapply perm_free_1; eauto. destruct H; auto. right; lia. Qed. Theorem loadbytes_free_2: @@ -2139,7 +2140,7 @@ Proof. unfold drop_perm in DROP. destruct (range_perm_dec m b lo hi Cur Freeable); inv DROP. unfold perm. simpl. rewrite PMap.gss. unfold proj_sumbool. rewrite zle_true. rewrite zlt_true. simpl. constructor. - omega. omega. + lia. lia. Qed. Theorem perm_drop_2: @@ -2149,7 +2150,7 @@ Proof. unfold drop_perm in DROP. destruct (range_perm_dec m b lo hi Cur Freeable); inv DROP. revert H0. unfold perm; simpl. rewrite PMap.gss. unfold proj_sumbool. rewrite zle_true. rewrite zlt_true. simpl. auto. - omega. omega. + lia. lia. Qed. Theorem perm_drop_3: @@ -2159,7 +2160,7 @@ Proof. unfold drop_perm in DROP. destruct (range_perm_dec m b lo hi Cur Freeable); inv DROP. unfold perm; simpl. rewrite PMap.gsspec. destruct (peq b' b). subst b'. unfold proj_sumbool. destruct (zle lo ofs). destruct (zlt ofs hi). - byContradiction. intuition omega. + byContradiction. intuition lia. auto. auto. auto. Qed. @@ -2185,7 +2186,7 @@ Proof. destruct (eq_block b' b). subst b'. destruct (zlt ofs0 lo). eapply perm_drop_3; eauto. destruct (zle hi ofs0). eapply perm_drop_3; eauto. - apply perm_implies with p. eapply perm_drop_1; eauto. omega. + apply perm_implies with p. eapply perm_drop_1; eauto. lia. generalize (size_chunk_pos chunk); intros. intuition. eapply perm_drop_3; eauto. Qed. @@ -2227,7 +2228,7 @@ Proof. destruct (eq_block b' b). subst b'. destruct (zlt ofs0 lo). eapply perm_drop_3; eauto. destruct (zle hi ofs0). eapply perm_drop_3; eauto. - apply perm_implies with p. eapply perm_drop_1; eauto. omega. intuition. + apply perm_implies with p. eapply perm_drop_1; eauto. lia. intuition. eapply perm_drop_3; eauto. rewrite pred_dec_false; eauto. red; intros; elim n0; red; intros. @@ -2285,8 +2286,8 @@ Lemma range_perm_inj: range_perm m2 b2 (lo + delta) (hi + delta) k p. Proof. intros; red; intros. - replace ofs with ((ofs - delta) + delta) by omega. - eapply perm_inj; eauto. apply H0. omega. + replace ofs with ((ofs - delta) + delta) by lia. + eapply perm_inj; eauto. apply H0. lia. Qed. Lemma valid_access_inj: @@ -2298,7 +2299,7 @@ Lemma valid_access_inj: Proof. intros. destruct H1 as [A B]. constructor. replace (ofs + delta + size_chunk chunk) - with ((ofs + size_chunk chunk) + delta) by omega. + with ((ofs + size_chunk chunk) + delta) by lia. eapply range_perm_inj; eauto. apply Z.divide_add_r; auto. eapply mi_align; eauto with mem. Qed. @@ -2320,9 +2321,9 @@ Proof. rewrite Nat2Z.inj_succ in H1. constructor. eapply mi_memval; eauto. - apply H1. omega. - replace (ofs + delta + 1) with ((ofs + 1) + delta) by omega. - apply IHn. red; intros; apply H1; omega. + apply H1. lia. + replace (ofs + delta + 1) with ((ofs + 1) + delta) by lia. + apply IHn. red; intros; apply H1; lia. Qed. Lemma load_inj: @@ -2353,11 +2354,11 @@ Proof. destruct (range_perm_dec m1 b1 ofs (ofs + len) Cur Readable); inv H0. exists (getN (Z.to_nat len) (ofs + delta) (m2.(mem_contents)#b2)). split. apply pred_dec_true. - replace (ofs + delta + len) with ((ofs + len) + delta) by omega. + replace (ofs + delta + len) with ((ofs + len) + delta) by lia. eapply range_perm_inj; eauto with mem. apply getN_inj; auto. - destruct (zle 0 len). rewrite Z2Nat.id by omega. auto. - rewrite Z_to_nat_neg by omega. simpl. red; intros; omegaContradiction. + destruct (zle 0 len). rewrite Z2Nat.id by lia. auto. + rewrite Z_to_nat_neg by lia. simpl. red; intros; extlia. Qed. (** Preservation of stores. *) @@ -2372,11 +2373,11 @@ Lemma setN_inj: Proof. induction 1; intros; simpl. auto. - replace (p + delta + 1) with ((p + 1) + delta) by omega. + replace (p + delta + 1) with ((p + 1) + delta) by lia. apply IHlist_forall2; auto. intros. rewrite ZMap.gsspec at 1. destruct (ZIndexed.eq q0 p). subst q0. rewrite ZMap.gss. auto. - rewrite ZMap.gso. auto. unfold ZIndexed.t in *. omega. + rewrite ZMap.gso. auto. unfold ZIndexed.t in *. lia. Qed. Definition meminj_no_overlap (f: meminj) (m: mem) : Prop := @@ -2431,8 +2432,8 @@ Proof. assert (b2 <> b2 \/ ofs0 + delta0 <> (r - delta) + delta). eapply H1; eauto. eauto 6 with mem. exploit store_valid_access_3. eexact H0. intros [A B]. - eapply perm_implies. apply perm_cur_max. apply A. omega. auto with mem. - destruct H8. congruence. omega. + eapply perm_implies. apply perm_cur_max. apply A. lia. auto with mem. + destruct H8. congruence. lia. (* block <> b1, block <> b2 *) eapply mi_memval; eauto. eauto with mem. Qed. @@ -2479,8 +2480,8 @@ Proof. rewrite setN_outside. auto. rewrite encode_val_length. rewrite <- size_chunk_conv. destruct (zlt (ofs0 + delta) ofs); auto. - destruct (zle (ofs + size_chunk chunk) (ofs0 + delta)). omega. - byContradiction. eapply H0; eauto. omega. + destruct (zle (ofs + size_chunk chunk) (ofs0 + delta)). lia. + byContradiction. eapply H0; eauto. lia. eauto with mem. Qed. @@ -2501,7 +2502,7 @@ Proof. with ((ofs + Z.of_nat (length bytes1)) + delta). eapply range_perm_inj; eauto with mem. eapply storebytes_range_perm; eauto. - rewrite (list_forall2_length H3). omega. + rewrite (list_forall2_length H3). lia. destruct (range_perm_storebytes _ _ _ _ H4) as [n2 STORE]. exists n2; split. eauto. constructor. @@ -2532,9 +2533,9 @@ Proof. eapply H1; eauto 6 with mem. exploit storebytes_range_perm. eexact H0. instantiate (1 := r - delta). - rewrite (list_forall2_length H3). omega. + rewrite (list_forall2_length H3). lia. eauto 6 with mem. - destruct H9. congruence. omega. + destruct H9. congruence. lia. (* block <> b1, block <> b2 *) eauto. Qed. @@ -2581,8 +2582,8 @@ Proof. rewrite PMap.gsspec. destruct (peq b2 b). subst b2. rewrite setN_outside. auto. destruct (zlt (ofs0 + delta) ofs); auto. - destruct (zle (ofs + Z.of_nat (length bytes2)) (ofs0 + delta)). omega. - byContradiction. eapply H0; eauto. omega. + destruct (zle (ofs + Z.of_nat (length bytes2)) (ofs0 + delta)). lia. + byContradiction. eapply H0; eauto. lia. eauto with mem. Qed. @@ -2679,10 +2680,10 @@ Proof. intros. destruct (eq_block b0 b1). subst b0. assert (delta0 = delta) by congruence. subst delta0. assert (lo <= ofs < hi). - { eapply perm_alloc_3; eauto. apply H6. generalize (size_chunk_pos chunk); omega. } + { eapply perm_alloc_3; eauto. apply H6. generalize (size_chunk_pos chunk); lia. } assert (lo <= ofs + size_chunk chunk - 1 < hi). - { eapply perm_alloc_3; eauto. apply H6. generalize (size_chunk_pos chunk); omega. } - apply H2. omega. + { eapply perm_alloc_3; eauto. apply H6. generalize (size_chunk_pos chunk); lia. } + apply H2. lia. eapply mi_align0 with (ofs := ofs) (p := p); eauto. red; intros. eapply perm_alloc_4; eauto. (* mem_contents *) @@ -2727,7 +2728,7 @@ Proof. intros. eapply perm_free_1; eauto. destruct (eq_block b2 b); auto. subst b. right. assert (~ (lo <= ofs + delta < hi)). red; intros; eapply H1; eauto. - omega. + lia. constructor. (* perm *) auto. @@ -2772,8 +2773,8 @@ Proof. intros. assert ({ m2' | drop_perm m2 b2 (lo + delta) (hi + delta) p = Some m2' }). apply range_perm_drop_2. red; intros. - replace ofs with ((ofs - delta) + delta) by omega. - eapply perm_inj; eauto. eapply range_perm_drop_1; eauto. omega. + replace ofs with ((ofs - delta) + delta) by lia. + eapply perm_inj; eauto. eapply range_perm_drop_1; eauto. lia. destruct X as [m2' DROP]. exists m2'; split; auto. inv H. constructor. @@ -2787,9 +2788,9 @@ Proof. destruct (zlt (ofs + delta0) (lo + delta0)). eapply perm_drop_3; eauto. destruct (zle (hi + delta0) (ofs + delta0)). eapply perm_drop_3; eauto. assert (perm_order p p0). - eapply perm_drop_2. eexact H0. instantiate (1 := ofs). omega. eauto. + eapply perm_drop_2. eexact H0. instantiate (1 := ofs). lia. eauto. apply perm_implies with p; auto. - eapply perm_drop_1. eauto. omega. + eapply perm_drop_1. eauto. lia. (* b1 <> b0 *) eapply perm_drop_3; eauto. destruct (eq_block b3 b2); auto. @@ -2798,7 +2799,7 @@ Proof. exploit H1; eauto. instantiate (1 := ofs + delta0 - delta). apply perm_cur_max. apply perm_implies with Freeable. - eapply range_perm_drop_1; eauto. omega. auto with mem. + eapply range_perm_drop_1; eauto. lia. auto with mem. eapply perm_drop_4; eauto. eapply perm_max. apply perm_implies with p0. eauto. eauto with mem. intuition. @@ -2829,7 +2830,7 @@ Proof. destruct (eq_block b2 b); auto. subst b2. right. destruct (zlt (ofs + delta) lo); auto. destruct (zle hi (ofs + delta)); auto. - byContradiction. exploit H1; eauto. omega. + byContradiction. exploit H1; eauto. lia. (* align *) eapply mi_align0; eauto. (* contents *) @@ -2862,9 +2863,9 @@ Theorem extends_refl: forall m, extends m m. Proof. intros. constructor. auto. constructor. - intros. unfold inject_id in H; inv H. replace (ofs + 0) with ofs by omega. auto. + intros. unfold inject_id in H; inv H. replace (ofs + 0) with ofs by lia. auto. intros. unfold inject_id in H; inv H. apply Z.divide_0_r. - intros. unfold inject_id in H; inv H. replace (ofs + 0) with ofs by omega. + intros. unfold inject_id in H; inv H. replace (ofs + 0) with ofs by lia. apply memval_lessdef_refl. tauto. Qed. @@ -2877,7 +2878,7 @@ Theorem load_extends: Proof. intros. inv H. exploit load_inj; eauto. unfold inject_id; reflexivity. intros [v2 [A B]]. exists v2; split. - replace (ofs + 0) with ofs in A by omega. auto. + replace (ofs + 0) with ofs in A by lia. auto. rewrite val_inject_id in B. auto. Qed. @@ -2901,7 +2902,7 @@ Theorem loadbytes_extends: /\ list_forall2 memval_lessdef bytes1 bytes2. Proof. intros. inv H. - replace ofs with (ofs + 0) by omega. eapply loadbytes_inj; eauto. + replace ofs with (ofs + 0) by lia. eapply loadbytes_inj; eauto. Qed. Theorem store_within_extends: @@ -2920,7 +2921,7 @@ Proof. rewrite val_inject_id. eauto. intros [m2' [A B]]. exists m2'; split. - replace (ofs + 0) with ofs in A by omega. auto. + replace (ofs + 0) with ofs in A by lia. auto. constructor; auto. rewrite (nextblock_store _ _ _ _ _ _ H0). rewrite (nextblock_store _ _ _ _ _ _ A). @@ -2938,7 +2939,7 @@ Proof. intros. inversion H. constructor. rewrite (nextblock_store _ _ _ _ _ _ H0). auto. eapply store_outside_inj; eauto. - unfold inject_id; intros. inv H2. eapply H1; eauto. omega. + unfold inject_id; intros. inv H2. eapply H1; eauto. lia. intros. eauto using perm_store_2. Qed. @@ -2972,7 +2973,7 @@ Proof. unfold inject_id; reflexivity. intros [m2' [A B]]. exists m2'; split. - replace (ofs + 0) with ofs in A by omega. auto. + replace (ofs + 0) with ofs in A by lia. auto. constructor; auto. rewrite (nextblock_storebytes _ _ _ _ _ H0). rewrite (nextblock_storebytes _ _ _ _ _ A). @@ -2990,7 +2991,7 @@ Proof. intros. inversion H. constructor. rewrite (nextblock_storebytes _ _ _ _ _ H0). auto. eapply storebytes_outside_inj; eauto. - unfold inject_id; intros. inv H2. eapply H1; eauto. omega. + unfold inject_id; intros. inv H2. eapply H1; eauto. lia. intros. eauto using perm_storebytes_2. Qed. @@ -3022,12 +3023,12 @@ Proof. intros. eapply perm_implies with Freeable; auto with mem. eapply perm_alloc_2; eauto. - omega. + lia. intros. eapply perm_alloc_inv in H; eauto. generalize (perm_alloc_inv _ _ _ _ _ H0 b0 ofs Max Nonempty); intros PERM. destruct (eq_block b0 b). subst b0. - assert (EITHER: lo1 <= ofs < hi1 \/ ~(lo1 <= ofs < hi1)) by omega. + assert (EITHER: lo1 <= ofs < hi1 \/ ~(lo1 <= ofs < hi1)) by lia. destruct EITHER. left. apply perm_implies with Freeable; auto with mem. eapply perm_alloc_2; eauto. right; tauto. @@ -3059,7 +3060,7 @@ Proof. intros. inv H. constructor. rewrite (nextblock_free _ _ _ _ _ H0). auto. eapply free_right_inj; eauto. - unfold inject_id; intros. inv H. eapply H1; eauto. omega. + unfold inject_id; intros. inv H. eapply H1; eauto. lia. intros. eauto using perm_free_3. Qed. @@ -3074,7 +3075,7 @@ Proof. intros. inversion H. assert ({ m2': mem | free m2 b lo hi = Some m2' }). apply range_perm_free. red; intros. - replace ofs with (ofs + 0) by omega. + replace ofs with (ofs + 0) by lia. eapply perm_inj with (b1 := b); eauto. eapply free_range_perm; eauto. destruct X as [m2' FREE]. exists m2'; split; auto. @@ -3084,7 +3085,7 @@ Proof. eapply free_right_inj with (m1 := m1'); eauto. eapply free_left_inj; eauto. unfold inject_id; intros. inv H1. - eapply perm_free_2. eexact H0. instantiate (1 := ofs); omega. eauto. + eapply perm_free_2. eexact H0. instantiate (1 := ofs); lia. eauto. intros. exploit mext_perm_inv0; eauto using perm_free_3. intros [A|A]. eapply perm_free_inv in A; eauto. destruct A as [[A B]|A]; auto. subst b0. right; eapply perm_free_2; eauto. @@ -3103,7 +3104,7 @@ Theorem perm_extends: forall m1 m2 b ofs k p, extends m1 m2 -> perm m1 b ofs k p -> perm m2 b ofs k p. Proof. - intros. inv H. replace ofs with (ofs + 0) by omega. + intros. inv H. replace ofs with (ofs + 0) by lia. eapply perm_inj; eauto. Qed. @@ -3118,7 +3119,7 @@ Theorem valid_access_extends: forall m1 m2 chunk b ofs p, extends m1 m2 -> valid_access m1 chunk b ofs p -> valid_access m2 chunk b ofs p. Proof. - intros. inv H. replace ofs with (ofs + 0) by omega. + intros. inv H. replace ofs with (ofs + 0) by lia. eapply valid_access_inj; eauto. auto. Qed. @@ -3263,7 +3264,7 @@ Theorem weak_valid_pointer_inject: weak_valid_pointer m2 b2 (ofs + delta) = true. Proof. intros until 2. unfold weak_valid_pointer. rewrite !orb_true_iff. - replace (ofs + delta - 1) with ((ofs - 1) + delta) by omega. + replace (ofs + delta - 1) with ((ofs - 1) + delta) by lia. intros []; eauto using valid_pointer_inject. Qed. @@ -3281,8 +3282,8 @@ Proof. assert (perm m1 b1 (Ptrofs.unsigned ofs1) Max Nonempty) by eauto with mem. exploit mi_representable; eauto. intros [A B]. assert (0 <= delta <= Ptrofs.max_unsigned). - generalize (Ptrofs.unsigned_range ofs1). omega. - unfold Ptrofs.add. repeat rewrite Ptrofs.unsigned_repr; omega. + generalize (Ptrofs.unsigned_range ofs1). lia. + unfold Ptrofs.add. repeat rewrite Ptrofs.unsigned_repr; lia. Qed. Lemma address_inject': @@ -3293,7 +3294,7 @@ Lemma address_inject': Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta)) = Ptrofs.unsigned ofs1 + delta. Proof. intros. destruct H0. eapply address_inject; eauto. - apply H0. generalize (size_chunk_pos chunk). omega. + apply H0. generalize (size_chunk_pos chunk). lia. Qed. Theorem weak_valid_pointer_inject_no_overflow: @@ -3308,7 +3309,7 @@ Proof. exploit mi_representable; eauto. destruct H0; eauto with mem. intros [A B]. pose proof (Ptrofs.unsigned_range ofs). - rewrite Ptrofs.unsigned_repr; omega. + rewrite Ptrofs.unsigned_repr; lia. Qed. Theorem valid_pointer_inject_no_overflow: @@ -3348,7 +3349,7 @@ Proof. exploit mi_representable; eauto. destruct H0; eauto with mem. intros [A B]. pose proof (Ptrofs.unsigned_range ofs). - unfold Ptrofs.add. repeat rewrite Ptrofs.unsigned_repr; auto; omega. + unfold Ptrofs.add. repeat rewrite Ptrofs.unsigned_repr; auto; lia. Qed. Theorem inject_no_overlap: @@ -3383,8 +3384,8 @@ Proof. rewrite (address_inject' _ _ _ _ _ _ _ _ H H2 H4). inv H1. simpl in H5. inv H2. simpl in H1. eapply mi_no_overlap; eauto. - apply perm_cur_max. apply (H5 (Ptrofs.unsigned ofs1)). omega. - apply perm_cur_max. apply (H1 (Ptrofs.unsigned ofs2)). omega. + apply perm_cur_max. apply (H5 (Ptrofs.unsigned ofs1)). lia. + apply perm_cur_max. apply (H1 (Ptrofs.unsigned ofs2)). lia. Qed. Theorem disjoint_or_equal_inject: @@ -3403,16 +3404,16 @@ Proof. intros. destruct (eq_block b1 b2). assert (b1' = b2') by congruence. assert (delta1 = delta2) by congruence. subst. - destruct H5. congruence. right. destruct H5. left; congruence. right. omega. + destruct H5. congruence. right. destruct H5. left; congruence. right. lia. destruct (eq_block b1' b2'); auto. subst. right. right. set (i1 := (ofs1 + delta1, ofs1 + delta1 + sz)). set (i2 := (ofs2 + delta2, ofs2 + delta2 + sz)). change (snd i1 <= fst i2 \/ snd i2 <= fst i1). - apply Intv.range_disjoint'; simpl; try omega. + apply Intv.range_disjoint'; simpl; try lia. unfold Intv.disjoint, Intv.In; simpl; intros. red; intros. exploit mi_no_overlap; eauto. - instantiate (1 := x - delta1). apply H2. omega. - instantiate (1 := x - delta2). apply H3. omega. + instantiate (1 := x - delta1). apply H2. lia. + instantiate (1 := x - delta2). apply H3. lia. intuition. Qed. @@ -3427,9 +3428,9 @@ Theorem aligned_area_inject: (al | ofs + delta). Proof. intros. - assert (P: al > 0) by omega. - assert (Q: Z.abs al <= Z.abs sz). apply Zdivide_bounds; auto. omega. - rewrite Z.abs_eq in Q; try omega. rewrite Z.abs_eq in Q; try omega. + assert (P: al > 0) by lia. + assert (Q: Z.abs al <= Z.abs sz). apply Zdivide_bounds; auto. lia. + rewrite Z.abs_eq in Q; try lia. rewrite Z.abs_eq in Q; try lia. assert (R: exists chunk, al = align_chunk chunk /\ al = size_chunk chunk). destruct H0. subst; exists Mint8unsigned; auto. destruct H0. subst; exists Mint16unsigned; auto. @@ -3437,7 +3438,7 @@ Proof. subst; exists Mint64; auto. destruct R as [chunk [A B]]. assert (valid_access m chunk b ofs Nonempty). - split. red; intros; apply H3. omega. congruence. + split. red; intros; apply H3. lia. congruence. exploit valid_access_inject; eauto. intros [C D]. congruence. Qed. @@ -3794,7 +3795,7 @@ Proof. unfold f'; intros. destruct (eq_block b0 b1). inversion H8. subst b0 b3 delta0. elim (fresh_block_alloc _ _ _ _ _ H0). - eapply perm_valid_block with (ofs := ofs). apply H9. generalize (size_chunk_pos chunk); omega. + eapply perm_valid_block with (ofs := ofs). apply H9. generalize (size_chunk_pos chunk); lia. eauto. unfold f'; intros. destruct (eq_block b0 b1). inversion H8. subst b0 b3 delta0. @@ -3817,10 +3818,10 @@ Proof. congruence. inversion H10; subst b0 b1' delta1. destruct (eq_block b2 b2'); auto. subst b2'. right; red; intros. - eapply H6; eauto. omega. + eapply H6; eauto. lia. inversion H11; subst b3 b2' delta2. destruct (eq_block b1' b2); auto. subst b1'. right; red; intros. - eapply H6; eauto. omega. + eapply H6; eauto. lia. eauto. (* representable *) unfold f'; intros. @@ -3828,16 +3829,16 @@ Proof. subst. injection H9; intros; subst b' delta0. destruct H10. exploit perm_alloc_inv; eauto; rewrite dec_eq_true; intro. exploit H3. apply H4 with (k := Max) (p := Nonempty); eauto. - generalize (Ptrofs.unsigned_range_2 ofs). omega. + generalize (Ptrofs.unsigned_range_2 ofs). lia. exploit perm_alloc_inv; eauto; rewrite dec_eq_true; intro. exploit H3. apply H4 with (k := Max) (p := Nonempty); eauto. - generalize (Ptrofs.unsigned_range_2 ofs). omega. + generalize (Ptrofs.unsigned_range_2 ofs). lia. eapply mi_representable0; try eassumption. destruct H10; eauto using perm_alloc_4. (* perm inv *) intros. unfold f' in H9; destruct (eq_block b0 b1). inversion H9; clear H9; subst b0 b3 delta0. - assert (EITHER: lo <= ofs < hi \/ ~(lo <= ofs < hi)) by omega. + assert (EITHER: lo <= ofs < hi \/ ~(lo <= ofs < hi)) by lia. destruct EITHER. left. apply perm_implies with Freeable; auto with mem. eapply perm_alloc_2; eauto. right; intros A. eapply perm_alloc_inv in A; eauto. rewrite dec_eq_true in A. tauto. @@ -3868,10 +3869,10 @@ Proof. eapply alloc_right_inject; eauto. eauto. instantiate (1 := b2). eauto with mem. - instantiate (1 := 0). unfold Ptrofs.max_unsigned. generalize Ptrofs.modulus_pos; omega. + instantiate (1 := 0). unfold Ptrofs.max_unsigned. generalize Ptrofs.modulus_pos; lia. auto. intros. apply perm_implies with Freeable; auto with mem. - eapply perm_alloc_2; eauto. omega. + eapply perm_alloc_2; eauto. lia. red; intros. apply Z.divide_0_r. intros. apply (valid_not_valid_diff m2 b2 b2); eauto with mem. intros [f' [A [B [C D]]]]. @@ -3994,13 +3995,13 @@ Proof. simpl; rewrite H0; auto. intros. destruct (eq_block b1 b). subst b1. rewrite H1 in H2; inv H2. - exists lo, hi; split; auto with coqlib. omega. + exists lo, hi; split; auto with coqlib. lia. exploit mi_no_overlap. eexact H. eexact n. eauto. eauto. eapply perm_max. eapply perm_implies. eauto. auto with mem. instantiate (1 := ofs + delta0 - delta). apply perm_cur_max. apply perm_implies with Freeable; auto with mem. - eapply free_range_perm; eauto. omega. - intros [A|A]. congruence. omega. + eapply free_range_perm; eauto. lia. + intros [A|A]. congruence. lia. Qed. Lemma drop_outside_inject: forall f m1 m2 b lo hi p m2', @@ -4027,7 +4028,7 @@ Proof. (* perm *) destruct (f b1) as [[b' delta'] |] eqn:?; try discriminate. destruct (f' b') as [[b'' delta''] |] eqn:?; inv H. - replace (ofs + (delta' + delta'')) with ((ofs + delta') + delta'') by omega. + replace (ofs + (delta' + delta'')) with ((ofs + delta') + delta'') by lia. eauto. (* align *) destruct (f b1) as [[b' delta'] |] eqn:?; try discriminate. @@ -4035,12 +4036,12 @@ Proof. apply Z.divide_add_r. eapply mi_align0; eauto. eapply mi_align1 with (ofs := ofs + delta') (p := p); eauto. - red; intros. replace ofs0 with ((ofs0 - delta') + delta') by omega. - eapply mi_perm0; eauto. apply H0. omega. + red; intros. replace ofs0 with ((ofs0 - delta') + delta') by lia. + eapply mi_perm0; eauto. apply H0. lia. (* memval *) destruct (f b1) as [[b' delta'] |] eqn:?; try discriminate. destruct (f' b') as [[b'' delta''] |] eqn:?; inv H. - replace (ofs + (delta' + delta'')) with ((ofs + delta') + delta'') by omega. + replace (ofs + (delta' + delta'')) with ((ofs + delta') + delta'') by lia. eapply memval_inject_compose; eauto. Qed. @@ -4069,11 +4070,11 @@ Proof. exploit mi_no_overlap0; eauto. intros A. destruct (eq_block b1x b2x). subst b1x. destruct A. congruence. - assert (delta1y = delta2y) by congruence. right; omega. + assert (delta1y = delta2y) by congruence. right; lia. exploit mi_no_overlap1. eauto. eauto. eauto. eapply perm_inj. eauto. eexact H2. eauto. eapply perm_inj. eauto. eexact H3. eauto. - intuition omega. + intuition lia. (* representable *) intros. destruct (f b) as [[b1 delta1] |] eqn:?; try discriminate. @@ -4085,15 +4086,15 @@ Proof. exploit mi_representable1. eauto. instantiate (1 := ofs'). rewrite H. replace (Ptrofs.unsigned ofs + delta1 - 1) with - ((Ptrofs.unsigned ofs - 1) + delta1) by omega. + ((Ptrofs.unsigned ofs - 1) + delta1) by lia. destruct H0; eauto using perm_inj. - rewrite H. omega. + rewrite H. lia. (* perm inv *) intros. destruct (f b1) as [[b' delta'] |] eqn:?; try discriminate. destruct (f' b') as [[b'' delta''] |] eqn:?; try discriminate. inversion H; clear H; subst b'' delta. - replace (ofs + (delta' + delta'')) with ((ofs + delta') + delta'') in H0 by omega. + replace (ofs + (delta' + delta'')) with ((ofs + delta') + delta'') in H0 by lia. exploit mi_perm_inv1; eauto. intros [A|A]. eapply mi_perm_inv0; eauto. right; red; intros. elim A. eapply perm_inj; eauto. @@ -4145,7 +4146,7 @@ Proof. (* inj *) replace f with (compose_meminj f inject_id). eapply mem_inj_compose; eauto. apply extensionality; intros. unfold compose_meminj, inject_id. - destruct (f x) as [[y delta] | ]; auto. decEq. decEq. omega. + destruct (f x) as [[y delta] | ]; auto. decEq. decEq. lia. (* unmapped *) eauto. (* mapped *) @@ -4210,7 +4211,7 @@ Proof. apply flat_inj_no_overlap. (* range *) unfold flat_inj; intros. - destruct (plt b (nextblock m)); inv H0. generalize (Ptrofs.unsigned_range_2 ofs); omega. + destruct (plt b (nextblock m)); inv H0. generalize (Ptrofs.unsigned_range_2 ofs); lia. (* perm inv *) unfold flat_inj; intros. destruct (plt b1 (nextblock m)); inv H0. @@ -4223,7 +4224,7 @@ Proof. intros; red; constructor. (* perm *) unfold flat_inj; intros. destruct (plt b1 thr); inv H. - replace (ofs + 0) with ofs by omega; auto. + replace (ofs + 0) with ofs by lia; auto. (* align *) unfold flat_inj; intros. destruct (plt b1 thr); inv H. apply Z.divide_0_r. (* mem_contents *) @@ -4243,7 +4244,7 @@ Proof. red. intros. apply Z.divide_0_r. intros. apply perm_implies with Freeable; auto with mem. - eapply perm_alloc_2; eauto. omega. + eapply perm_alloc_2; eauto. lia. unfold flat_inj. apply pred_dec_true. rewrite (alloc_result _ _ _ _ _ H). auto. Qed. @@ -4259,7 +4260,7 @@ Proof. intros; red. exploit store_mapped_inj. eauto. eauto. apply flat_inj_no_overlap. unfold flat_inj. apply pred_dec_true; auto. eauto. - replace (ofs + 0) with ofs by omega. + replace (ofs + 0) with ofs by lia. intros [m'' [A B]]. congruence. Qed. @@ -4306,7 +4307,7 @@ Lemma valid_block_unchanged_on: forall m m' b, unchanged_on m m' -> valid_block m b -> valid_block m' b. Proof. - unfold valid_block; intros. apply unchanged_on_nextblock in H. xomega. + unfold valid_block; intros. apply unchanged_on_nextblock in H. extlia. Qed. Lemma perm_unchanged_on: @@ -4349,7 +4350,7 @@ Proof. + unfold loadbytes. destruct H. destruct (range_perm_dec m b ofs (ofs + n) Cur Readable). rewrite pred_dec_true. f_equal. - apply getN_exten. intros. rewrite Z2Nat.id in H by omega. + apply getN_exten. intros. rewrite Z2Nat.id in H by lia. apply unchanged_on_contents0; auto. red; intros. apply unchanged_on_perm0; auto. rewrite pred_dec_false. auto. @@ -4367,7 +4368,7 @@ Proof. destruct (zle n 0). + erewrite loadbytes_empty in * by assumption. auto. + rewrite <- H1. apply loadbytes_unchanged_on_1; auto. - exploit loadbytes_range_perm; eauto. instantiate (1 := ofs). omega. + exploit loadbytes_range_perm; eauto. instantiate (1 := ofs). lia. intros. eauto with mem. Qed. @@ -4410,7 +4411,7 @@ Proof. rewrite encode_val_length. rewrite <- size_chunk_conv. destruct (zlt ofs0 ofs); auto. destruct (zlt ofs0 (ofs + size_chunk chunk)); auto. - elim (H0 ofs0). omega. auto. + elim (H0 ofs0). lia. auto. Qed. Lemma storebytes_unchanged_on: @@ -4426,7 +4427,7 @@ Proof. destruct (peq b0 b); auto. subst b0. apply setN_outside. destruct (zlt ofs0 ofs); auto. destruct (zlt ofs0 (ofs + Z.of_nat (length bytes))); auto. - elim (H0 ofs0). omega. auto. + elim (H0 ofs0). lia. auto. Qed. Lemma alloc_unchanged_on: @@ -4455,7 +4456,7 @@ Proof. - split; intros. eapply perm_free_1; eauto. destruct (eq_block b0 b); auto. destruct (zlt ofs lo); auto. destruct (zle hi ofs); auto. - subst b0. elim (H0 ofs). omega. auto. + subst b0. elim (H0 ofs). lia. auto. eapply perm_free_3; eauto. - unfold free in H. destruct (range_perm_dec m b lo hi Cur Freeable); inv H. simpl. auto. @@ -4473,7 +4474,7 @@ Proof. destruct (eq_block b0 b); auto. subst b0. assert (~ (lo <= ofs < hi)). { red; intros; eelim H0; eauto. } - right; omega. + right; lia. eapply perm_drop_4; eauto. - unfold drop_perm in H. destruct (range_perm_dec m b lo hi Cur Freeable); inv H; simpl. auto. @@ -4500,7 +4501,7 @@ Notation mem := Mem.mem. Global Opaque Mem.alloc Mem.free Mem.store Mem.load Mem.storebytes Mem.loadbytes. -Hint Resolve +Global Hint Resolve Mem.valid_not_valid_diff Mem.perm_implies Mem.perm_cur diff --git a/common/Memtype.v b/common/Memtype.v index ca9c6f1f..b8ad1a6b 100644 --- a/common/Memtype.v +++ b/common/Memtype.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -60,7 +61,7 @@ Inductive perm_order: permission -> permission -> Prop := | perm_W_R: perm_order Writable Readable | perm_any_N: forall p, perm_order p Nonempty. -Hint Constructors perm_order: mem. +Global Hint Constructors perm_order: mem. Lemma perm_order_trans: forall p1 p2 p3, perm_order p1 p2 -> perm_order p2 p3 -> perm_order p1 p3. diff --git a/common/PrintAST.ml b/common/PrintAST.ml index cf3a17d5..61c76c91 100644 --- a/common/PrintAST.ml +++ b/common/PrintAST.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/common/Sections.ml b/common/Sections.ml index 839128a5..794b8470 100644 --- a/common/Sections.ml +++ b/common/Sections.ml @@ -6,21 +6,27 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) (* Handling of linker sections *) +type initialized = + | Uninit (* uninitialized data area *) + | Init (* initialized with fixed, non-relocatable data *) + | Init_reloc (* initialized with relocatable data (symbol addresses) *) + type section_name = | Section_text - | Section_data of bool (* true = init data, false = uninit data *) - | Section_small_data of bool - | Section_const of bool - | Section_small_const of bool + | Section_data of initialized + | Section_small_data of initialized + | Section_const of initialized + | Section_small_const of initialized | Section_string | Section_literal | Section_jumptable @@ -40,6 +46,7 @@ type access_mode = type section_info = { sec_name_init: section_name; + sec_name_init_reloc: section_name; sec_name_uninit: section_name; sec_writable: bool; sec_executable: bool; @@ -47,8 +54,9 @@ type section_info = { } let default_section_info = { - sec_name_init = Section_data true; - sec_name_uninit = Section_data false; + sec_name_init = Section_data Init; + sec_name_init_reloc = Section_data Init_reloc; + sec_name_uninit = Section_data Uninit; sec_writable = true; sec_executable = false; sec_access = Access_default @@ -59,41 +67,49 @@ let default_section_info = { let builtin_sections = [ "CODE", {sec_name_init = Section_text; + sec_name_init_reloc = Section_text; sec_name_uninit = Section_text; sec_writable = false; sec_executable = true; sec_access = Access_default}; "DATA", - {sec_name_init = Section_data true; - sec_name_uninit = Section_data false; + {sec_name_init = Section_data Init; + sec_name_init_reloc = Section_data Init_reloc; + sec_name_uninit = Section_data Uninit; sec_writable = true; sec_executable = false; sec_access = Access_default}; "SDATA", - {sec_name_init = Section_small_data true; - sec_name_uninit = Section_small_data false; + {sec_name_init = Section_small_data Init; + sec_name_init_reloc = Section_small_data Init_reloc; + sec_name_uninit = Section_small_data Uninit; sec_writable = true; sec_executable = false; sec_access = Access_near}; "CONST", - {sec_name_init = Section_const true; - sec_name_uninit = Section_const false; + {sec_name_init = Section_const Init; + sec_name_init_reloc = Section_const Init_reloc; + sec_name_uninit = Section_const Uninit; sec_writable = false; sec_executable = false; sec_access = Access_default}; "SCONST", - {sec_name_init = Section_small_const true; - sec_name_uninit = Section_small_const false; + {sec_name_init = Section_small_const Init; + sec_name_init_reloc = Section_small_const Init_reloc; + sec_name_uninit = Section_small_const Uninit; sec_writable = false; sec_executable = false; sec_access = Access_near}; "STRING", {sec_name_init = Section_string; + sec_name_init_reloc = Section_string; sec_name_uninit = Section_string; sec_writable = false; sec_executable = false; sec_access = Access_default}; "LITERAL", {sec_name_init = Section_literal; + sec_name_init_reloc = Section_literal; sec_name_uninit = Section_literal; sec_writable = false; sec_executable = false; sec_access = Access_default}; "JUMPTABLE", {sec_name_init = Section_jumptable; + sec_name_init_reloc = Section_jumptable; sec_name_uninit = Section_jumptable; sec_writable = false; sec_executable = false; sec_access = Access_default} @@ -128,15 +144,19 @@ let define_section name ?iname ?uname ?writable ?executable ?access () = match executable with Some b -> b | None -> si.sec_executable and access = match access with Some b -> b | None -> si.sec_access in - let iname = + let i = match iname with Some s -> Section_user(s, writable, executable) | None -> si.sec_name_init in - let uname = + let ir = + match iname with Some s -> Section_user(s, writable, executable) + | None -> si.sec_name_init_reloc in + let u = match uname with Some s -> Section_user(s, writable, executable) | None -> si.sec_name_uninit in let new_si = - { sec_name_init = iname; - sec_name_uninit = uname; + { sec_name_init = i; + sec_name_init_reloc = ir; + sec_name_uninit = u; sec_writable = writable; sec_executable = executable; sec_access = access } in @@ -156,7 +176,7 @@ let use_section_for id name = let gcc_section name readonly exec = let sn = Section_user(name, not readonly, exec) in - { sec_name_init = sn; sec_name_uninit = sn; + { sec_name_init = sn; sec_name_init_reloc = sn; sec_name_uninit = sn; sec_writable = not readonly; sec_executable = exec; sec_access = Access_default } @@ -199,7 +219,12 @@ let for_variable env loc id ty init = Hashtbl.find current_section_table name with Not_found -> assert false in - ((if init then si.sec_name_init else si.sec_name_uninit), si.sec_access) + let secname = + match init with + | Uninit -> si.sec_name_uninit + | Init -> si.sec_name_init + | Init_reloc -> si.sec_name_init_reloc in + (secname, si.sec_access) (* Determine sections for a function definition *) diff --git a/common/Sections.mli b/common/Sections.mli index d9fd9239..8ec98e40 100644 --- a/common/Sections.mli +++ b/common/Sections.mli @@ -6,22 +6,28 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) (* Handling of linker sections *) +type initialized = + | Uninit (* uninitialized data area *) + | Init (* initialized with fixed, non-relocatable data *) + | Init_reloc (* initialized with relocatable data (symbol addresses) *) + type section_name = | Section_text - | Section_data of bool (* true = init data, false = uninit data *) - | Section_small_data of bool - | Section_const of bool - | Section_small_const of bool + | Section_data of initialized + | Section_small_data of initialized + | Section_const of initialized + | Section_small_const of initialized | Section_string | Section_literal | Section_jumptable @@ -46,7 +52,7 @@ val define_section: -> ?writable:bool -> ?executable:bool -> ?access:access_mode -> unit -> unit val use_section_for: AST.ident -> string -> bool -val for_variable: Env.t -> C.location -> AST.ident -> C.typ -> bool -> +val for_variable: Env.t -> C.location -> AST.ident -> C.typ -> initialized -> section_name * access_mode val for_function: Env.t -> C.location -> AST.ident -> C.attributes -> section_name list val for_stringlit: unit -> section_name diff --git a/common/Separation.v b/common/Separation.v index 27065d1f..f41d94c3 100644 --- a/common/Separation.v +++ b/common/Separation.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -113,7 +114,7 @@ Proof. intros P Q [[A B] [C D]]. split; auto. Qed. -Hint Resolve massert_imp_refl massert_eqv_refl : core. +Global Hint Resolve massert_imp_refl massert_eqv_refl : core. (** * Separating conjunction *) @@ -355,12 +356,12 @@ Proof. intros. rewrite <- sep_assoc. eapply sep_imp; eauto. split; simpl; intros. - intuition auto. -+ omega. -+ apply H5; omega. -+ omega. -+ apply H5; omega. -+ red; simpl; intros; omega. -- intuition omega. ++ lia. ++ apply H5; lia. ++ lia. ++ apply H5; lia. ++ red; simpl; intros; lia. +- intuition lia. Qed. Lemma range_drop_left: @@ -392,12 +393,12 @@ Proof. assert (mid <= align mid al) by (apply align_le; auto). split; simpl; intros. - intuition auto. -+ omega. -+ apply H7; omega. -+ omega. -+ apply H7; omega. -+ red; simpl; intros; omega. -- intuition omega. ++ lia. ++ apply H7; lia. ++ lia. ++ apply H7; lia. ++ red; simpl; intros; lia. +- intuition lia. Qed. Lemma range_preserved: @@ -493,7 +494,7 @@ Proof. split; [|split]. - assert (Mem.valid_access m chunk b ofs Freeable). { split; auto. red; auto. } - split. generalize (size_chunk_pos chunk). unfold Ptrofs.max_unsigned. omega. + split. generalize (size_chunk_pos chunk). unfold Ptrofs.max_unsigned. lia. split. auto. + destruct (Mem.valid_access_load m chunk b ofs) as [v LOAD]. eauto with mem. @@ -616,7 +617,7 @@ Next Obligation. assert (IMG: forall b1 b2 delta ofs k p, j b1 = Some (b2, delta) -> Mem.perm m0 b1 ofs k p -> img b2 (ofs + delta)). { intros. red. exists b1, delta; split; auto. - replace (ofs + delta - delta) with ofs by omega. + replace (ofs + delta - delta) with ofs by lia. eauto with mem. } destruct H. constructor. - destruct mi_inj. constructor; intros. @@ -668,7 +669,7 @@ Proof. intros; red; intros. eelim C; eauto. simpl. exists b1, delta; split; auto. destruct VALID as [V1 V2]. apply Mem.perm_cur_max. apply Mem.perm_implies with Writable; auto with mem. - apply V1. omega. + apply V1. lia. - red; simpl; intros. destruct H1 as (b0 & delta0 & U & V). eelim C; eauto. simpl. exists b0, delta0; eauto with mem. Qed. @@ -690,7 +691,7 @@ Lemma alloc_parallel_rule: /\ (forall b, b <> b1 -> j' b = j b). Proof. intros until delta; intros SEP ALLOC1 ALLOC2 ALIGN LO HI RANGE1 RANGE2 RANGE3. - assert (RANGE4: lo <= hi) by xomega. + assert (RANGE4: lo <= hi) by extlia. assert (FRESH1: ~Mem.valid_block m1 b1) by (eapply Mem.fresh_block_alloc; eauto). assert (FRESH2: ~Mem.valid_block m2 b2) by (eapply Mem.fresh_block_alloc; eauto). destruct SEP as (INJ & SP & DISJ). simpl in INJ. @@ -698,10 +699,10 @@ Proof. - eapply Mem.alloc_right_inject; eauto. - eexact ALLOC1. - instantiate (1 := b2). eauto with mem. -- instantiate (1 := delta). xomega. -- intros. assert (0 <= ofs < sz2) by (eapply Mem.perm_alloc_3; eauto). omega. +- instantiate (1 := delta). extlia. +- intros. assert (0 <= ofs < sz2) by (eapply Mem.perm_alloc_3; eauto). lia. - intros. apply Mem.perm_implies with Freeable; auto with mem. - eapply Mem.perm_alloc_2; eauto. xomega. + eapply Mem.perm_alloc_2; eauto. extlia. - red; intros. apply Z.divide_trans with 8; auto. exists (8 / align_chunk chunk). destruct chunk; reflexivity. - intros. elim FRESH2. eapply Mem.valid_block_inject_2; eauto. @@ -709,19 +710,19 @@ Proof. exists j'; split; auto. rewrite <- ! sep_assoc. split; [|split]. -+ simpl. intuition auto; try (unfold Ptrofs.max_unsigned in *; omega). ++ simpl. intuition auto; try (unfold Ptrofs.max_unsigned in *; lia). * apply Mem.perm_implies with Freeable; auto with mem. - eapply Mem.perm_alloc_2; eauto. omega. + eapply Mem.perm_alloc_2; eauto. lia. * apply Mem.perm_implies with Freeable; auto with mem. - eapply Mem.perm_alloc_2; eauto. omega. -* red; simpl; intros. destruct H1, H2. omega. + eapply Mem.perm_alloc_2; eauto. lia. +* red; simpl; intros. destruct H1, H2. lia. * red; simpl; intros. assert (b = b2) by tauto. subst b. assert (0 <= ofs < lo \/ hi <= ofs < sz2) by tauto. clear H1. destruct H2 as (b0 & delta0 & D & E). eapply Mem.perm_alloc_inv in E; eauto. destruct (eq_block b0 b1). - subst b0. rewrite J2 in D. inversion D; clear D; subst delta0. xomega. + subst b0. rewrite J2 in D. inversion D; clear D; subst delta0. extlia. rewrite J3 in D by auto. elim FRESH2. eapply Mem.valid_block_inject_2; eauto. + apply (m_invar P) with m2; auto. eapply Mem.alloc_unchanged_on; eauto. + red; simpl; intros. @@ -753,11 +754,11 @@ Proof. simpl in E. assert (PERM: Mem.range_perm m2 b2 0 sz2 Cur Freeable). { red; intros. - destruct (zlt ofs lo). apply J; omega. - destruct (zle hi ofs). apply K; omega. - replace ofs with ((ofs - delta) + delta) by omega. + destruct (zlt ofs lo). apply J; lia. + destruct (zle hi ofs). apply K; lia. + replace ofs with ((ofs - delta) + delta) by lia. eapply Mem.perm_inject; eauto. - eapply Mem.free_range_perm; eauto. xomega. + eapply Mem.free_range_perm; eauto. extlia. } destruct (Mem.range_perm_free _ _ _ _ PERM) as [m2' FREE]. exists m2'; split; auto. split; [|split]. @@ -768,16 +769,16 @@ Proof. destruct (zle hi (ofs + delta0)). intuition auto. destruct (eq_block b0 b1). * subst b0. rewrite H1 in H; inversion H; clear H; subst delta0. - eelim (Mem.perm_free_2 m1); eauto. xomega. + eelim (Mem.perm_free_2 m1); eauto. extlia. * exploit Mem.mi_no_overlap; eauto. apply Mem.perm_max with k. apply Mem.perm_implies with p; auto with mem. eapply Mem.perm_free_3; eauto. apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable; auto with mem. eapply (Mem.free_range_perm m1); eauto. - instantiate (1 := ofs + delta0 - delta). xomega. - intros [X|X]. congruence. omega. + instantiate (1 := ofs + delta0 - delta). extlia. + intros [X|X]. congruence. lia. + simpl. exists b0, delta0; split; auto. - replace (ofs + delta0 - delta0) with ofs by omega. + replace (ofs + delta0 - delta0) with ofs by lia. apply Mem.perm_max with k. apply Mem.perm_implies with p; auto with mem. eapply Mem.perm_free_3; eauto. - apply (m_invar P) with m2; auto. @@ -787,7 +788,7 @@ Proof. destruct (zle hi i). intuition auto. right; exists b1, delta; split; auto. apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable; auto with mem. - eapply Mem.free_range_perm; eauto. xomega. + eapply Mem.free_range_perm; eauto. extlia. - red; simpl; intros. eelim C; eauto. simpl. right. destruct H as (b0 & delta0 & U & V). exists b0, delta0; split; auto. @@ -870,7 +871,7 @@ Proof. exists j', vres2, m2'; intuition auto. split; [|split]. - exact INJ'. -- apply m_invar with (m0 := m2). +- apply (m_invar _ m2). + apply globalenv_inject_incr with j m1; auto. + eapply Mem.unchanged_on_implies; eauto. intros; red; intros; red; intros. diff --git a/common/Smallstep.v b/common/Smallstep.v index 27ad0a2d..f337ba3c 100644 --- a/common/Smallstep.v +++ b/common/Smallstep.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -893,8 +894,8 @@ Proof. exploit (sd_traces DET). eexact H3. intros L2. assert (t1 = t0 /\ t2 = t3). destruct t1. inv MT. auto. - destruct t1; simpl in L1; try omegaContradiction. - destruct t0. inv MT. destruct t0; simpl in L2; try omegaContradiction. + destruct t1; simpl in L1; try extlia. + destruct t0. inv MT. destruct t0; simpl in L2; try extlia. simpl in H5. split. congruence. congruence. destruct H1; subst. assert (s2 = s4) by (eapply sd_determ_2; eauto). subst s4. @@ -974,7 +975,7 @@ Proof. destruct C as [P | [P Q]]; auto using lex_ord_left. + exploit sd_determ_3. eauto. eexact A. eauto. intros [P Q]; subst t s1'0. exists (i, n), s2; split; auto. - right; split. apply star_refl. apply lex_ord_right. omega. + right; split. apply star_refl. apply lex_ord_right. lia. - exact public_preserved. Qed. @@ -1256,7 +1257,7 @@ Proof. subst t. assert (EITHER: t1 = E0 \/ t2 = E0). unfold Eapp in H2; rewrite app_length in H2. - destruct t1; auto. destruct t2; auto. simpl in H2; omegaContradiction. + destruct t1; auto. destruct t2; auto. simpl in H2; extlia. destruct EITHER; subst. exploit IHstar; eauto. intros [s2x [s2y [A [B C]]]]. exists s2x; exists s2y; intuition. eapply star_left; eauto. @@ -1305,7 +1306,7 @@ Proof. - (* 1 L2 makes one or several transitions *) assert (EITHER: t = E0 \/ (length t = 1)%nat). { exploit L3_single_events; eauto. - destruct t; auto. destruct t; auto. simpl. intros. omegaContradiction. } + destruct t; auto. destruct t; auto. simpl. intros. extlia. } destruct EITHER. + (* 1.1 these are silent transitions *) subst t. exploit (bsim_E0_plus S12); eauto. @@ -1473,7 +1474,7 @@ Remark not_silent_length: forall t1 t2, (length (t1 ** t2) <= 1)%nat -> t1 = E0 \/ t2 = E0. Proof. unfold Eapp, E0; intros. rewrite app_length in H. - destruct t1; destruct t2; auto. simpl in H. omegaContradiction. + destruct t1; destruct t2; auto. simpl in H. extlia. Qed. Lemma f2b_determinacy_inv: @@ -1622,7 +1623,7 @@ Proof. intros [[EQ1 [EQ2 EQ3]] | [NOT1 [NOT2 MT]]]. + (* 2.1 L2 makes a silent transition: remain in "before" state *) subst. simpl in *. exists (F2BI_before n0); exists s1; split. - right; split. apply star_refl. constructor. omega. + right; split. apply star_refl. constructor. lia. econstructor; eauto. eapply star_right; eauto. + (* 2.2 L2 make a non-silent transition *) exploit not_silent_length. eapply (sr_traces L1_receptive); eauto. intros [EQ | EQ]. @@ -1650,7 +1651,7 @@ Proof. exploit f2b_determinacy_inv. eexact H2. eexact STEP2. intros [[EQ1 [EQ2 EQ3]] | [NOT1 [NOT2 MT]]]. subst. exists (F2BI_after n); exists s1; split. - right; split. apply star_refl. constructor; omega. + right; split. apply star_refl. constructor; lia. eapply f2b_match_after'; eauto. congruence. Qed. @@ -1763,7 +1764,7 @@ Proof. destruct IHstar as [s2x [A B]]. exists s2x; split; auto. eapply plus_left. eauto. apply plus_star; eauto. auto. destruct t1. simpl in *. subst t. exists s2; split; auto. apply plus_one; auto. - simpl in LEN. omegaContradiction. + simpl in LEN. extlia. Qed. Lemma ffs_simulation: @@ -1955,7 +1956,7 @@ Proof. assert (t2 = ev :: nil). inv H1; simpl in H0; tauto. subst t2. exists (t, s0). constructor; auto. simpl; auto. (* single-event *) - red. intros. inv H0; simpl; omega. + red. intros. inv H0; simpl; lia. Qed. (** * Connections with big-step semantics *) diff --git a/common/Subtyping.v b/common/Subtyping.v index 26b282e0..8e5d9361 100644 --- a/common/Subtyping.v +++ b/common/Subtyping.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -222,7 +223,7 @@ Definition weight_bounds (ob: option bounds) : nat := Lemma weight_bounds_1: forall lo hi s, weight_bounds (Some (B lo hi s)) < weight_bounds None. Proof. - intros; simpl. generalize (T.weight_range hi); omega. + intros; simpl. generalize (T.weight_range hi); lia. Qed. Lemma weight_bounds_2: @@ -233,8 +234,8 @@ Proof. intros; simpl. generalize (T.weight_sub _ _ s1) (T.weight_sub _ _ s2) (T.weight_sub _ _ H) (T.weight_sub _ _ H0); intros. destruct H1. - assert (T.weight lo2 < T.weight lo1) by (apply T.weight_sub_strict; auto). omega. - assert (T.weight hi1 < T.weight hi2) by (apply T.weight_sub_strict; auto). omega. + assert (T.weight lo2 < T.weight lo1) by (apply T.weight_sub_strict; auto). lia. + assert (T.weight hi1 < T.weight hi2) by (apply T.weight_sub_strict; auto). lia. Qed. Hint Resolve T.sub_refl: ty. @@ -250,11 +251,11 @@ Lemma weight_type_move: Proof. unfold type_move; intros. destruct (peq r1 r2). - inv H. split; auto. split; intros. omega. discriminate. + inv H. split; auto. split; intros. lia. discriminate. destruct (te_typ e)!r1 as [[lo1 hi1 s1]|] eqn:E1; destruct (te_typ e)!r2 as [[lo2 hi2 s2]|] eqn:E2. - destruct (T.sub_dec hi1 lo2). - inv H. split; auto. split; intros. omega. discriminate. + inv H. split; auto. split; intros. lia. discriminate. destruct (T.sub_dec lo1 hi2); try discriminate. set (lo2' := T.lub lo1 lo2) in *. set (hi1' := T.glb hi1 hi2) in *. @@ -264,45 +265,45 @@ Proof. set (b2 := B lo2' hi2 (T.lub_min lo1 lo2 hi2 s s2)) in *. Local Opaque weight_bounds. destruct (T.eq lo2 lo2'); destruct (T.eq hi1 hi1'); inversion H; clear H; subst changed e'; simpl. -+ split; auto. split; intros. omega. discriminate. ++ split; auto. split; intros. lia. discriminate. + assert (weight_bounds (Some b1) < weight_bounds (Some (B lo1 hi1 s1))) by (apply weight_bounds_2; auto with ty). split; auto. split; intros. - rewrite PTree.gsspec. destruct (peq r r1). subst r. rewrite E1. omega. omega. - rewrite PTree.gss. rewrite PTree.gso by auto. rewrite E2. omega. + rewrite PTree.gsspec. destruct (peq r r1). subst r. rewrite E1. lia. lia. + rewrite PTree.gss. rewrite PTree.gso by auto. rewrite E2. lia. + assert (weight_bounds (Some b2) < weight_bounds (Some (B lo2 hi2 s2))) by (apply weight_bounds_2; auto with ty). split; auto. split; intros. - rewrite PTree.gsspec. destruct (peq r r2). subst r. rewrite E2. omega. omega. - rewrite PTree.gss. rewrite PTree.gso by auto. rewrite E1. omega. + rewrite PTree.gsspec. destruct (peq r r2). subst r. rewrite E2. lia. lia. + rewrite PTree.gss. rewrite PTree.gso by auto. rewrite E1. lia. + assert (weight_bounds (Some b1) < weight_bounds (Some (B lo1 hi1 s1))) by (apply weight_bounds_2; auto with ty). assert (weight_bounds (Some b2) < weight_bounds (Some (B lo2 hi2 s2))) by (apply weight_bounds_2; auto with ty). split; auto. split; intros. rewrite ! PTree.gsspec. - destruct (peq r r2). subst r. rewrite E2. omega. - destruct (peq r r1). subst r. rewrite E1. omega. - omega. - rewrite PTree.gss. rewrite PTree.gso by auto. rewrite PTree.gss. omega. + destruct (peq r r2). subst r. rewrite E2. lia. + destruct (peq r r1). subst r. rewrite E1. lia. + lia. + rewrite PTree.gss. rewrite PTree.gso by auto. rewrite PTree.gss. lia. - set (b2 := B lo1 (T.high_bound lo1) (T.high_bound_sub lo1)) in *. assert (weight_bounds (Some b2) < weight_bounds None) by (apply weight_bounds_1). inv H; simpl. split. destruct (T.sub_dec hi1 lo1); auto. split; intros. - rewrite PTree.gsspec. destruct (peq r r2). subst r; rewrite E2; omega. omega. - rewrite PTree.gss. rewrite PTree.gso by auto. rewrite E1. omega. + rewrite PTree.gsspec. destruct (peq r r2). subst r; rewrite E2; lia. lia. + rewrite PTree.gss. rewrite PTree.gso by auto. rewrite E1. lia. - set (b1 := B (T.low_bound hi2) hi2 (T.low_bound_sub hi2)) in *. assert (weight_bounds (Some b1) < weight_bounds None) by (apply weight_bounds_1). inv H; simpl. split. destruct (T.sub_dec hi2 lo2); auto. split; intros. - rewrite PTree.gsspec. destruct (peq r r1). subst r; rewrite E1; omega. omega. - rewrite PTree.gss. rewrite PTree.gso by auto. rewrite E2. omega. + rewrite PTree.gsspec. destruct (peq r r1). subst r; rewrite E1; lia. lia. + rewrite PTree.gss. rewrite PTree.gso by auto. rewrite E2. lia. -- inv H. split; auto. simpl; split; intros. omega. congruence. +- inv H. split; auto. simpl; split; intros. lia. congruence. Qed. Definition weight_constraints (b: PTree.t bounds) (cstr: list constraint) : nat := @@ -312,7 +313,7 @@ Remark weight_constraints_tighter: forall b1 b2, (forall r, weight_bounds b1!r <= weight_bounds b2!r) -> forall q, weight_constraints b1 q <= weight_constraints b2 q. Proof. - induction q; simpl. omega. generalize (H (fst a)) (H (snd a)); omega. + induction q; simpl. lia. generalize (H (fst a)) (H (snd a)); lia. Qed. Lemma weight_solve_rec: @@ -323,8 +324,8 @@ Lemma weight_solve_rec: <= weight_constraints e.(te_typ) e.(te_sub) + weight_constraints e.(te_typ) q. Proof. induction q; simpl; intros. -- inv H. split. intros; omega. replace (changed' && negb changed') with false. - omega. destruct changed'; auto. +- inv H. split. intros; lia. replace (changed' && negb changed') with false. + lia. destruct changed'; auto. - destruct a as [r1 r2]; monadInv H; simpl. rename x into changed1. rename x0 into e1. exploit weight_type_move; eauto. intros [A [B C]]. @@ -336,7 +337,7 @@ Proof. assert (Q: weight_constraints (te_typ e1) (te_sub e1) <= weight_constraints (te_typ e1) (te_sub e) + weight_bounds (te_typ e1)!r1 + weight_bounds (te_typ e1)!r2). - { destruct A as [Q|Q]; rewrite Q. omega. simpl. omega. } + { destruct A as [Q|Q]; rewrite Q. lia. simpl. lia. } assert (R: weight_constraints (te_typ e1) q <= weight_constraints (te_typ e) q) by (apply weight_constraints_tighter; auto). set (ch1 := if changed' && negb (changed || changed1) then 1 else 0) in *. @@ -344,11 +345,11 @@ Proof. destruct changed1. assert (ch2 <= ch1 + 1). { unfold ch2, ch1. rewrite orb_true_r. simpl. rewrite andb_false_r. - destruct (changed' && negb changed); omega. } - exploit C; eauto. omega. + destruct (changed' && negb changed); lia. } + exploit C; eauto. lia. assert (ch2 <= ch1). - { unfold ch2, ch1. rewrite orb_false_r. omega. } - generalize (B r1) (B r2); omega. + { unfold ch2, ch1. rewrite orb_false_r. lia. } + generalize (B r1) (B r2); lia. Qed. Definition weight_typenv (e: typenv) : nat := @@ -364,7 +365,7 @@ Function solve_constraints (e: typenv) {measure weight_typenv e}: res typenv := end. Proof. intros. exploit weight_solve_rec; eauto. simpl. intros [A B]. - unfold weight_typenv. omega. + unfold weight_typenv. lia. Qed. Definition typassign := positive -> T.t. diff --git a/common/Switch.v b/common/Switch.v index 5a6d4c63..b9aeed96 100644 --- a/common/Switch.v +++ b/common/Switch.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -235,8 +236,8 @@ Proof. destruct (split_lt n cases) as [lc rc] eqn:SEQ. rewrite (IHcases lc rc) by auto. destruct (zlt key n); intros EQ; inv EQ; simpl. -+ destruct (zeq v key). rewrite zlt_true by omega. auto. auto. -+ destruct (zeq v key). rewrite zlt_false by omega. auto. auto. ++ destruct (zeq v key). rewrite zlt_true by lia. auto. auto. ++ destruct (zeq v key). rewrite zlt_false by lia. auto. auto. Qed. Lemma split_between_prop: @@ -269,12 +270,12 @@ Lemma validate_jumptable_correct_rec: list_nth_z tbl v = Some(ZMap.get (base + v) cases). Proof. induction tbl; simpl; intros. -- unfold list_length_z in H0. simpl in H0. omegaContradiction. +- unfold list_length_z in H0. simpl in H0. extlia. - InvBooleans. rewrite list_length_z_cons in H0. apply beq_nat_true in H1. destruct (zeq v 0). - + replace (base + v) with base by omega. congruence. - + replace (base + v) with (Z.succ base + Z.pred v) by omega. - apply IHtbl. auto. omega. + + replace (base + v) with base by lia. congruence. + + replace (base + v) with (Z.succ base + Z.pred v) by lia. + apply IHtbl. auto. lia. Qed. Lemma validate_jumptable_correct: @@ -288,12 +289,12 @@ Lemma validate_jumptable_correct: Proof. intros. rewrite (validate_jumptable_correct_rec cases tbl ofs); auto. -- f_equal. f_equal. rewrite Z.mod_small. omega. - destruct (zle ofs v). omega. +- f_equal. f_equal. rewrite Z.mod_small. lia. + destruct (zle ofs v). lia. assert (M: ((v - ofs) + 1 * modulus) mod modulus = (v - ofs) + modulus). - { rewrite Z.mod_small. omega. omega. } - rewrite Z_mod_plus in M by auto. rewrite M in H0. omega. -- generalize (Z_mod_lt (v - ofs) modulus modulus_pos). omega. + { rewrite Z.mod_small. lia. lia. } + rewrite Z_mod_plus in M by auto. rewrite M in H0. lia. +- generalize (Z_mod_lt (v - ofs) modulus modulus_pos). lia. Qed. Lemma validate_correct_rec: @@ -309,7 +310,7 @@ Proof. destruct cases as [ | [key1 act1] cases1]; intros. + apply beq_nat_true in H. subst act. reflexivity. + InvBooleans. apply beq_nat_true in H2. subst. simpl. - destruct (zeq v hi). auto. omegaContradiction. + destruct (zeq v hi). auto. extlia. - (* eq node *) destruct (split_eq key cases) as [optact others] eqn:EQ. intros. destruct optact as [act1|]; InvBooleans; try discriminate. @@ -319,19 +320,19 @@ Proof. + congruence. + eapply IHt; eauto. unfold refine_low_bound, refine_high_bound. split. - destruct (zeq key lo); omega. - destruct (zeq key hi); omega. + destruct (zeq key lo); lia. + destruct (zeq key hi); lia. - (* lt node *) destruct (split_lt key cases) as [lcases rcases] eqn:EQ; intros; InvBooleans. rewrite (split_lt_prop v default _ _ _ _ EQ). destruct (zlt v key). - eapply IHt1. eauto. omega. - eapply IHt2. eauto. omega. + eapply IHt1. eauto. lia. + eapply IHt2. eauto. lia. - (* jumptable node *) destruct (split_between default ofs sz cases) as [ins outs] eqn:EQ; intros; InvBooleans. rewrite (split_between_prop v _ _ _ _ _ _ EQ). - assert (0 <= (v - ofs) mod modulus < modulus) by (apply Z_mod_lt; omega). + assert (0 <= (v - ofs) mod modulus < modulus) by (apply Z_mod_lt; lia). destruct (zlt ((v - ofs) mod modulus) sz). - rewrite Z.mod_small by omega. eapply validate_jumptable_correct; eauto. + rewrite Z.mod_small by lia. eapply validate_jumptable_correct; eauto. eapply IHt; eauto. Qed. @@ -346,7 +347,7 @@ Theorem validate_switch_correct: Proof. unfold validate_switch, table_tree_agree; split. eapply validate_wf; eauto. - intros; eapply validate_correct_rec; eauto. omega. + intros; eapply validate_correct_rec; eauto. lia. Qed. End COMPTREE. diff --git a/common/Switchaux.ml b/common/Switchaux.ml index 4035e299..47ded8ee 100644 --- a/common/Switchaux.ml +++ b/common/Switchaux.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/common/Unityping.v b/common/Unityping.v index 28bcfb5c..1089b359 100644 --- a/common/Unityping.v +++ b/common/Unityping.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -126,12 +127,12 @@ Lemma length_move: length e'.(te_equ) + (if changed then 1 else 0) <= S(length e.(te_equ)). Proof. unfold move; intros. - destruct (peq r1 r2). inv H. omega. + destruct (peq r1 r2). inv H. lia. destruct e.(te_typ)!r1 as [ty1|]; destruct e.(te_typ)!r2 as [ty2|]; inv H; simpl. - destruct (T.eq ty1 ty2); inv H1. omega. - omega. - omega. - omega. + destruct (T.eq ty1 ty2); inv H1. lia. + lia. + lia. + lia. Qed. Lemma length_solve_rec: @@ -140,14 +141,14 @@ Lemma length_solve_rec: length e'.(te_equ) + (if ch' && negb ch then 1 else 0) <= length e.(te_equ) + length q. Proof. induction q; simpl; intros. -- inv H. replace (ch' && negb ch') with false. omega. destruct ch'; auto. +- inv H. replace (ch' && negb ch') with false. lia. destruct ch'; auto. - destruct a as [r1 r2]; monadInv H. rename x0 into e0. rename x into ch0. exploit IHq; eauto. intros A. exploit length_move; eauto. intros B. set (X := (if ch' && negb (ch || ch0) then 1 else 0)) in *. set (Y := (if ch0 then 1 else 0)) in *. set (Z := (if ch' && negb ch then 1 else 0)) in *. - cut (Z <= X + Y). intros. omega. + cut (Z <= X + Y). intros. lia. unfold X, Y, Z. destruct ch'; destruct ch; destruct ch0; simpl; auto. Qed. @@ -164,7 +165,7 @@ Function solve_constraints (e: typenv) {measure weight_typenv e}: res typenv := end. Proof. intros. exploit length_solve_rec; eauto. simpl. intros. - unfold weight_typenv. omega. + unfold weight_typenv. lia. Qed. Definition typassign := positive -> T.t. @@ -199,7 +200,7 @@ Proof. apply A. rewrite PTree.gso by congruence. auto. Qed. -Hint Resolve set_incr: ty. +Global Hint Resolve set_incr: ty. Lemma set_sound: forall te x ty e e', set e x ty = OK e' -> satisf te e' -> te x = ty. @@ -216,7 +217,7 @@ Proof. induction xl; destruct tyl; simpl; intros; monadInv H; eauto with ty. Qed. -Hint Resolve set_list_incr: ty. +Global Hint Resolve set_list_incr: ty. Lemma set_list_sound: forall te xl tyl e e', set_list e xl tyl = OK e' -> satisf te e' -> map te xl = tyl. @@ -242,7 +243,7 @@ Proof. - inv H; simpl in *; split; auto. Qed. -Hint Resolve move_incr: ty. +Global Hint Resolve move_incr: ty. Lemma move_sound: forall te e r1 r2 e' changed, diff --git a/common/Values.v b/common/Values.v index 68a2054b..891c9a88 100644 --- a/common/Values.v +++ b/common/Values.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -1024,10 +1025,10 @@ Lemma load_result_rettype: forall chunk v, has_rettype (load_result chunk v) (rettype_of_chunk chunk). Proof. intros. unfold has_rettype; destruct chunk; destruct v; simpl; auto. -- rewrite Int.sign_ext_idem by omega; auto. -- rewrite Int.zero_ext_idem by omega; auto. -- rewrite Int.sign_ext_idem by omega; auto. -- rewrite Int.zero_ext_idem by omega; auto. +- rewrite Int.sign_ext_idem by lia; auto. +- rewrite Int.zero_ext_idem by lia; auto. +- rewrite Int.sign_ext_idem by lia; auto. +- rewrite Int.zero_ext_idem by lia; auto. - destruct Archi.ptr64 eqn:SF; simpl; auto. - destruct Archi.ptr64 eqn:SF; simpl; auto. - destruct Archi.ptr64 eqn:SF; simpl; auto. @@ -1053,14 +1054,14 @@ Theorem cast8unsigned_and: forall x, zero_ext 8 x = and x (Vint(Int.repr 255)). Proof. destruct x; simpl; auto. decEq. - change 255 with (two_p 8 - 1). apply Int.zero_ext_and. omega. + change 255 with (two_p 8 - 1). apply Int.zero_ext_and. lia. Qed. Theorem cast16unsigned_and: forall x, zero_ext 16 x = and x (Vint(Int.repr 65535)). Proof. destruct x; simpl; auto. decEq. - change 65535 with (two_p 16 - 1). apply Int.zero_ext_and. omega. + change 65535 with (two_p 16 - 1). apply Int.zero_ext_and. lia. Qed. Theorem bool_of_val_of_bool: @@ -1297,7 +1298,7 @@ Proof. unfold divs. rewrite Int.eq_false; try discriminate. simpl. rewrite (Int.eq_false Int.one Int.mone); try discriminate. rewrite andb_false_intro2; auto. f_equal. f_equal. - rewrite Int.divs_one; auto. replace Int.zwordsize with 32; auto. omega. + rewrite Int.divs_one; auto. replace Int.zwordsize with 32; auto. lia. Qed. Theorem divu_pow2: @@ -1424,7 +1425,7 @@ Proof. destruct (Int.ltu i0 (Int.repr 31)) eqn:?; inv H1. exploit Int.ltu_inv; eauto. change (Int.unsigned (Int.repr 31)) with 31. intros. assert (Int.ltu i0 Int.iwordsize = true). - unfold Int.ltu. apply zlt_true. change (Int.unsigned Int.iwordsize) with 32. omega. + unfold Int.ltu. apply zlt_true. change (Int.unsigned Int.iwordsize) with 32. lia. simpl. rewrite H0. simpl. decEq. rewrite Int.shrx_carry; auto. Qed. @@ -1439,7 +1440,7 @@ Proof. destruct (Int.ltu i0 (Int.repr 31)) eqn:?; inv H1. exploit Int.ltu_inv; eauto. change (Int.unsigned (Int.repr 31)) with 31. intros. assert (Int.ltu i0 Int.iwordsize = true). - unfold Int.ltu. apply zlt_true. change (Int.unsigned Int.iwordsize) with 32. omega. + unfold Int.ltu. apply zlt_true. change (Int.unsigned Int.iwordsize) with 32. lia. exists i; exists i0; intuition. rewrite Int.shrx_shr; auto. destruct (Int.lt i Int.zero); simpl; rewrite H0; auto. Qed. @@ -1462,12 +1463,12 @@ Proof. replace (Int.ltu (Int.sub (Int.repr 32) n) Int.iwordsize) with true. simpl. replace (Int.ltu n Int.iwordsize) with true. f_equal; apply Int.shrx_shr_2; assumption. - symmetry; apply zlt_true. change (Int.unsigned n < 32); omega. + symmetry; apply zlt_true. change (Int.unsigned n < 32); lia. symmetry; apply zlt_true. unfold Int.sub. change (Int.unsigned (Int.repr 32)) with 32. assert (Int.unsigned n <> 0). { red; intros; elim H. rewrite <- (Int.repr_unsigned n), H0. auto. } rewrite Int.unsigned_repr. - change (Int.unsigned Int.iwordsize) with 32; omega. - assert (32 < Int.max_unsigned) by reflexivity. omega. + change (Int.unsigned Int.iwordsize) with 32; lia. + assert (32 < Int.max_unsigned) by reflexivity. lia. Qed. Theorem or_rolm: @@ -1657,7 +1658,7 @@ Proof. rewrite (Int64.eq_false Int64.one Int64.mone); try discriminate. rewrite andb_false_intro2; auto. simpl. f_equal. f_equal. apply Int64.divs_one. - replace Int64.zwordsize with 64; auto. omega. + replace Int64.zwordsize with 64; auto. lia. Qed. Theorem divlu_pow2: @@ -1700,7 +1701,7 @@ Proof. destruct (Int.ltu i0 (Int.repr 63)) eqn:?; inv H1. exploit Int.ltu_inv; eauto. change (Int.unsigned (Int.repr 63)) with 63. intros. assert (Int.ltu i0 Int64.iwordsize' = true). - unfold Int.ltu. apply zlt_true. change (Int.unsigned Int64.iwordsize') with 64. omega. + unfold Int.ltu. apply zlt_true. change (Int.unsigned Int64.iwordsize') with 64. lia. simpl. rewrite H0. simpl. decEq. rewrite Int64.shrx'_carry; auto. Qed. @@ -1721,12 +1722,12 @@ Proof. replace (Int.ltu (Int.sub (Int.repr 64) n) Int64.iwordsize') with true. simpl. replace (Int.ltu n Int64.iwordsize') with true. f_equal; apply Int64.shrx'_shr_2; assumption. - symmetry; apply zlt_true. change (Int.unsigned n < 64); omega. + symmetry; apply zlt_true. change (Int.unsigned n < 64); lia. symmetry; apply zlt_true. unfold Int.sub. change (Int.unsigned (Int.repr 64)) with 64. assert (Int.unsigned n <> 0). { red; intros; elim H. rewrite <- (Int.repr_unsigned n), H0. auto. } rewrite Int.unsigned_repr. - change (Int.unsigned Int64.iwordsize') with 64; omega. - assert (64 < Int.max_unsigned) by reflexivity. omega. + change (Int.unsigned Int64.iwordsize') with 64; lia. + assert (64 < Int.max_unsigned) by reflexivity. lia. Qed. Theorem negate_cmp_bool: @@ -2000,7 +2001,7 @@ Inductive lessdef_list: list val -> list val -> Prop := lessdef v1 v2 -> lessdef_list vl1 vl2 -> lessdef_list (v1 :: vl1) (v2 :: vl2). -Hint Resolve lessdef_refl lessdef_undef lessdef_list_nil lessdef_list_cons : core. +Global Hint Resolve lessdef_refl lessdef_undef lessdef_list_nil lessdef_list_cons : core. Lemma lessdef_list_inv: forall vl1 vl2, lessdef_list vl1 vl2 -> vl1 = vl2 \/ In Vundef vl1. @@ -2225,7 +2226,7 @@ Inductive inject (mi: meminj): val -> val -> Prop := | val_inject_undef: forall v, inject mi Vundef v. -Hint Constructors inject : core. +Global Hint Constructors inject : core. Inductive inject_list (mi: meminj): list val -> list val-> Prop:= | inject_list_nil : @@ -2234,7 +2235,7 @@ Inductive inject_list (mi: meminj): list val -> list val-> Prop:= inject mi v v' -> inject_list mi vl vl'-> inject_list mi (v :: vl) (v' :: vl'). -Hint Resolve inject_list_nil inject_list_cons : core. +Global Hint Resolve inject_list_nil inject_list_cons : core. Lemma inject_ptrofs: forall mi i, inject mi (Vptrofs i) (Vptrofs i). @@ -2242,7 +2243,7 @@ Proof. unfold Vptrofs; intros. destruct Archi.ptr64; auto. Qed. -Hint Resolve inject_ptrofs : core. +Global Hint Resolve inject_ptrofs : core. Section VAL_INJ_OPS. @@ -2545,7 +2546,7 @@ Proof. constructor. eapply val_inject_incr; eauto. auto. Qed. -Hint Resolve inject_incr_refl val_inject_incr val_inject_list_incr : core. +Global Hint Resolve inject_incr_refl val_inject_incr val_inject_list_incr : core. Lemma val_inject_lessdef: forall v1 v2, Val.lessdef v1 v2 <-> Val.inject (fun b => Some(b, 0)) v1 v2. @@ -8,16 +8,18 @@ # # # Copyright Institut National de Recherche en Informatique et en # # Automatique. All rights reserved. This file is distributed # -# under the terms of the GNU General Public License as published by # -# the Free Software Foundation, either version 2 of the License, or # -# (at your option) any later version. This file is also distributed # -# under the terms of the INRIA Non-Commercial License Agreement. # +# under the terms of the GNU Lesser General Public License as # +# published by the Free Software Foundation, either version 2.1 of # +# the License, or (at your option) any later version. # +# This file is also distributed under the terms of the # +# INRIA Non-Commercial License Agreement. # # # ####################################################################### prefix='/usr/local' bindir='$(PREFIX)/bin' libdir='$(PREFIX)/lib/compcert' +mandir='$(PREFIX)/share/man' coqdevdir='$(PREFIX)/lib/compcert/coq' toolprefix='' target='' @@ -25,7 +27,6 @@ has_runtime_lib=true has_standard_headers=true clightgen=false install_coqdev=false -responsefile="gnu" ignore_coq_version=false library_Flocq=local library_MenhirLib=local @@ -53,7 +54,7 @@ Supported targets: x86_32-cygwin (x86 32 bits, Cygwin environment under Windows) x86_64-linux (x86 64 bits, Linux) x86_64-bsd (x86 64 bits, BSD) - x86_64-macosx (x86 64 bits, MacOS X) + x86_64-macos (x86 64 bits, MacOS X) x86_64-cygwin (x86 64 bits, Cygwin environment under Windows) verilog-linux (x86 64 bits, Linux) verilog-bsd (x86 64 bits, BSD) @@ -61,6 +62,7 @@ Supported targets: rv32-linux (RISC-V 32 bits, Linux) rv64-linux (RISC-V 64 bits, Linux) aarch64-linux (AArch64, i.e. ARMv8 in 64-bit mode, Linux) + aarch64-macos (AArch64, i.e. Apple silicon, MacOS) manual (edit configuration file by hand) For x86 targets, the "x86_32-" prefix can also be written "ia32-" or "i386-". @@ -88,6 +90,7 @@ Options: -prefix <dir> Install in <dir>/bin and <dir>/lib/compcert -bindir <dir> Install binaries in <dir> -libdir <dir> Install libraries in <dir> + -mandir <dir> Install man pages in <dir> -coqdevdir <dir> Install Coq development (.vo files) in <dir> -toolprefix <pref> Prefix names of tools ("gcc", etc) with <pref> -use-external-Flocq Use an already-installed Flocq library @@ -117,6 +120,8 @@ while : ; do bindir="$2"; shift;; -libdir|--libdir) libdir="$2"; shift;; + -mandir|--mandir) + mandir="$2"; shift;; -coqdevdir|--coqdevdir) coqdevdir="$2"; install_coqdev=true; shift;; -toolprefix|--toolprefix) @@ -210,13 +215,24 @@ target=${target#[a-zA-Z0-9]*-} # Per-target configuration +# We start with reasonable defaults, +# then redefine the required parameters for each target, +# then check for missing parameters and derive values for them. + asm_supports_cfi="" -casm_options="" +cc="${toolprefix}gcc" +cc_options="" +casm="${toolprefix}gcc" +casm_options="-c" casmruntime="" -clinker_needs_no_pie=true +clinker="${toolprefix}gcc" clinker_options="" -cprepro_options="" - +clinker_needs_no_pie=true +cprepro="${toolprefix}gcc" +cprepro_options="-E" +archiver="${toolprefix}ar rcs" +libmath="-lm" +responsefile="gnu" # # ARM Target Configuration @@ -236,13 +252,7 @@ if test "$arch" = "arm"; then exit 2;; esac - casm="${toolprefix}gcc" - casm_options="-c" - cc="${toolprefix}gcc" - clinker="${toolprefix}gcc" - cprepro="${toolprefix}gcc" cprepro_options="-std=c99 -U__GNUC__ '-D__REDIRECT(name,proto,alias)=name proto' '-D__REDIRECT_NTH(name,proto,alias)=name proto' -E" - libmath="-lm" system="linux" fi @@ -280,19 +290,14 @@ if test "$arch" = "powerpc"; then clinker="${toolprefix}dcc" cprepro="${toolprefix}dcc" cprepro_options="-E -D__GNUC__" + archiver="${toolprefix}dar -q" libmath="-lm" system="diab" responsefile="diab" ;; *) - casm="${toolprefix}gcc" - casm_options="-c" casmruntime="${toolprefix}gcc -c -Wa,-mregnames" - cc="${toolprefix}gcc" - clinker="${toolprefix}gcc" - cprepro="${toolprefix}gcc" cprepro_options="-std=c99 -U__GNUC__ -E" - libmath="-lm" system="linux" ;; esac @@ -307,38 +312,26 @@ if test "$arch" = "x86" -a "$bitsize" = "32"; then case "$target" in bsd) abi="standard" - casm="${toolprefix}gcc" + cc_options="-m32" casm_options="-m32 -c" - cc="${toolprefix}gcc -m32" - clinker="${toolprefix}gcc" clinker_options="-m32" - cprepro="${toolprefix}gcc" cprepro_options="-std=c99 -m32 -U__GNUC__ -E" - libmath="-lm" system="bsd" ;; cygwin) abi="standard" - casm="${toolprefix}gcc" + cc_options="-m32" casm_options="-m32 -c" - cc="${toolprefix}gcc -m32" - clinker="${toolprefix}gcc" clinker_options="-m32" - cprepro="${toolprefix}gcc" cprepro_options="-std=c99 -m32 -U__GNUC__ '-D__attribute__(x)=' -E" - libmath="-lm" system="cygwin" ;; linux) abi="standard" - casm="${toolprefix}gcc" + cc_options="-m32" casm_options="-m32 -c" - cc="${toolprefix}gcc -m32" - clinker="${toolprefix}gcc" clinker_options="-m32" - cprepro="${toolprefix}gcc" cprepro_options="-std=c99 -m32 -U__GNUC__ -E" - libmath="-lm" system="linux" ;; *) @@ -356,53 +349,36 @@ if test "$arch" = "x86" -a "$bitsize" = "64"; then case "$target" in bsd) abi="standard" - casm="${toolprefix}gcc" + cc_options="-m64" casm_options="-m64 -c" - cc="${toolprefix}gcc -m64" - clinker="${toolprefix}gcc" clinker_options="-m64" - cprepro="${toolprefix}gcc" cprepro_options="-std=c99 -m64 -U__GNUC__ -E" - libmath="-lm" system="bsd" ;; linux) abi="standard" - casm="${toolprefix}gcc" + cc_options="-m64" casm_options="-m64 -c" - cc="${toolprefix}gcc -m64" - clinker="${toolprefix}gcc" clinker_options="-m64" - cprepro="${toolprefix}gcc" cprepro_options="-std=c99 -m64 -U__GNUC__ -E" - libmath="-lm" system="linux" ;; - macosx) - # kernel major versions count upwards from 4 for OSX 10.0 to 15 for OSX 10.11 - kernel_major=`uname -r | cut -d "." -f 1` - - abi="macosx" - casm="${toolprefix}gcc" + macos|macosx) + abi="macos" + cc_options="-arch x86_64" casm_options="-arch x86_64 -c" - cc="${toolprefix}gcc -arch x86_64" - clinker="${toolprefix}gcc" + clinker_options="-arch x86_64" clinker_needs_no_pie=false - cprepro="${toolprefix}gcc" - cprepro_options="-std=c99 -arch x86_64 -U__GNUC__ -U__clang__ -U__BLOCKS__ '-D__attribute__(x)=' '-D__asm(x)=' '-D_Nullable=' '-D_Nonnull=' -E" + cprepro_options="-std=c99 -arch x86_64 -U__GNUC__ -U__clang__ -U__BLOCKS__ '-D__attribute__(x)=' '-D__asm(x)=' '-D_Nullable=' '-D_Nonnull=' '-D__DARWIN_OS_INLINE=static inline' -Wno-\\#warnings -E" libmath="" - system="macosx" + system="macos" ;; cygwin) abi="standard" - casm="${toolprefix}gcc" + cc_options="-m64" casm_options="-m64 -c" - cc="${toolprefix}gcc -m64" - clinker="${toolprefix}gcc" clinker_options="-m64" - cprepro="${toolprefix}gcc" cprepro_options="-std=c99 -m64 -U__GNUC__ '-D__attribute__(x)=' -E" - libmath="-lm" system="cygwin" ;; *) @@ -472,14 +448,10 @@ if test "$arch" = "riscV"; then model_options="-march=rv32imafd -mabi=ilp32d" fi abi="standard" - casm="${toolprefix}gcc" + cc_options="$model_options" casm_options="$model_options -c" - cc="${toolprefix}gcc $model_options" - clinker="${toolprefix}gcc" clinker_options="$model_options" - cprepro="${toolprefix}gcc" cprepro_options="$model_options -std=c99 -U__GNUC__ -E" - libmath="-lm" system="linux" fi @@ -490,15 +462,20 @@ if test "$arch" = "aarch64"; then case "$target" in linux) abi="standard" - casm="${toolprefix}gcc" - casm_options="-c" - cc="${toolprefix}gcc" - clinker="${toolprefix}gcc" - clinker_options="" - cprepro="${toolprefix}gcc" cprepro_options="-std=c99 -U__GNUC__ -E" - libmath="-lm" system="linux";; + macos|macosx) + abi="apple" + casm="${toolprefix}cc" + casm_options="-c -arch arm64" + cc="${toolprefix}cc -arch arm64" + clinker="${toolprefix}cc" + clinker_needs_no_pie=false + cprepro="${toolprefix}cc" + cprepro_options="-std=c99 -arch arm64 -U__GNUC__ -U__clang__ -U__BLOCKS__ '-D__attribute__(x)=' '-D__asm(x)=' '-D_Nullable=' '-D_Nonnull=' '-D__DARWIN_OS_INLINE=static inline' -Wno-\\#warnings -E" + libmath="" + system="macos" + ;; *) echo "Error: invalid eabi/system '$target' for architecture AArch64." 1>&2 echo "$usage" 1>&2 @@ -581,19 +558,19 @@ missingtools=false echo "Testing Coq... " | tr -d '\n' coq_ver=$(${COQBIN}coqc -v 2>/dev/null | sed -n -e 's/The Coq Proof Assistant, version \([^ ]*\).*$/\1/p') case "$coq_ver" in - 8.8.0|8.8.1|8.8.2|8.9.0|8.9.1|8.10.0|8.10.1|8.10.2|8.11.0|8.11.1|8.11.2|8.12.0|8.12.1) + 8.9.0|8.9.1|8.10.0|8.10.1|8.10.2|8.11.0|8.11.1|8.11.2|8.12.0|8.12.1|8.12.2|8.13.0|8.13.1|8.13.2) echo "version $coq_ver -- good!";; ?*) echo "version $coq_ver -- UNSUPPORTED" if $ignore_coq_version; then echo "Warning: this version of Coq is unsupported, proceed at your own risks." else - echo "Error: CompCert requires a version of Coq between 8.8.0 and 8.12.1" + echo "Error: CompCert requires a version of Coq between 8.9.0 and 8.13.2" missingtools=true fi;; "") echo "NOT FOUND" - echo "Error: make sure Coq version 8.11.2 is installed." + echo "Error: make sure Coq version 8.12.2 is installed." missingtools=true;; esac @@ -696,7 +673,7 @@ cat > Makefile.config <<EOF PREFIX=$prefix BINDIR=$bindir LIBDIR=$libdir -MANDIR=$sharedir/man +MANDIR=$mandir SHAREDIR=$sharedir COQDEVDIR=$coqdevdir OCAML_NATIVE_COMP=$ocaml_native_comp @@ -714,12 +691,13 @@ BITSIZE=$bitsize CASM=$casm CASM_OPTIONS=$casm_options CASMRUNTIME=$casmruntime -CC=$cc +CC=$cc $cc_options CLIGHTGEN=$clightgen CLINKER=$clinker CLINKER_OPTIONS=$clinker_options CPREPRO=$cprepro CPREPRO_OPTIONS=$cprepro_options +ARCHIVER=$archiver ENDIANNESS=$endianness HAS_RUNTIME_LIB=$has_runtime_lib HAS_STANDARD_HEADERS=$has_standard_headers @@ -785,26 +763,32 @@ ENDIANNESS= # Possible choices for x86: # SYSTEM=linux # SYSTEM=bsd -# SYSTEM=macosx +# SYSTEM=macos # SYSTEM=cygwin SYSTEM= -# C compiler for compiling runtime library files and some tests -CC=gcc - -# Preprocessor for .c files -CPREPRO=gcc -U__GNUC__ -E +# C compiler (for testing only) +CC=cc -# Assembler for assembling .s files -CASM=gcc -c +# Assembler for assembling compiled files +CASM=cc +CASM_OPTIONS=-c # Assembler for assembling runtime library files -CASMRUNTIME=gcc -c +CASMRUNTIME=$(CASM) $(CASM_OPTIONS) # Linker -CLINKER=gcc +CLINKER=cc +CLINKER_OPTIONS=-no-pie -# Math library. Set to empty under MacOS X +# Preprocessor for .c files +CPREPRO=cc +CPREPRO_OPTIONS=-std c99 -U__GNUC__ -E + +# Archiver to build .a libraries +ARCHIVER=ar rcs + +# Math library. Set to empty under macOS LIBMATH=-lm # Turn on/off the installation and use of the runtime support library @@ -820,8 +804,8 @@ ASM_SUPPORTS_CFI=false # Turn on/off compilation of clightgen CLIGHTGEN=false -# Whether the other tools support responsefiles in gnu syntax -RESPONSEFILE="none" +# Whether the other tools support responsefiles in GNU syntax or Diab syntax +RESPONSEFILE=gnu # diab # Whether to use the local copies of Flocq and MenhirLib LIBRARY_FLOCQ=local # external @@ -856,7 +840,7 @@ B cparser B extraction EOF -make CoqProject +$make CoqProject # # Clean up target-dependent files to force their recompilation @@ -874,9 +858,9 @@ Please finish the configuration by editing file ./Makefile.config. EOF else -bindirexp=`echo "$bindir" | sed -e "s|\\\$(PREFIX)|$prefix|"` -libdirexp=`echo "$libdir" | sed -e "s|\\\$(PREFIX)|$prefix|"` -coqdevdirexp=`echo "$coqdevdir" | sed -e "s|\\\$(PREFIX)|$prefix|"` +expandprefix() { + echo "$1" | sed -e "s|\\\$(PREFIX)|$prefix|" +} cat <<EOF @@ -886,28 +870,29 @@ CompCert configuration: Application binary interface.. $abi Endianness.................... $endianness OS and development env........ $system - C compiler.................... $cc - C preprocessor................ $cprepro - Assembler..................... $casm + C compiler.................... $cc $cc_options + C preprocessor................ $cprepro $cprepro_options + Assembler..................... $casm $casm_options Assembler supports CFI........ $asm_supports_cfi Assembler for runtime lib..... $casmruntime - Linker........................ $clinker - Linker needs '-no-pie'........ $clinker_needs_no_pie + Linker........................ $clinker $clinker_options + Archiver...................... $archiver Math library.................. $libmath Build command to use.......... $make Menhir API library............ $menhir_dir The Flocq library............. $library_Flocq The MenhirLib library......... $library_MenhirLib - Binaries installed in......... $bindirexp + Binaries installed in......... $(expandprefix $bindir) Runtime library provided...... $has_runtime_lib - Library files installed in.... $libdirexp + Library files installed in.... $(expandprefix $libdir) + Man pages installed in........ $(expandprefix $mandir) Standard headers provided..... $has_standard_headers - Standard headers installed in. $libdirexp/include + Standard headers installed in. $(expandprefix $libdir)/include EOF if $install_coqdev; then cat <<EOF - Coq development installed in.. $coqdevdirexp + Coq development installed in.. $(expandprefix $coqdevdir) EOF else cat <<EOF diff --git a/cparser/Bitfields.ml b/cparser/Bitfields.ml deleted file mode 100644 index 7a00f719..00000000 --- a/cparser/Bitfields.ml +++ /dev/null @@ -1,580 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(* Elimination of bit fields in structs *) - -(* Assumes: nothing. *) - -open Machine -open C -open Cutil -open Transform - -(* Info associated to each bitfield *) - -type bitfield_info = - { bf_carrier: string; (* name of underlying regular field *) - bf_carrier_typ: typ; (* type of underlying regular field *) - bf_pos: int; (* start bit *) - bf_size: int; (* size in bit *) - bf_signed: bool; (* is field signed or unsigned? *) - bf_signed_res: bool; (* is result of extracting field signed or unsigned? *) - bf_bool: bool (* does field have type _Bool? *) - } - -(* invariants: - 0 <= pos < bitsizeof(int) - 0 < sz <= bitsizeof(int) - 0 < pos + sz <= bitsizeof(int) -*) - -let carrier_field bf = - { fld_name = bf.bf_carrier; fld_typ = bf.bf_carrier_typ; - fld_bitfield = None; fld_anonymous = false } - -(* Mapping (struct/union identifier, bitfield name) -> bitfield info *) - -let bitfield_table = - (Hashtbl.create 57: (ident * string, bitfield_info) Hashtbl.t) - -let is_bitfield structid fieldname = - Hashtbl.find_opt bitfield_table (structid, fieldname) - -(* Mapping struct/union identifier -> list of members after transformation, - including the carrier fields, but without the bit fields. - structs and unions containing no bit fields are not put in this table. *) - -let composite_transformed_members = - (Hashtbl.create 57: (ident, C.field list) Hashtbl.t) - -(* Signedness issues *) - -let unsigned_ikind_for_carrier nbits = - if nbits <= 8 then IUChar else - if nbits <= 8 * !config.sizeof_short then IUShort else - if nbits <= 8 * !config.sizeof_int then IUInt else - if nbits <= 8 * !config.sizeof_long then IULong else - if nbits <= 8 * !config.sizeof_longlong then IULongLong else - assert false - -let is_signed_enum_bitfield env sid fld eid n = - let info = Env.find_enum env eid in - if List.for_all (fun (_, v, _) -> int_representable v n false) info.Env.ei_members - then false - else if List.for_all (fun (_, v, _) -> int_representable v n true) info.Env.ei_members - then true - else begin - Diagnostics.warning Diagnostics.no_loc Diagnostics.Unnamed - "not all values of type 'enum %s' can be represented in bit-field '%s' of struct '%s' (%d bits are not enough)" - eid.C.name fld sid.C.name n; - false - end - -(* Packing algorithm -- keep consistent with [Cutil.pack_bitfield]! *) - -let pack_bitfields env sid ml = - let rec pack accu pos = function - | [] -> - (pos, accu, []) - | m :: ms as ml -> - match m.fld_bitfield with - | None -> (pos, accu, ml) - | Some n -> - if n = 0 then - (pos, accu, ms) (* bit width 0 means end of pack *) - else if pos + n > 8 * !config.sizeof_int then - (pos, accu, ml) (* doesn't fit in current word *) - else begin - let signed = - match unroll env m.fld_typ with - | TInt(ik, _) -> is_signed_ikind ik - | TEnum(eid, _) -> is_signed_enum_bitfield env sid m.fld_name eid n - | _ -> assert false (* should never happen, checked in Elab *) in - let signed2 = - match unroll env (type_of_member env m) with - | TInt(ik, _) -> is_signed_ikind ik - | _ -> assert false (* should never happen, checked in Elab *) in - let is_bool = - match unroll env m.fld_typ with - | TInt(IBool, _) -> true - | _ -> false in - - pack ((m.fld_name, pos, n, signed, signed2, is_bool) :: accu) - (pos + n) ms - end - in pack [] 0 ml - -let rec transf_struct_members env id count = function - | [] -> [] - | m :: ms as ml -> - if m.fld_bitfield = None then - m :: transf_struct_members env id count ms - else begin - let (nbits, bitfields, ml') = pack_bitfields env id ml in - if nbits = 0 then - (* Lone zero-size bitfield: just ignore *) - transf_struct_members env id count ml' - else begin - (* Create integer field of sufficient size for this bitfield group *) - let carrier = Printf.sprintf "__bf%d" count in - let carrier_ikind = unsigned_ikind_for_carrier nbits in - let carrier_typ = TInt(carrier_ikind, []) in - (* Enter each field with its bit position, size, signedness *) - List.iter - (fun (name, pos, sz, signed, signed2, is_bool) -> - if name <> "" then begin - let pos' = - if !config.bitfields_msb_first - then sizeof_ikind carrier_ikind * 8 - pos - sz - else pos in - Debug.set_bitfield_offset id name pos carrier (sizeof_ikind carrier_ikind); - Hashtbl.add bitfield_table - (id, name) - {bf_carrier = carrier; bf_carrier_typ = carrier_typ; - bf_pos = pos'; bf_size = sz; - bf_signed = signed; bf_signed_res = signed2; - bf_bool = is_bool} - end) - bitfields; - { fld_name = carrier; fld_typ = carrier_typ; fld_bitfield = None; fld_anonymous = false;} - :: transf_struct_members env id (count + 1) ml' - end - end - -let rec transf_union_members env id count = function - | [] -> [] - | m :: ms -> - (match m.fld_bitfield with - | None -> m::transf_union_members env id count ms - | Some nbits -> - let carrier = Printf.sprintf "__bf%d" count in - let carrier_ikind = unsigned_ikind_for_carrier nbits in - let carrier_typ = TInt(carrier_ikind, []) in - let signed = - match unroll env m.fld_typ with - | TInt(ik, _) -> is_signed_ikind ik - | TEnum(eid, _) -> is_signed_enum_bitfield env id m.fld_name eid nbits - | _ -> assert false (* should never happen, checked in Elab *) in - let signed2 = - match unroll env (type_of_member env m) with - | TInt(ik, _) -> is_signed_ikind ik - | _ -> assert false (* should never happen, checked in Elab *) in - let pos' = - if !config.bitfields_msb_first - then sizeof_ikind carrier_ikind * 8 - nbits - else 0 in - let is_bool = - match unroll env m.fld_typ with - | TInt(IBool, _) -> true - | _ -> false in - Hashtbl.add bitfield_table - (id, m.fld_name) - {bf_carrier = carrier; bf_carrier_typ = carrier_typ; - bf_pos = pos'; bf_size = nbits; - bf_signed = signed; bf_signed_res = signed2; - bf_bool = is_bool}; - { fld_name = carrier; fld_typ = carrier_typ; fld_bitfield = None; fld_anonymous = false;} - :: transf_union_members env id (count + 1) ms) - -let transf_composite env loc su id attr ml = - if List.for_all (fun f -> f.fld_bitfield = None) ml then - (attr, ml) - else begin - if find_custom_attributes ["packed";"__packed__"] attr <> [] then - Diagnostics.error loc "bitfields in packed structs not allowed"; - let ml' = - match su with - | Struct -> transf_struct_members env id 1 ml - | Union -> transf_union_members env id 1 ml in - Hashtbl.add composite_transformed_members id ml'; - (attr, ml') - end - -(* Bitfield manipulation expressions *) - -let left_shift_count bf = - intconst - (Int64.of_int (8 * !config.sizeof_int - (bf.bf_pos + bf.bf_size))) - IInt - -let right_shift_count bf = - intconst - (Int64.of_int (8 * !config.sizeof_int - bf.bf_size)) - IInt - -let uintconst_hex v = - { edesc = EConst(CInt(v, IUInt, Printf.sprintf "0x%LXU" v)); - etyp = TInt(IUInt, []) } - -let insertion_mask bf = - let m = - Int64.shift_left - (Int64.pred (Int64.shift_left 1L bf.bf_size)) - bf.bf_pos in - (* Give the mask an hexadecimal string representation, nicer to read *) - uintconst_hex m - -let eshift env op a b = - let ty = unary_conversion env a.etyp in - { edesc = EBinop(op, a, b, ty); etyp = ty } - -let ebinint env op a b = - let ty = binary_conversion env a.etyp b.etyp in - { edesc = EBinop(op, a, b, ty); etyp = ty } - -(* Extract the value of a bitfield *) - -(* Reference C code: - -unsigned int bitfield_unsigned_extract(unsigned int x, int ofs, int sz) -{ - return (x << (BITSIZE_UINT - (ofs + sz))) >> (BITSIZE_UINT - sz); -} - -signed int bitfield_signed_extract(unsigned int x, int ofs, int sz) -{ - return ((signed int) (x << (BITSIZE_UINT - (ofs + sz)))) - >> (BITSIZE_UINT - sz); -} - -*) - -let bitfield_extract env bf carrier = - let e1 = eshift env Oshl carrier (left_shift_count bf) in - let ty = TInt((if bf.bf_signed then IInt else IUInt), []) in - let e2 = ecast ty e1 in - let e3 = eshift env Oshr e2 (right_shift_count bf) in - if bf.bf_signed_res = bf.bf_signed - then e3 - else ecast (TInt((if bf.bf_signed_res then IInt else IUInt), [])) e3 - -(* Assign a bitfield within a carrier *) - -(* Reference C code: - -unsigned int bitfield_insert(unsigned int x, int ofs, int sz, unsigned int y) -{ - unsigned int mask = ((1U << sz) - 1) << ofs; - return (x & ~mask) | ((y << ofs) & mask); -} - -If the bitfield is of type _Bool, the new value (y above) must be converted -to _Bool to normalize it to 0 or 1. -*) - -let bitfield_assign env bf carrier newval = - let msk = insertion_mask bf in - let notmsk = {edesc = EUnop(Onot, msk); etyp = msk.etyp} in - let newval_casted = - ecast (TInt(IUInt,[])) - (if bf.bf_bool then ecast (TInt(IBool,[])) newval else newval) in - let newval_shifted = - eshift env Oshl newval_casted (intconst (Int64.of_int bf.bf_pos) IUInt) in - let newval_masked = ebinint env Oand newval_shifted msk - and oldval_masked = ebinint env Oand carrier notmsk in - ebinint env Oor oldval_masked newval_masked - -(* Initialize a bitfield *) - -(* Reference C code: - -unsigned int bitfield_init(int ofs, int sz, unsigned int y) -{ - unsigned int mask = (1U << sz) - 1; - return (y & mask) << ofs; -} - -If the bitfield is of type _Bool, the new value (y above) must be converted -to _Bool to normalize it to 0 or 1. -*) - -let bitfield_initializer bf i = - match i with - | Init_single e -> - let m = Int64.pred (Int64.shift_left 1L bf.bf_size) in - let e_cast = - if bf.bf_bool then ecast (TInt(IBool,[])) e else e in - let e_mask = uintconst_hex m in - let e_and = - {edesc = EBinop(Oand, e_cast, e_mask, TInt(IUInt,[])); - etyp = TInt(IUInt,[])} in - {edesc = EBinop(Oshl, e_and, intconst (Int64.of_int bf.bf_pos) IInt, - TInt(IUInt, [])); - etyp = TInt(IUInt, [])} - | _ -> - assert false - -(* Associate to the left so that it prints more nicely *) - -let or_expr_list = function - | [] -> intconst 0L IUInt - | [e] -> e - | e1 :: el -> - List.fold_left - (fun accu e -> - {edesc = EBinop(Oor, accu, e, TInt(IUInt,[])); - etyp = TInt(IUInt,[])}) - e1 el - -(* Initialize the carrier for consecutive bitfields *) - -let rec pack_bitfield_init id carrier fld_init_list = - match fld_init_list with - | [] -> ([], []) - | (fld, i) :: rem -> - match is_bitfield id fld.fld_name with - | None -> - ([], fld_init_list) - | Some bf -> - if bf.bf_carrier <> carrier then - ([], fld_init_list) - else begin - let (el, rem') = pack_bitfield_init id carrier rem in - (bitfield_initializer bf i :: el, rem') - end - -let rec transf_struct_init id fld_init_list = - match fld_init_list with - | [] -> [] - | (fld, i) :: rem -> - match is_bitfield id fld.fld_name with - | None -> - (fld, i) :: transf_struct_init id rem - | Some bf -> - let (el, rem') = - pack_bitfield_init id bf.bf_carrier fld_init_list in - (carrier_field bf, - Init_single {edesc = ECast(bf.bf_carrier_typ, or_expr_list el); - etyp = bf.bf_carrier_typ}) - :: transf_struct_init id rem' - -(* Add default initialization for carrier fields that are not listed in the output of - [transf_struct_init]. This happens with carrier fields that contain no named - bitfields, only anonymous bitfields. *) - -let rec completed_struct_init env actual expected = - match actual, expected with - | [], [] -> [] - | (f_a, i) :: actual', f_e :: expected' when f_a.fld_name = f_e.fld_name -> - (f_a, i) :: completed_struct_init env actual' expected' - | _, f_e :: expected' -> - (f_e, default_init env f_e.fld_typ) :: completed_struct_init env actual expected' - | _, [] -> - assert false - -(* Check whether a field access (e.f or e->f) is a bitfield access. - If so, return carrier expression (e and *e, respectively) - and bitfield_info *) - -let rec is_bitfield_access env e = - match e.edesc with - | EUnop(Odot fieldname, e1) -> - begin match unroll env e1.etyp with - | TUnion (id,_) - | TStruct(id, _) -> - (try Some(e1, Hashtbl.find bitfield_table (id, fieldname)) - with Not_found -> None) - | _ -> - None - end - | EUnop(Oarrow fieldname, e1) -> - begin match unroll env e1.etyp with - | TPtr(ty, _) | TArray(ty, _, _) -> - is_bitfield_access env - {edesc = EUnop(Odot fieldname, - {edesc = EUnop(Oderef, e1); etyp = ty}); - etyp = e.etyp} - | _ -> - None - end - | _ -> None - -(* Expressions *) - -let rec transf_exp env ctx e = - match e.edesc with - | EConst _ -> e - | ESizeof _ -> e - | EAlignof _ -> e - | EVar _ -> e - - | EUnop(Odot s, e1) -> - begin match is_bitfield_access env e with - | None -> - {edesc = EUnop(Odot s, transf_exp env Val e1); etyp = e.etyp} - | Some(ex, bf) -> - transf_read env ex bf - end - | EUnop(Oarrow s, e1) -> - begin match is_bitfield_access env e with - | None -> - {edesc = EUnop(Oarrow s, transf_exp env Val e1); etyp = e.etyp} - | Some(ex, bf) -> - transf_read env ex bf - end - | EUnop((Opreincr|Opredecr) as op, e1) -> - begin match is_bitfield_access env e1 with - | None -> - {edesc = EUnop(op, transf_exp env Val e1); etyp = e.etyp} - | Some(ex, bf) -> - transf_pre env ctx (op_for_incr_decr op) ex bf e1.etyp - end - | EUnop((Opostincr|Opostdecr) as op, e1) -> - begin match is_bitfield_access env e1 with - | None -> - {edesc = EUnop(op, transf_exp env Val e1); etyp = e.etyp} - | Some(ex, bf) -> - transf_post env ctx (op_for_incr_decr op) ex bf e1.etyp - end - | EUnop(op, e1) -> - {edesc = EUnop(op, transf_exp env Val e1); etyp = e.etyp} - - | EBinop(Oassign, e1, e2, ty) -> - begin match is_bitfield_access env e1 with - | None -> - {edesc = EBinop(Oassign, transf_exp env Val e1, - transf_exp env Val e2, ty); - etyp = e.etyp} - | Some(ex, bf) -> - transf_assign env ctx ex bf e2 - end - | EBinop((Oadd_assign|Osub_assign|Omul_assign|Odiv_assign - |Omod_assign|Oand_assign|Oor_assign|Oxor_assign - |Oshl_assign|Oshr_assign) as op, - e1, e2, ty) -> - begin match is_bitfield_access env e1 with - | None -> - {edesc = EBinop(op, transf_exp env Val e1, - transf_exp env Val e2, ty); etyp = e.etyp} - | Some(ex, bf) -> - transf_assignop env ctx (op_for_assignop op) ex bf e2 ty - end - | EBinop(Ocomma, e1, e2, ty) -> - {edesc = EBinop(Ocomma, transf_exp env Effects e1, - transf_exp env Val e2, ty); - etyp = e.etyp} - | EBinop(op, e1, e2, ty) -> - {edesc = EBinop(op, transf_exp env Val e1, transf_exp env Val e2, ty); - etyp = e.etyp} - - | EConditional(e1, e2, e3) -> - {edesc = EConditional(transf_exp env Val e1, - transf_exp env ctx e2, transf_exp env ctx e3); - etyp = e.etyp} - | ECast(ty, e1) -> - {edesc = ECast(ty, transf_exp env Val e1); etyp = e.etyp} - | ECompound(ty, i) -> - {edesc = ECompound(ty, transf_init env i); etyp = e.etyp} - | ECall(e1, el) -> - {edesc = ECall(transf_exp env Val e1, List.map (transf_exp env Val) el); - etyp = e.etyp} - -and transf_read env e bf = - bitfield_extract env bf - {edesc = EUnop(Odot bf.bf_carrier, transf_exp env Val e); - etyp = bf.bf_carrier_typ} - -and transf_assign env ctx e1 bf e2 = - bind_lvalue env (transf_exp env Val e1) (fun base -> - let carrier = - {edesc = EUnop(Odot bf.bf_carrier, base); etyp = bf.bf_carrier_typ} in - let asg = - eassign carrier (bitfield_assign env bf carrier (transf_exp env Val e2)) in - if ctx = Val then ecomma asg (bitfield_extract env bf carrier) else asg) - -and transf_assignop env ctx op e1 bf e2 tyres = - bind_lvalue env (transf_exp env Val e1) (fun base -> - let carrier = - {edesc = EUnop(Odot bf.bf_carrier, base); etyp = bf.bf_carrier_typ} in - let rhs = - {edesc = EBinop(op, bitfield_extract env bf carrier, transf_exp env Val e2, tyres); - etyp = tyres} in - let asg = - eassign carrier (bitfield_assign env bf carrier rhs) in - if ctx = Val then ecomma asg (bitfield_extract env bf carrier) else asg) - -and transf_pre env ctx op e1 bf tyfield = - transf_assignop env ctx op e1 bf (intconst 1L IInt) - (unary_conversion env tyfield) - -and transf_post env ctx op e1 bf tyfield = - if ctx = Effects then - transf_pre env ctx op e1 bf tyfield - else begin - bind_lvalue env (transf_exp env Val e1) (fun base -> - let carrier = - {edesc = EUnop(Odot bf.bf_carrier, base); etyp = bf.bf_carrier_typ} in - let temp = mk_temp env tyfield in - let tyres = unary_conversion env tyfield in - let settemp = eassign temp (bitfield_extract env bf carrier) in - let rhs = - {edesc = EBinop(op, temp, intconst 1L IInt, tyres); etyp = tyres} in - let asg = - eassign carrier (bitfield_assign env bf carrier rhs) in - ecomma (ecomma settemp asg) temp) - end - -(* Initializers *) - -and transf_init env i = - match i with - | Init_single e -> Init_single (transf_exp env Val e) - | Init_array il -> Init_array (List.rev (List.rev_map (transf_init env) il)) - | Init_struct(id, fld_init_list) -> - let fld_init_list' = - List.map (fun (f, i) -> (f, transf_init env i)) fld_init_list in - begin match Hashtbl.find composite_transformed_members id with - | exception Not_found -> - Init_struct(id, fld_init_list') - | ml -> - Init_struct(id, completed_struct_init env (transf_struct_init id fld_init_list') ml) - end - | Init_union(id, fld, i) -> - let i' = transf_init env i in - match is_bitfield id fld.fld_name with - | None -> - Init_union(id, fld, i') - | Some bf -> - Init_union(id, carrier_field bf, Init_single (bitfield_initializer bf i')) - -(* Declarations *) - -let transf_decl env loc (sto, id, ty, init_opt) = - (sto, id, ty, - match init_opt with None -> None | Some i -> Some(transf_init env i)) - -(* Statements *) - -let transf_stmt env s = - Transform.stmt - ~expr:(fun loc env ctx e -> transf_exp env ctx e) - ~decl:(fun env (sto, id, ty, init_opt) -> transf_decl env s.sloc (sto, id, ty, init_opt)) - env s - -(* Functions *) - -let transf_fundef env loc f = - Transform.fundef transf_stmt env f - -(* Programs *) - -let program p = - Hashtbl.clear bitfield_table; - Hashtbl.clear composite_transformed_members; - Transform.program - ~composite:transf_composite - ~decl: transf_decl - ~fundef:transf_fundef - p diff --git a/cparser/Bitfields.mli b/cparser/Bitfields.mli deleted file mode 100644 index 45899a46..00000000 --- a/cparser/Bitfields.mli +++ /dev/null @@ -1,16 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -val program: C.program -> C.program diff --git a/cparser/C.mli b/cparser/C.mli index 15717565..763a9277 100644 --- a/cparser/C.mli +++ b/cparser/C.mli @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/Cabs.v b/cparser/Cabs.v index ff046cba..accb95a0 100644 --- a/cparser/Cabs.v +++ b/cparser/Cabs.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/Cabshelper.ml b/cparser/Cabshelper.ml index 7cffef08..36f67283 100644 --- a/cparser/Cabshelper.ml +++ b/cparser/Cabshelper.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/Ceval.ml b/cparser/Ceval.ml index ecf83779..14f61e06 100644 --- a/cparser/Ceval.ml +++ b/cparser/Ceval.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/Ceval.mli b/cparser/Ceval.mli index 32a0ed91..5b9bb0d7 100644 --- a/cparser/Ceval.mli +++ b/cparser/Ceval.mli @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/Cflow.ml b/cparser/Cflow.ml index cc257189..061e958e 100644 --- a/cparser/Cflow.ml +++ b/cparser/Cflow.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -23,8 +24,12 @@ open Cutil module StringSet = Set.Make(String) (* Functions declared noreturn by the standard *) +(* We also add our own "__builtin_unreachable" function because, currently, + it is difficult to attach attributes to a built-in function. *) + let std_noreturn_functions = - ["longjmp";"exit";"_exit";"abort";"_Exit";"quick_exit";"thrd_exit"] + ["longjmp";"exit";"_exit";"abort";"_Exit";"quick_exit";"thrd_exit"; + "__builtin_unreachable"] (* Statements are abstracted as "flow transformers": functions from possible inputs to possible outcomes. diff --git a/cparser/Cflow.mli b/cparser/Cflow.mli index 0de245ae..8348b37e 100644 --- a/cparser/Cflow.mli +++ b/cparser/Cflow.mli @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/Checks.ml b/cparser/Checks.ml index 17caf19a..507488f2 100644 --- a/cparser/Checks.ml +++ b/cparser/Checks.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/Checks.mli b/cparser/Checks.mli index cfd7b04d..08ce4e9a 100644 --- a/cparser/Checks.mli +++ b/cparser/Checks.mli @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/Cleanup.ml b/cparser/Cleanup.ml index 63ac8ac1..62b00e04 100644 --- a/cparser/Cleanup.ml +++ b/cparser/Cleanup.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/Cleanup.mli b/cparser/Cleanup.mli index 818a51bc..c469936a 100644 --- a/cparser/Cleanup.mli +++ b/cparser/Cleanup.mli @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/Cprint.ml b/cparser/Cprint.ml index 9aeec421..93377989 100644 --- a/cparser/Cprint.ml +++ b/cparser/Cprint.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/Cprint.mli b/cparser/Cprint.mli index be7ce029..01175d36 100644 --- a/cparser/Cprint.mli +++ b/cparser/Cprint.mli @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/Cutil.ml b/cparser/Cutil.ml index 3467c092..d3a830ce 100644 --- a/cparser/Cutil.ml +++ b/cparser/Cutil.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -448,34 +449,6 @@ let rec equal_types env t1 t2 = let compatible_types mode env t1 t2 = match combine_types mode env t1 t2 with Some _ -> true | None -> false -(* Naive placement algorithm for bit fields, might not match that - of the compiler. *) - -let pack_bitfields ml = - let rec pack nbits = function - | [] -> - (nbits, []) - | m :: ms as ml -> - match m.fld_bitfield with - | None -> (nbits, ml) - | Some n -> - if n = 0 then - (nbits, ms) (* bit width 0 means end of pack *) - else if nbits + n > 8 * !config.sizeof_int then - (nbits, ml) (* doesn't fit in current word *) - else - pack (nbits + n) ms (* add to current word *) - in - let (nbits, ml') = pack 0 ml in - let (sz, al) = - (* A lone bitfield of width 0 consumes no space and aligns to 1 *) - if nbits = 0 then (0, 1) else - if nbits <= 8 then (1, 1) else - if nbits <= 16 then (2, 2) else - if nbits <= 32 then (4, 4) else - if nbits <= 64 then (8, 8) else assert false in - (sz, al, ml') - (* Natural alignment, in bytes *) let alignof_ikind = function @@ -519,15 +492,13 @@ let rec alignof env t = let alignof_struct_union env members = let rec align_rec al = function | [] -> Some al - | m :: rem as ml -> - if m.fld_bitfield = None then begin + | m :: rem -> + if m.fld_name = "" then + align_rec al rem + else match alignof env m.fld_typ with | None -> None | Some a -> align_rec (max a al) rem - end else begin - let (s, a, ml') = pack_bitfields ml in - align_rec (max a al) ml' - end in align_rec 1 members let align x boundary = @@ -604,43 +575,63 @@ let sizeof_union env members = Bitfields are taken into account for the size and offset computations but not given an offset. Not done here but in composite_info_def: rounding size to alignment. *) + let sizeof_layout_struct env members ma = - let align_offset ofs a = - align ofs (if ma > 0 && a > ma then ma else a) in - let rec sizeof_rec ofs accu = function + + let align_bit_offset pos a = + align pos (8 * (if ma > 0 && a > ma then ma else a)) in + + let record_field name pos = + assert (pos mod 8 = 0); + (name, pos / 8) in + + (* pos is the current position in bits *) + let rec sizeof_rec pos accu = function | [] -> - Some (ofs, accu) + Some (pos, accu) | [ { fld_typ = TArray(_, None, _) } as m ] -> (* C99: ty[] allowed as last field *) begin match alignof env m.fld_typ with | Some a -> - let ofs = align_offset ofs a in - Some (ofs, (m.fld_name, ofs) :: accu) + let pos = align_bit_offset pos a in + Some (pos, record_field m.fld_name pos :: accu) | None -> None end - | m :: rem as ml -> - if m.fld_bitfield = None then begin - match alignof env m.fld_typ, sizeof env m.fld_typ with - | Some a, Some s -> - let ofs = align_offset ofs a in - sizeof_rec (ofs + s) ((m.fld_name, ofs) :: accu) rem - | _, _ -> None - end else begin - let (s, a, ml') = pack_bitfields ml in - sizeof_rec (align_offset ofs a + s) accu ml' + | m :: rem -> + begin match alignof env m.fld_typ, sizeof env m.fld_typ with + | Some a, Some s -> + begin match m.fld_bitfield with + | None -> + let pos = align_bit_offset pos a in + sizeof_rec (pos + s * 8) + (record_field m.fld_name pos :: accu) + rem + | Some width -> + (* curr = beginning of storage unit, in bits + next = one past end of storage unit, in bits *) + let curr = pos / (a * 8) * (a * 8) in + let next = curr + s * 8 in + let pos' = + if width <= 0 then align pos (a * 8) + else if pos + width <= next then pos + width + else next + width in + sizeof_rec pos' accu rem + end + | _, _ -> + None end in sizeof_rec 0 [] members let sizeof_struct env members ma = match sizeof_layout_struct env members ma with | None -> None - | Some(sz, offsets) -> Some sz + | Some(bitsize, offsets) -> Some ((bitsize + 7) / 8) (* Compute the offsets of all non-bitfield members of a struct. *) let struct_layout env attrs members = let (ma, _, _) = packing_parameters attrs in match sizeof_layout_struct env members ma with - | Some(sz, offsets) -> offsets + | Some(bitsize, offsets) -> offsets | None -> [] (* Compute the offset of a struct member *) diff --git a/cparser/Cutil.mli b/cparser/Cutil.mli index 2ddee78c..17eb2207 100644 --- a/cparser/Cutil.mli +++ b/cparser/Cutil.mli @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/Diagnostics.ml b/cparser/Diagnostics.ml index 86a5e522..483b0376 100644 --- a/cparser/Diagnostics.ml +++ b/cparser/Diagnostics.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/Diagnostics.mli b/cparser/Diagnostics.mli index 0f0a0ea5..1210353f 100644 --- a/cparser/Diagnostics.mli +++ b/cparser/Diagnostics.mli @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/Elab.ml b/cparser/Elab.ml index bb9f8aca..a5b87e2e 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -1001,7 +1002,7 @@ and elab_field_group env = function | TInt(ik, _) -> ik | TEnum(_, _) -> enum_ikind | _ -> ILongLong (* trigger next error message *) in - if integer_rank ik > integer_rank IInt then begin + if sizeof_ikind ik > sizeof_ikind IInt then begin error loc "the type of bit-field '%a' must be an integer type no bigger than 'int'" pp_field id; None,env @@ -2871,7 +2872,10 @@ let elab_definition (for_loop: bool) (local: bool) (nonstatic_inline: bool) (* pragma *) | PRAGMA(s, loc) -> - emit_elab env loc (Gpragma s); + if local then + warning loc Unnamed "pragmas are ignored inside functions" + else + emit_elab env loc (Gpragma s); ([], env) (* static assertion *) diff --git a/cparser/Elab.mli b/cparser/Elab.mli index 59c5efc1..bca4f74d 100644 --- a/cparser/Elab.mli +++ b/cparser/Elab.mli @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/Env.ml b/cparser/Env.ml index 00806be1..7918c31f 100644 --- a/cparser/Env.ml +++ b/cparser/Env.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/Env.mli b/cparser/Env.mli index 589a76c7..7c1096cf 100644 --- a/cparser/Env.mli +++ b/cparser/Env.mli @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/ErrorReports.ml b/cparser/ErrorReports.ml index e8f0bee5..ac1e17ac 100644 --- a/cparser/ErrorReports.ml +++ b/cparser/ErrorReports.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/ErrorReports.mli b/cparser/ErrorReports.mli index dbaba5ff..c2160b49 100644 --- a/cparser/ErrorReports.mli +++ b/cparser/ErrorReports.mli @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/ExtendedAsm.ml b/cparser/ExtendedAsm.ml index df2da2a2..d34dd654 100644 --- a/cparser/ExtendedAsm.ml +++ b/cparser/ExtendedAsm.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/GCC.ml b/cparser/GCC.ml index 458e51d3..31385b45 100644 --- a/cparser/GCC.ml +++ b/cparser/GCC.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/GCC.mli b/cparser/GCC.mli index 174e5754..5b2ddbba 100644 --- a/cparser/GCC.mli +++ b/cparser/GCC.mli @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/Lexer.mll b/cparser/Lexer.mll index 881d411a..42980d30 100644 --- a/cparser/Lexer.mll +++ b/cparser/Lexer.mll @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -95,7 +96,8 @@ let () = (* We can ignore the __extension__ GCC keyword. *) ignored_keywords := SSet.add "__extension__" !ignored_keywords -let init_ctx = SSet.singleton "__builtin_va_list" +let init_ctx = SSet.of_list (List.map fst CBuiltins.builtins.C.builtin_typedefs) + let types_context : SSet.t ref = ref init_ctx let _ = @@ -391,7 +393,7 @@ and string_literal startp accu = parse (* We assume gcc -E syntax but try to tolerate variations. *) and hash = parse | whitespace_char_no_newline + - (decimal_constant as n) + (digit + as n) whitespace_char_no_newline * "\"" ([^ '\n' '\"']* as file) "\"" [^ '\n']* '\n' diff --git a/cparser/Machine.ml b/cparser/Machine.ml index 97bedb3b..c47ec594 100644 --- a/cparser/Machine.ml +++ b/cparser/Machine.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -178,12 +179,12 @@ let x86_32 = struct_passing_style = SP_split_args; struct_return_style = SR_ref} -let x86_32_macosx = +let x86_32_macos = {x86_32 with struct_passing_style = SP_split_args; struct_return_style = SR_int1248 } let x86_32_bsd = - x86_32_macosx + x86_32_macos let x86_64 = { i32lpll64 with name = "x86_64"; char_signed = true; @@ -242,6 +243,9 @@ let aarch64 = struct_passing_style = SP_ref_callee; (* Wrong *) struct_return_style = SR_ref } (* Wrong *) +let aarch64_apple = + { aarch64 with char_signed = true } + (* Add GCC extensions re: sizeof and alignof *) let gcc_extensions c = diff --git a/cparser/Machine.mli b/cparser/Machine.mli index ca7de17b..f9d347b9 100644 --- a/cparser/Machine.mli +++ b/cparser/Machine.mli @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -71,7 +72,7 @@ val ilp32ll64 : t val i32lpll64 : t val il32pll64 : t val x86_32 : t -val x86_32_macosx : t +val x86_32_macos : t val x86_32_bsd : t val x86_64 : t val win32 : t @@ -87,6 +88,7 @@ val arm_bigendian : t val rv32 : t val rv64 : t val aarch64 : t +val aarch64_apple : t val gcc_extensions : t -> t val compcert_interpreter : t -> t diff --git a/cparser/PackedStructs.ml b/cparser/PackedStructs.ml index 4c70c7ae..f3a45785 100644 --- a/cparser/PackedStructs.ml +++ b/cparser/PackedStructs.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -60,10 +61,10 @@ let set_alignas_attr al attrs = (* Rewriting field declarations *) let transf_field_decl mfa swapped loc env struct_id f = - if f.fld_bitfield <> None then - error loc "bitfields in packed structs not allowed"; (* Register as byte-swapped if needed *) if swapped then begin + if f.fld_bitfield <> None then + error loc "byte-swapped bit fields are not supported"; let (can_swap, must_swap) = can_byte_swap env f.fld_typ in if not can_swap then fatal_error loc "cannot byte-swap field of type '%a'" @@ -73,6 +74,8 @@ let transf_field_decl mfa swapped loc env struct_id f = end; (* Reduce alignment if requested *) if mfa = 0 then f else begin + if f.fld_bitfield <> None then + error loc "bit fields in packed structs are not supported"; let al = safe_alignof loc env f.fld_typ in { f with fld_typ = change_attributes_type env (set_alignas_attr (min mfa al)) f.fld_typ } diff --git a/cparser/Parse.ml b/cparser/Parse.ml index d9f9aa1c..a54af0cc 100644 --- a/cparser/Parse.ml +++ b/cparser/Parse.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -17,7 +18,7 @@ module CharSet = Set.Make(struct type t = char let compare = compare end) -let transform_program t p name = +let transform_program t p = let run_pass pass flag p = if CharSet.mem flag t then begin let p = pass p in @@ -26,12 +27,11 @@ let transform_program t p name = end else p in - let p1 = (run_pass StructPassing.program 's' - (run_pass PackedStructs.program 'p' - (run_pass Unblock.program 'b' - (run_pass Bitfields.program 'f' - p)))) in - Rename.program p1 + p + |> run_pass Unblock.program 'b' + |> run_pass PackedStructs.program 'p' + |> run_pass StructPassing.program 's' + |> Rename.program let parse_transformations s = let t = ref CharSet.empty in @@ -39,7 +39,6 @@ let parse_transformations s = String.iter (function 'b' -> set "b" | 's' -> set "s" - | 'f' -> set "bf" | 'p' -> set "bp" | _ -> ()) s; @@ -52,34 +51,33 @@ let read_file sourcefile = close_in ic; text +let parse_string name text = + let log_fuel = Camlcoq.Nat.of_int 50 in + match + Parser.translation_unit_file log_fuel (Lexer.tokens_stream name text) + with + | Parser.MenhirLibParser.Inter.Parsed_pr (ast, _ ) -> + (ast: Cabs.definition list) + | _ -> (* Fail_pr or Fail_pr_full or Timeout_pr, depending + on the version of Menhir. + Fail_pr{,_full} means that there's an inconsistency + between the pre-parser and the parser. + Timeout_pr means that we ran for 2^50 steps. *) + Diagnostics.fatal_error Diagnostics.no_loc "internal error while parsing" + let preprocessed_file transfs name sourcefile = Diagnostics.reset(); + let check_errors x = + Diagnostics.check_errors(); x in (* Reading the whole file at once may seem costly, but seems to be the simplest / most robust way of accessing the text underlying a range of positions. This is used when printing an error message. Plus, I note that reading the whole file into memory leads to a speed increase: "make -C test" speeds up by 3 seconds out of 40 on my machine. *) - let text = read_file sourcefile in - let p = - let t = parse_transformations transfs in - let log_fuel = Camlcoq.Nat.of_int 50 in - let ast : Cabs.definition list = - (match Timing.time "Parsing" - (* The call to Lexer.tokens_stream results in the pre - parsing of the entire file. This is non-negligeabe, - so we cannot use Timing.time2 *) - (fun () -> - Parser.translation_unit_file log_fuel (Lexer.tokens_stream name text)) () - with - | Parser.MenhirLibParser.Inter.Fail_pr -> - (* Theoretically impossible : implies inconsistencies - between grammars. *) - Diagnostics.fatal_error Diagnostics.no_loc "internal error while parsing" - | Parser.MenhirLibParser.Inter.Timeout_pr -> assert false - | Parser.MenhirLibParser.Inter.Parsed_pr (ast, _ ) -> ast) in - let p1 = Timing.time "Elaboration" Elab.elab_file ast in - Diagnostics.check_errors (); - Timing.time2 "Emulations" transform_program t p1 name in - Diagnostics.check_errors(); - p + read_file sourcefile + |> Timing.time2 "Parsing" parse_string name + |> Timing.time "Elaboration" Elab.elab_file + |> check_errors + |> Timing.time2 "Emulations" transform_program (parse_transformations transfs) + |> check_errors diff --git a/cparser/Parse.mli b/cparser/Parse.mli index 433e2e73..c406d96c 100644 --- a/cparser/Parse.mli +++ b/cparser/Parse.mli @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/Parser.vy b/cparser/Parser.vy index 93d84ecf..f1abe3d9 100644 --- a/cparser/Parser.vy +++ b/cparser/Parser.vy @@ -6,10 +6,11 @@ /* */ /* Copyright Institut National de Recherche en Informatique et en */ /* Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU General Public License as published by */ -/* the Free Software Foundation, either version 2 of the License, or */ -/* (at your option) any later version. This file is also distributed */ -/* under the terms of the INRIA Non-Commercial License Agreement. */ +/* under the terms of the GNU Lesser General Public License as */ +/* published by the Free Software Foundation, either version 2.1 of */ +/* the License, or (at your option) any later version. */ +/* This file is also distributed under the terms of the */ +/* INRIA Non-Commercial License Agreement. */ /* */ /* *********************************************************************/ diff --git a/cparser/Rename.ml b/cparser/Rename.ml index 64412194..96424bf8 100644 --- a/cparser/Rename.ml +++ b/cparser/Rename.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/Rename.mli b/cparser/Rename.mli index 818a51bc..c469936a 100644 --- a/cparser/Rename.mli +++ b/cparser/Rename.mli @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/StructPassing.ml b/cparser/StructPassing.ml index 222da367..f1f481d0 100644 --- a/cparser/StructPassing.ml +++ b/cparser/StructPassing.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/StructPassing.mli b/cparser/StructPassing.mli index 45899a46..3ac42495 100644 --- a/cparser/StructPassing.mli +++ b/cparser/StructPassing.mli @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/Transform.ml b/cparser/Transform.ml index a57d94c4..2ca235f1 100644 --- a/cparser/Transform.ml +++ b/cparser/Transform.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/Transform.mli b/cparser/Transform.mli index 220b7944..c00fd15c 100644 --- a/cparser/Transform.mli +++ b/cparser/Transform.mli @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/Unblock.ml b/cparser/Unblock.ml index d25f70c6..4b1f2262 100644 --- a/cparser/Unblock.ml +++ b/cparser/Unblock.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -31,6 +32,9 @@ let rec local_initializer env path init k = let (ty_elt, sz) = match unroll env path.etyp with | TArray(ty_elt, Some sz, _) -> (ty_elt, sz) + (* We accept empty array initializer for flexible array members, which + has size zero *) + | TArray(ty_elt, None, _) when il = [] -> (ty_elt, 0L) | _ -> Diagnostics.fatal_error Diagnostics.no_loc "wrong type for array initializer" in let rec array_init pos il = if pos >= sz then k else begin diff --git a/cparser/Unblock.mli b/cparser/Unblock.mli index e6bea9e4..bd807096 100644 --- a/cparser/Unblock.mli +++ b/cparser/Unblock.mli @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/deLexer.ml b/cparser/deLexer.ml index ee6976d4..e3ab3291 100644 --- a/cparser/deLexer.ml +++ b/cparser/deLexer.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/handcrafted.messages b/cparser/handcrafted.messages index 23e90b3e..db7318c4 100644 --- a/cparser/handcrafted.messages +++ b/cparser/handcrafted.messages @@ -7,10 +7,11 @@ # # # Copyright Institut National de Recherche en Informatique et en # # Automatique. All rights reserved. This file is distributed # -# under the terms of the GNU General Public License as published by # -# the Free Software Foundation, either version 2 of the License, or # -# (at your option) any later version. This file is also distributed # -# under the terms of the INRIA Non-Commercial License Agreement. # +# under the terms of the GNU Lesser General Public License as # +# published by the Free Software Foundation, either version 2.1 of # +# the License, or (at your option) any later version. # +# This file is also distributed under the terms of the # +# INRIA Non-Commercial License Agreement. # # # ####################################################################### diff --git a/cparser/pre_parser.mly b/cparser/pre_parser.mly index 4b62b235..cffbd192 100644 --- a/cparser/pre_parser.mly +++ b/cparser/pre_parser.mly @@ -7,10 +7,11 @@ /* */ /* Copyright Institut National de Recherche en Informatique et en */ /* Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU General Public License as published by */ -/* the Free Software Foundation, either version 2 of the License, or */ -/* (at your option) any later version. This file is also distributed */ -/* under the terms of the INRIA Non-Commercial License Agreement. */ +/* under the terms of the GNU Lesser General Public License as */ +/* published by the Free Software Foundation, either version 2.1 of */ +/* the License, or (at your option) any later version. */ +/* This file is also distributed under the terms of the */ +/* INRIA Non-Commercial License Agreement. */ /* */ /* *********************************************************************/ diff --git a/cparser/pre_parser_aux.ml b/cparser/pre_parser_aux.ml index 4a4953ba..a35305ac 100644 --- a/cparser/pre_parser_aux.ml +++ b/cparser/pre_parser_aux.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/cparser/pre_parser_aux.mli b/cparser/pre_parser_aux.mli index f6b98a95..36e33bc5 100644 --- a/cparser/pre_parser_aux.mli +++ b/cparser/pre_parser_aux.mli @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index 020ac60e..d9e941fb 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -594,7 +594,7 @@ let gnu_file_loc (f,l) = let string_table: (string,int) Hashtbl.t = Hashtbl.create 7 let gnu_string_entry s = - if (String.length s < 4 && Configuration.system <> "macosx") (* macosx needs debug_str *) + if (String.length s < 4 && Configuration.system <> "macos") (* macos needs debug_str *) || Configuration.system = "cygwin" then (*Cygwin does not use the debug_str section*) Simple_string s else diff --git a/doc/index.html b/doc/index.html index ec8c4d91..c3912cb2 100644 --- a/doc/index.html +++ b/doc/index.html @@ -8,6 +8,7 @@ body { color: black; background: white; margin-left: 5%; margin-right: 5%; + max-width:750px; } h2 { margin-left: -5%;} h3 { margin-left: -3%; } @@ -24,7 +25,7 @@ a:active {color : Red; text-decoration : underline; } <H1 align="center">The CompCert verified compiler</H1> <H2 align="center">Commented Coq development</H2> -<H3 align="center">Version 3.8, 2020-11-16</H3> +<H3 align="center">Version 3.9, 2021-05-10</H3> <H2>Introduction</H2> @@ -46,9 +47,9 @@ Journal of Automated Reasoning 43(4):363-446, 2009. <P>This Web site gives a commented listing of the underlying Coq specifications and proofs. Proof scripts are folded by default, but -can be viewed by clicking on "Proof". Some modules (written in <I>italics</I> below) differ between the four target architectures. The -PowerPC versions of these modules are shown below; the ARM, x86 and RISC-V -versions can be found in the source distribution. +can be viewed by clicking on "Proof". Some modules (written in <I>italics</I> below) differ between the five target architectures. The +PowerPC versions of these modules are shown below; the AArch64, ARM, +x86 and RISC-V versions can be found in the source distribution. </P> <P> This development is a work in progress; some parts have diff --git a/driver/Clflags.ml b/driver/Clflags.ml index 80883372..25c3e1dd 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -17,7 +17,6 @@ let linker_options = ref ([]: string list) let assembler_options = ref ([]: string list) let option_flongdouble = ref false let option_fstruct_passing = ref false -let option_fbitfields = ref false let option_fvararg_calls = ref true let option_funprototyped = ref true let option_fpacked_structs = ref false diff --git a/driver/CommonOptions.ml b/driver/CommonOptions.ml index e8a6941c..9da1e533 100644 --- a/driver/CommonOptions.ml +++ b/driver/CommonOptions.ml @@ -32,7 +32,7 @@ let version_options tool_name = (* Language support options *) let all_language_support_options = [ - option_fbitfields; option_flongdouble; + option_flongdouble; option_fstruct_passing; option_fvararg_calls; option_funprototyped; option_fpacked_structs; option_finline_asm ] @@ -44,11 +44,11 @@ let unset_all opts () = List.iter (fun r -> r := false) opts let language_support_options = [ Exact "-fall", Unit (set_all all_language_support_options); - Exact "-fnone", Unit (unset_all all_language_support_options);] + Exact "-fnone", Unit (unset_all all_language_support_options); + Exact "-fbitfields", Unit (fun () -> ()); ] @ f_opt "longdouble" option_flongdouble @ f_opt "struct-return" option_fstruct_passing @ f_opt "struct-passing" option_fstruct_passing - @ f_opt "bitfields" option_fbitfields @ f_opt "vararg-calls" option_fvararg_calls @ f_opt "unprototyped" option_funprototyped @ f_opt "packed-structs" option_fpacked_structs @@ -56,7 +56,6 @@ let language_support_options = let language_support_help = {|Language support options (use -fno-<opt> to turn off -f<opt>) : - -fbitfields Emulate bit fields in structs [off] -flongdouble Treat 'long double' as 'double' [off] -fstruct-passing Support passing structs and unions by value as function results or function arguments [off] @@ -67,6 +66,7 @@ let language_support_help = -finline-asm Support inline 'asm' statements [off] -fall Activate all language support options above -fnone Turn off all language support options above + -fbitfields Ignored (bit fields are now implemented natively) |} (* General options *) @@ -77,7 +77,6 @@ let general_help = -v Print external commands before invoking them -timings Show the time spent in various compiler passes -version Print the version string and exit - -version-file <file> Print version inforation to <file> and exit -target <value> Generate code for the given target -conf <file> Read configuration from file @<file> Read command line options from <file> diff --git a/driver/Configuration.ml b/driver/Configuration.ml index 2188acf0..4b0c116e 100644 --- a/driver/Configuration.ml +++ b/driver/Configuration.ml @@ -157,4 +157,4 @@ let response_file_style = let gnu_toolchain = system <> "diab" -let elf_target = system <> "macosx" && system <> "cygwin" +let elf_target = system <> "macos" && system <> "cygwin" diff --git a/driver/Driver.ml b/driver/Driver.ml index 043e43c1..2b34d538 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -412,6 +412,8 @@ let _ = fatal_error no_loc "ambiguous '-o' option (multiple source files)"; if !num_input_files = 0 then fatal_error no_loc "no input file"; + if not !option_interp && !main_function_name <> "main" then + fatal_error no_loc "option '-main' requires option '-interp'"; let linker_args = time "Total compilation time" perform_actions () in if not (nolink ()) && linker_args <> [] then begin linker (output_filename_default "a.out") linker_args diff --git a/driver/Frontend.ml b/driver/Frontend.ml index bb97e945..6133291e 100644 --- a/driver/Frontend.ml +++ b/driver/Frontend.ml @@ -80,7 +80,6 @@ let parse_c_file sourcename ifile = let simplifs = "b" (* blocks: mandatory *) ^ (if !option_fstruct_passing then "s" else "") - ^ (if !option_fbitfields then "f" else "") ^ (if !option_fpacked_structs then "p" else "") in (* Parsing and production of a simplified C AST *) @@ -109,15 +108,17 @@ let init () = | "x86" -> if Configuration.model = "64" then Machine.x86_64 else - if Configuration.abi = "macosx" - then Machine.x86_32_macosx + if Configuration.abi = "macos" + then Machine.x86_32_macos else if Configuration.system = "bsd" then Machine.x86_32_bsd else Machine.x86_32 | "riscV" -> if Configuration.model = "64" then Machine.rv64 else Machine.rv32 - | "aarch64" -> Machine.aarch64 + | "aarch64" -> if Configuration.abi = "apple" + then Machine.aarch64_apple + else Machine.aarch64 | _ -> assert false end; Env.set_builtins C2C.builtins; diff --git a/exportclight/Clightdefs.v b/exportclight/Clightdefs.v index 8af920df..708be1cb 100644 --- a/exportclight/Clightdefs.v +++ b/exportclight/Clightdefs.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -18,6 +19,8 @@ From Coq Require Import Ascii String List ZArith. From compcert Require Import Integers Floats Maps Errors AST Ctypes Cop Clight. +(** ** Short names for types *) + Definition tvoid := Tvoid. Definition tschar := Tint I8 Signed noattr. Definition tuchar := Tint I8 Unsigned noattr. @@ -56,6 +59,8 @@ Definition talignas (n: N) (ty: type) := Definition tvolatile_alignas (n: N) (ty: type) := tattr {| attr_volatile := true; attr_alignas := Some n |} ty. +(** ** Constructor for programs and compilation units *) + Definition wf_composites (types: list composite_definition) : Prop := match build_composite_env types with OK _ => True | Error _ => False end. @@ -81,6 +86,8 @@ Definition mkprogram (types: list composite_definition) prog_comp_env := ce; prog_comp_env_eq := EQ |}. +(** ** Encoding character strings as positive numbers *) + (** The following encoding of character strings as positive numbers must be kept consistent with the OCaml function [Camlcoq.pos_of_string]. *) @@ -169,17 +176,6 @@ Fixpoint ident_of_string (s: string) : ident := | String c s => append_char_pos c (ident_of_string s) end. -(** A convenient notation [$ "ident"] to force evaluation of - [ident_of_string "ident"] *) - -Ltac ident_of_string s := - let x := constr:(ident_of_string s) in - let y := eval compute in x in - exact y. - -Notation "$ s" := (ltac:(ident_of_string s)) - (at level 1, only parsing) : string_scope. - (** The inverse conversion, from encoded strings to strings *) Section DECODE_BITS. @@ -289,3 +285,20 @@ Proof. intros. rewrite <- (string_of_ident_of_string s1), <- (string_of_ident_of_string s2). congruence. Qed. + +(** ** Notations *) + +Module ClightNotations. + +(** A convenient notation [$ "ident"] to force evaluation of + [ident_of_string "ident"] *) + +Ltac ident_of_string s := + let x := constr:(ident_of_string s) in + let y := eval compute in x in + exact y. + +Notation "$ s" := (ltac:(ident_of_string s)) + (at level 1, only parsing) : clight_scope. + +End ClightNotations. diff --git a/exportclight/Clightgen.ml b/exportclight/Clightgen.ml index 5e27370e..44c76cc6 100644 --- a/exportclight/Clightgen.ml +++ b/exportclight/Clightgen.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/exportclight/Clightnorm.ml b/exportclight/Clightnorm.ml index a6158b60..88d44c08 100644 --- a/exportclight/Clightnorm.ml +++ b/exportclight/Clightnorm.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/exportclight/ExportClight.ml b/exportclight/ExportClight.ml index 4ff901eb..742b3a5c 100644 --- a/exportclight/ExportClight.ml +++ b/exportclight/ExportClight.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -89,23 +90,22 @@ let coqstring p s = exception Not_an_identifier +let sanitize_char = function + | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' as c -> c + | ' ' | '$' -> '_' + | _ -> raise Not_an_identifier + let sanitize s = - let s' = Bytes.create (String.length s) in - for i = 0 to String.length s - 1 do - Bytes.set s' i - (match String.get s i with - | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' as c -> c - | ' ' | '$' -> '_' - | _ -> raise Not_an_identifier) - done; - Bytes.to_string s' + if s <> "" + then "_" ^ String.map sanitize_char s + else "empty_ident" let temp_names : (ident, string) Hashtbl.t = Hashtbl.create 17 let ident p id = try let s = Hashtbl.find string_of_atom id in - fprintf p "_%s" (sanitize s) + fprintf p "%s" (sanitize s) with Not_found | Not_an_identifier -> try let s = Hashtbl.find temp_names id in @@ -124,10 +124,10 @@ let define_idents p = (fun (id, name) -> try if !use_canonical_atoms && id = pos_of_string name then - fprintf p "Definition _%s : ident := $\"%s\".@ " + fprintf p "Definition %s : ident := $\"%s\".@ " (sanitize name) name else - fprintf p "Definition _%s : ident := %a.@ " + fprintf p "Definition %s : ident := %a.@ " (sanitize name) positive id with Not_an_identifier -> ()); @@ -160,6 +160,22 @@ let attribute p a = a.attr_volatile (print_option coqN) a.attr_alignas +(* Raw int size and signedness *) + +let intsize p sz = + fprintf p "%s" + (match sz with + | I8 -> "I8" + | I16 -> "I16" + | I32 -> "I32" + | IBool -> "IBool") + +let signedness p sg = + fprintf p "%s" + (match sg with + | Signed -> "Signed" + | Unsigned -> "Unsigned") + (* Types *) let rec typ p t = @@ -216,8 +232,8 @@ and typlist p = function and callconv p cc = if cc = cc_default then fprintf p "cc_default" - else fprintf p "{|cc_vararg:=%b; cc_unproto:=%b; cc_structret:=%b|}" - cc.cc_vararg cc.cc_unproto cc.cc_structret + else fprintf p "{|cc_vararg:=%a; cc_unproto:=%b; cc_structret:=%b|}" + (print_option coqZ) cc.cc_vararg cc.cc_unproto cc.cc_structret (* External functions *) @@ -398,7 +414,7 @@ and lblstmts p = function (print_option coqZ) lbl stmt s lblstmts ls let print_function p (id, f) = - fprintf p "Definition f_%s := {|@ " (sanitize (extern_atom id)); + fprintf p "Definition f%s := {|@ " (sanitize (extern_atom id)); fprintf p " fn_return := %a;@ " typ f.fn_return; fprintf p " fn_callconv := %a;@ " callconv f.fn_callconv; fprintf p " fn_params := %a;@ " (print_list (print_pair ident typ)) f.fn_params; @@ -419,7 +435,7 @@ let init_data p = function | Init_addrof(id,ofs) -> fprintf p "Init_addrof %a %a" ident id coqptrofs ofs let print_variable p (id, v) = - fprintf p "Definition v_%s := {|@ " (sanitize (extern_atom id)); + fprintf p "Definition v%s := {|@ " (sanitize (extern_atom id)); fprintf p " gvar_info := %a;@ " typ v.gvar_info; fprintf p " gvar_init := %a;@ " (print_list init_data) v.gvar_init; fprintf p " gvar_readonly := %B;@ " v.gvar_readonly; @@ -434,20 +450,33 @@ let print_globdef p (id, gd) = let print_ident_globdef p = function | (id, Gfun(Ctypes.Internal f)) -> - fprintf p "(%a, Gfun(Internal f_%s))" ident id (sanitize (extern_atom id)) + fprintf p "(%a, Gfun(Internal f%s))" ident id (sanitize (extern_atom id)) | (id, Gfun(Ctypes.External(ef, targs, tres, cc))) -> fprintf p "@[<hov 2>(%a,@ @[<hov 2>Gfun(External %a@ %a@ %a@ %a))@]@]" ident id external_function ef typlist targs typ tres callconv cc | (id, Gvar v) -> - fprintf p "(%a, Gvar v_%s)" ident id (sanitize (extern_atom id)) + fprintf p "(%a, Gvar v%s)" ident id (sanitize (extern_atom id)) (* Composite definitions *) +let print_member p = function + | Member_plain (id, ty) -> + fprintf p "@[<hov 2>Member_plain@ %a@ %a@]" + ident id typ ty + | Member_bitfield (id, sz, sg, a, width, pad) -> + fprintf p "@[<hov 2>Member_bitfield@ %a@ %a@ %a@ %a@ %a@ %B@]" + ident id + intsize sz + signedness sg + attribute a + coqZ width + pad + let print_composite_definition p (Composite(id, su, m, a)) = fprintf p "@[<hv 2>Composite %a %s@ %a@ %a@]" ident id (match su with Struct -> "Struct" | Union -> "Union") - (print_list (print_pair ident typ)) m + (print_list print_member) m attribute a (* The prologue *) @@ -455,8 +484,10 @@ let print_composite_definition p (Composite(id, su, m, a)) = let prologue = "\ From Coq Require Import String List ZArith.\n\ From compcert Require Import Coqlib Integers Floats AST Ctypes Cop Clight Clightdefs.\n\ +Import Clightdefs.ClightNotations.\n\ Local Open Scope Z_scope.\n\ -Local Open Scope string_scope.\n" +Local Open Scope string_scope.\n\ +Local Open Scope clight_scope.\n" (* Naming the compiler-generated temporaries occurring in the program *) diff --git a/extraction/extraction.v b/extraction/extraction.v index 521c0cdd..8c2a52a2 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/flocq/Calc/Bracket.v b/flocq/Calc/Bracket.v index 83714e87..838cadfa 100644 --- a/flocq/Calc/Bracket.v +++ b/flocq/Calc/Bracket.v @@ -19,15 +19,19 @@ COPYING file for more details. (** * Locations: where a real number is positioned with respect to its rounded-down value in an arbitrary format. *) +From Coq Require Import Lia. Require Import Raux Defs Float_prop. +Require Import SpecFloatCompat. + +Notation location := location (only parsing). +Notation loc_Exact := loc_Exact (only parsing). +Notation loc_Inexact := loc_Inexact (only parsing). Section Fcalc_bracket. Variable d u : R. Hypothesis Hdu : (d < u)%R. -Inductive location := loc_Exact | loc_Inexact : comparison -> location. - Variable x : R. Definition inbetween_loc := @@ -233,7 +237,7 @@ apply Rplus_le_compat_l. apply Rmult_le_compat_r. now apply Rlt_le. apply IZR_le. -omega. +lia. (* . *) now rewrite middle_range. Qed. @@ -246,7 +250,7 @@ Theorem inbetween_step_Lo : Proof. intros x k l Hx Hk1 Hk2. apply inbetween_step_not_Eq with (1 := Hx). -omega. +lia. apply Rcompare_Lt. assert (Hx' := inbetween_bounds _ _ (ordered_steps _) _ _ Hx). apply Rlt_le_trans with (1 := proj2 Hx'). @@ -255,7 +259,7 @@ rewrite Rcompare_plus_l, Rcompare_mult_r, Rcompare_half_l. apply Rcompare_not_Lt. rewrite <- mult_IZR. apply IZR_le. -omega. +lia. exact Hstep. Qed. @@ -267,7 +271,7 @@ Theorem inbetween_step_Hi : Proof. intros x k l Hx Hk1 Hk2. apply inbetween_step_not_Eq with (1 := Hx). -omega. +lia. apply Rcompare_Gt. assert (Hx' := inbetween_bounds _ _ (ordered_steps _) _ _ Hx). apply Rlt_le_trans with (2 := proj1 Hx'). @@ -276,7 +280,7 @@ rewrite Rcompare_plus_l, Rcompare_mult_r, Rcompare_half_l. apply Rcompare_Lt. rewrite <- mult_IZR. apply IZR_lt. -omega. +lia. exact Hstep. Qed. @@ -331,7 +335,7 @@ Theorem inbetween_step_any_Mi_odd : Proof. intros x k l Hx Hk. apply inbetween_step_not_Eq with (1 := Hx). -omega. +lia. inversion_clear Hx as [|l' _ Hl]. now rewrite (middle_odd _ Hk) in Hl. Qed. @@ -344,7 +348,7 @@ Theorem inbetween_step_Lo_Mi_Eq_odd : Proof. intros x k Hx Hk. apply inbetween_step_not_Eq with (1 := Hx). -omega. +lia. inversion_clear Hx as [Hl|]. rewrite Hl. rewrite Rcompare_plus_l, Rcompare_mult_r, Rcompare_half_r. @@ -365,7 +369,7 @@ Theorem inbetween_step_Hi_Mi_even : Proof. intros x k l Hx Hl Hk. apply inbetween_step_not_Eq with (1 := Hx). -omega. +lia. apply Rcompare_Gt. assert (Hx' := inbetween_bounds_not_Eq _ _ _ _ Hx Hl). apply Rle_lt_trans with (2 := proj1 Hx'). @@ -387,7 +391,7 @@ Theorem inbetween_step_Mi_Mi_even : Proof. intros x k Hx Hk. apply inbetween_step_not_Eq with (1 := Hx). -omega. +lia. apply Rcompare_Eq. inversion_clear Hx as [Hx'|]. rewrite Hx', <- Hk, mult_IZR. @@ -433,10 +437,10 @@ now apply inbetween_step_Lo_not_Eq with (2 := H1). destruct (Zcompare_spec (2 * k) nb_steps) as [Hk1|Hk1|Hk1]. (* . 2 * k < nb_steps *) apply inbetween_step_Lo with (1 := Hx). -omega. +lia. destruct (Zeven_ex nb_steps). rewrite He in H. -omega. +lia. (* . 2 * k = nb_steps *) set (l' := match l with loc_Exact => Eq | _ => Gt end). assert ((l = loc_Exact /\ l' = Eq) \/ (l <> loc_Exact /\ l' = Gt)). @@ -490,7 +494,7 @@ now apply inbetween_step_Lo_not_Eq with (2 := H1). destruct (Zcompare_spec (2 * k + 1) nb_steps) as [Hk1|Hk1|Hk1]. (* . 2 * k + 1 < nb_steps *) apply inbetween_step_Lo with (1 := Hx) (3 := Hk1). -omega. +lia. (* . 2 * k + 1 = nb_steps *) destruct l. apply inbetween_step_Lo_Mi_Eq_odd with (1 := Hx) (2 := Hk1). @@ -499,7 +503,7 @@ apply inbetween_step_any_Mi_odd with (1 := Hx) (2 := Hk1). apply inbetween_step_Hi with (1 := Hx). destruct (Zeven_ex nb_steps). rewrite Ho in H. -omega. +lia. apply Hk. Qed. @@ -612,7 +616,7 @@ clear -Hk. intros m. rewrite (F2R_change_exp beta e). apply (f_equal (fun r => F2R (Float beta (m * Zpower _ r) e))). ring. -omega. +lia. assert (Hp: (Zpower beta k > 0)%Z). apply Z.lt_gt. apply Zpower_gt_0. @@ -622,7 +626,7 @@ rewrite 2!Hr. rewrite Zmult_plus_distr_l, Zmult_1_l. unfold F2R at 2. simpl. rewrite plus_IZR, Rmult_plus_distr_r. -apply new_location_correct. +apply new_location_correct; unfold F2R; simpl. apply bpow_gt_0. now apply Zpower_gt_1. now apply Z_mod_lt. @@ -665,7 +669,7 @@ rewrite <- Hm in H'. clear -H H'. apply inbetween_unique with (1 := H) (2 := H'). destruct (inbetween_float_bounds x m e l H) as (H1,H2). destruct (inbetween_float_bounds x m' e l' H') as (H3,H4). -cut (m < m' + 1 /\ m' < m + 1)%Z. clear ; omega. +cut (m < m' + 1 /\ m' < m + 1)%Z. clear ; lia. now split ; apply lt_F2R with beta e ; apply Rle_lt_trans with x. Qed. diff --git a/flocq/Calc/Div.v b/flocq/Calc/Div.v index 65195562..48e3bb51 100644 --- a/flocq/Calc/Div.v +++ b/flocq/Calc/Div.v @@ -19,6 +19,7 @@ COPYING file for more details. (** * Helper function and theorem for computing the rounded quotient of two floating-point numbers. *) +From Coq Require Import Lia. Require Import Raux Defs Generic_fmt Float_prop Digits Bracket. Set Implicit Arguments. @@ -80,7 +81,7 @@ assert ((F2R (Float beta m1 e1) / F2R (Float beta m2 e2) = IZR m1' / IZR m2' * b destruct (Zle_bool e (e1 - e2)) eqn:He' ; injection Hm ; intros ; subst. - split ; try easy. apply Zle_bool_imp_le in He'. - rewrite mult_IZR, IZR_Zpower by omega. + rewrite mult_IZR, IZR_Zpower by lia. unfold Zminus ; rewrite 2!bpow_plus, 2!bpow_opp. field. repeat split ; try apply Rgt_not_eq, bpow_gt_0. @@ -88,8 +89,8 @@ assert ((F2R (Float beta m1 e1) / F2R (Float beta m2 e2) = IZR m1' / IZR m2' * b - apply Z.leb_gt in He'. split ; cycle 1. { apply Z.mul_pos_pos with (1 := Hm2). - apply Zpower_gt_0 ; omega. } - rewrite mult_IZR, IZR_Zpower by omega. + apply Zpower_gt_0 ; lia. } + rewrite mult_IZR, IZR_Zpower by lia. unfold Zminus ; rewrite bpow_plus, bpow_opp, bpow_plus, bpow_opp. field. repeat split ; try apply Rgt_not_eq, bpow_gt_0. @@ -113,7 +114,7 @@ destruct (Z_lt_le_dec 1 m2') as [Hm2''|Hm2'']. now apply IZR_neq, Zgt_not_eq. field. now apply IZR_neq, Zgt_not_eq. -- assert (r = 0 /\ m2' = 1)%Z as [-> ->] by (clear -Hr Hm2'' ; omega). +- assert (r = 0 /\ m2' = 1)%Z as [-> ->] by (clear -Hr Hm2'' ; lia). unfold Rdiv. rewrite Rmult_1_l, Rplus_0_r, Rinv_1, Rmult_1_r. now constructor. @@ -150,10 +151,10 @@ unfold cexp. destruct (Zle_lt_or_eq _ _ H1) as [H|H]. - replace (fexp (mag _ _)) with (fexp (e + 1)). apply Z.le_min_r. - clear -H1 H2 H ; apply f_equal ; omega. + clear -H1 H2 H ; apply f_equal ; lia. - replace (fexp (mag _ _)) with (fexp e). apply Z.le_min_l. - clear -H1 H2 H ; apply f_equal ; omega. + clear -H1 H2 H ; apply f_equal ; lia. Qed. End Fcalc_div. diff --git a/flocq/Calc/Operations.v b/flocq/Calc/Operations.v index 3416cb4e..ac93d412 100644 --- a/flocq/Calc/Operations.v +++ b/flocq/Calc/Operations.v @@ -17,7 +17,9 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the COPYING file for more details. *) -(** Basic operations on floats: alignment, addition, multiplication *) +(** * Basic operations on floats: alignment, addition, multiplication *) + +From Coq Require Import Lia. Require Import Raux Defs Float_prop. Set Implicit Arguments. @@ -50,7 +52,7 @@ case (Zle_bool e1 e2) ; intros He ; split ; trivial. now rewrite <- F2R_change_exp. rewrite <- F2R_change_exp. apply refl_equal. -omega. +lia. Qed. Theorem Falign_spec_exp: diff --git a/flocq/Calc/Round.v b/flocq/Calc/Round.v index 5bde6af4..704a1ab2 100644 --- a/flocq/Calc/Round.v +++ b/flocq/Calc/Round.v @@ -19,6 +19,7 @@ COPYING file for more details. (** * Helper function for computing the rounded value of a real number. *) +From Coq Require Import Lia. Require Import Core Digits Float_prop Bracket. Section Fcalc_round. @@ -88,7 +89,7 @@ destruct Px as [Px|Px]. destruct Bx as [Bx1 Bx2]. apply lt_0_F2R in Bx1. apply gt_0_F2R in Bx2. - omega. + lia. Qed. (** Relates location and rounding. *) @@ -585,7 +586,7 @@ apply Zlt_succ. rewrite Zle_bool_true with (1 := Hm). rewrite Zle_bool_false. now case Rlt_bool. -omega. +lia. Qed. Definition truncate_aux t k := @@ -674,7 +675,7 @@ unfold cexp. rewrite mag_F2R_Zdigits. 2: now apply Zgt_not_eq. unfold k in Hk. clear -Hk. -omega. +lia. rewrite <- Hm', F2R_0. apply generic_format_0. Qed. @@ -717,14 +718,14 @@ simpl. apply Zfloor_div. intros H. generalize (Zpower_pos_gt_0 beta k) (Zle_bool_imp_le _ _ (radix_prop beta)). -omega. +lia. rewrite scaled_mantissa_generic with (1 := Fx). now rewrite Zfloor_IZR. (* *) split. apply refl_equal. unfold k in Hk. -omega. +lia. Qed. Theorem truncate_correct_partial' : @@ -744,7 +745,7 @@ destruct Zlt_bool ; intros Hk. now apply inbetween_float_new_location. ring. - apply (conj H1). - omega. + lia. Qed. Theorem truncate_correct_partial : @@ -790,7 +791,7 @@ intros x m e l [Hx|Hx] H1 H2. destruct Zlt_bool. intros H. apply False_ind. - omega. + lia. intros _. apply (conj H1). right. @@ -803,7 +804,7 @@ intros x m e l [Hx|Hx] H1 H2. rewrite mag_F2R_Zdigits with (1 := Zm). now apply Zlt_le_weak. - assert (Hm: m = 0%Z). - cut (m <= 0 < m + 1)%Z. omega. + cut (m <= 0 < m + 1)%Z. lia. assert (F2R (Float beta m e) <= x < F2R (Float beta (m + 1) e))%R as Hx'. apply inbetween_float_bounds with (1 := H1). rewrite <- Hx in Hx'. @@ -1156,7 +1157,7 @@ exact H1. unfold k in Hk. destruct H2 as [H2|H2]. left. -omega. +lia. right. split. exact H2. @@ -1165,7 +1166,7 @@ inversion_clear H1. rewrite H. apply generic_format_F2R. unfold cexp. -omega. +lia. Qed. End Fcalc_round. diff --git a/flocq/Calc/Sqrt.v b/flocq/Calc/Sqrt.v index 8843d21e..4d267d21 100644 --- a/flocq/Calc/Sqrt.v +++ b/flocq/Calc/Sqrt.v @@ -19,6 +19,7 @@ COPYING file for more details. (** * Helper functions and theorems for computing the rounded square root of a floating-point number. *) +From Coq Require Import Lia. Require Import Raux Defs Digits Generic_fmt Float_prop Bracket. Set Implicit Arguments. @@ -86,7 +87,7 @@ assert (sqrt (F2R (Float beta m1 e1)) = sqrt (IZR m') * bpow e)%R as Hf. { rewrite <- (sqrt_Rsqr (bpow e)) by apply bpow_ge_0. rewrite <- sqrt_mult. unfold Rsqr, m'. - rewrite mult_IZR, IZR_Zpower by omega. + rewrite mult_IZR, IZR_Zpower by lia. rewrite Rmult_assoc, <- 2!bpow_plus. now replace (_ + _)%Z with e1 by ring. now apply IZR_le. @@ -106,7 +107,7 @@ fold (Rsqr (IZR q)). rewrite sqrt_Rsqr. now constructor. apply IZR_le. -clear -Hr ; omega. +clear -Hr ; lia. (* .. r <> 0 *) constructor. split. @@ -117,14 +118,14 @@ fold (Rsqr (IZR q)). rewrite sqrt_Rsqr. apply Rle_refl. apply IZR_le. -clear -Hr ; omega. +clear -Hr ; lia. apply sqrt_lt_1. rewrite mult_IZR. apply Rle_0_sqr. rewrite <- Hq. now apply IZR_le. apply IZR_lt. -omega. +lia. apply Rlt_le_trans with (sqrt (IZR ((q + 1) * (q + 1)))). apply sqrt_lt_1. rewrite <- Hq. @@ -133,13 +134,13 @@ rewrite mult_IZR. apply Rle_0_sqr. apply IZR_lt. ring_simplify. -omega. +lia. rewrite mult_IZR. fold (Rsqr (IZR (q + 1))). rewrite sqrt_Rsqr. apply Rle_refl. apply IZR_le. -clear -Hr ; omega. +clear -Hr ; lia. (* ... location *) rewrite Rcompare_half_r. generalize (Rcompare_sqr (2 * sqrt (IZR (q * q + r))) (IZR q + IZR (q + 1))). @@ -154,14 +155,14 @@ replace ((q + (q + 1)) * (q + (q + 1)))%Z with (4 * (q * q) + 4 * q + 1)%Z by ri generalize (Zle_cases r q). case (Zle_bool r q) ; intros Hr''. change (4 * (q * q + r) < 4 * (q * q) + 4 * q + 1)%Z. -omega. +lia. change (4 * (q * q + r) > 4 * (q * q) + 4 * q + 1)%Z. -omega. +lia. rewrite <- Hq. now apply IZR_le. rewrite <- plus_IZR. apply IZR_le. -clear -Hr ; omega. +clear -Hr ; lia. apply Rmult_le_pos. now apply IZR_le. apply sqrt_ge_0. @@ -188,7 +189,7 @@ set (e := Z.min _ _). assert (2 * e <= e1)%Z as He. { assert (e <= Z.div2 e1)%Z by apply Z.le_min_r. rewrite (Zdiv2_odd_eqn e1). - destruct Z.odd ; omega. } + destruct Z.odd ; lia. } generalize (Fsqrt_core_correct m1 e1 e Hm1 He). destruct Fsqrt_core as [m l]. apply conj. diff --git a/flocq/Core/Defs.v b/flocq/Core/Defs.v index f5c6f33b..27342df9 100644 --- a/flocq/Core/Defs.v +++ b/flocq/Core/Defs.v @@ -80,4 +80,8 @@ Definition Rnd_NA_pt (F : R -> Prop) (x f : R) := Rnd_N_pt F x f /\ forall f2 : R, Rnd_N_pt F x f2 -> (Rabs f2 <= Rabs f)%R. +Definition Rnd_N0_pt (F : R -> Prop) (x f : R) := + Rnd_N_pt F x f /\ + forall f2 : R, Rnd_N_pt F x f2 -> (Rabs f <= Rabs f2)%R. + End RND. diff --git a/flocq/Core/Digits.v b/flocq/Core/Digits.v index bed2e20a..a18ff8d6 100644 --- a/flocq/Core/Digits.v +++ b/flocq/Core/Digits.v @@ -17,8 +17,13 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the COPYING file for more details. *) -Require Import ZArith Zquot. +From Coq Require Import Lia ZArith Zquot. + Require Import Zaux. +Require Import SpecFloatCompat. + +Notation digits2_pos := digits2_pos (only parsing). +Notation Zdigits2 := Zdigits2 (only parsing). (** Number of bits (radix 2) of a positive integer. @@ -41,9 +46,9 @@ intros n d. unfold d. clear. assert (Hp: forall m, (Zpower_nat 2 (S m) = 2 * Zpower_nat 2 m)%Z) by easy. induction n ; simpl digits2_Pnat. rewrite Zpos_xI, 2!Hp. -omega. +lia. rewrite (Zpos_xO n), 2!Hp. -omega. +lia. now split. Qed. @@ -185,13 +190,13 @@ apply Zgt_not_eq. now apply Zpower_gt_0. now apply Zle_minus_le_0. destruct (Zle_or_lt 0 k) as [H0|H0]. -rewrite (Zdigit_lt n) by omega. +rewrite (Zdigit_lt n) by lia. unfold Zdigit. replace k' with (k' - k + k)%Z by ring. rewrite Zpower_plus with (2 := H0). rewrite Zmult_assoc, Z_quot_mult. replace (k' - k)%Z with (k' - k - 1 + 1)%Z by ring. -rewrite Zpower_exp by omega. +rewrite Zpower_exp by lia. rewrite Zmult_assoc. change (Zpower beta 1) with (beta * 1)%Z. rewrite Zmult_1_r. @@ -203,7 +208,7 @@ now apply Zlt_le_weak. rewrite Zdigit_lt with (1 := H0). apply sym_eq. apply Zdigit_lt. -omega. +lia. Qed. Theorem Zdigit_div_pow : @@ -227,7 +232,7 @@ unfold Zdigit. rewrite <- 2!ZOdiv_mod_mult. apply (f_equal (fun x => Z.quot x (beta ^ k))). replace k' with (k + 1 + (k' - (k + 1)))%Z by ring. -rewrite Zpower_exp by omega. +rewrite Zpower_exp by lia. rewrite Zmult_comm. rewrite Zpower_plus by easy. change (Zpower beta 1) with (beta * 1)%Z. @@ -449,7 +454,7 @@ unfold Zscale. case Zle_bool_spec ; intros Hk. now apply Zdigit_mul_pow. apply Zdigit_div_pow with (1 := Hk'). -omega. +lia. Qed. Theorem Zscale_0 : @@ -492,7 +497,7 @@ now rewrite Zpower_plus. now apply Zplus_le_0_compat. case Zle_bool_spec ; intros Hk''. pattern k at 1 ; replace k with (k + k' + -k')%Z by ring. -assert (0 <= -k')%Z by omega. +assert (0 <= -k')%Z by lia. rewrite Zpower_plus by easy. rewrite Zmult_assoc, Z_quot_mult. apply refl_equal. @@ -503,7 +508,7 @@ rewrite Zpower_plus with (2 := Hk). apply Zquot_mult_cancel_r. apply Zgt_not_eq. now apply Zpower_gt_0. -omega. +lia. Qed. Theorem Zscale_scale : @@ -532,7 +537,7 @@ rewrite Zdigit_mod_pow by apply Hk. rewrite Zdigit_scale by apply Hk. unfold Zminus. now rewrite Z.opp_involutive, Zplus_comm. -omega. +lia. Qed. Theorem Zdigit_slice_out : @@ -589,16 +594,16 @@ destruct (Zle_or_lt k2' k) as [Hk''|Hk'']. now apply Zdigit_slice_out. rewrite Zdigit_slice by now split. apply Zdigit_slice_out. -zify ; omega. -rewrite Zdigit_slice by (zify ; omega). +zify ; lia. +rewrite Zdigit_slice by (zify ; lia). rewrite (Zdigit_slice n (k1 + k1')) by now split. rewrite Zdigit_slice. now rewrite Zplus_assoc. -zify ; omega. +zify ; lia. unfold Zslice. rewrite Z.min_r. now rewrite Zle_bool_false. -omega. +lia. Qed. Theorem Zslice_mul_pow : @@ -624,14 +629,14 @@ case Zle_bool_spec ; intros Hk2. apply (f_equal (fun x => Z.rem x (beta ^ k2))). unfold Zscale. case Zle_bool_spec ; intros Hk1'. -replace k1 with Z0 by omega. +replace k1 with Z0 by lia. case Zle_bool_spec ; intros Hk'. -replace k with Z0 by omega. +replace k with Z0 by lia. simpl. now rewrite Z.quot_1_r. rewrite Z.opp_involutive. apply Zmult_1_r. -rewrite Zle_bool_false by omega. +rewrite Zle_bool_false by lia. rewrite 2!Z.opp_involutive, Zplus_comm. rewrite Zpower_plus by assumption. apply Zquot_Zquot. @@ -646,7 +651,7 @@ unfold Zscale. case Zle_bool_spec; intros Hk. now apply Zslice_mul_pow. apply Zslice_div_pow with (2 := Hk1). -omega. +lia. Qed. Theorem Zslice_div_pow_scale : @@ -666,7 +671,7 @@ apply Zdigit_slice_out. now apply Zplus_le_compat_l. rewrite Zdigit_slice by now split. destruct (Zle_or_lt 0 (k1 + k')) as [Hk1'|Hk1']. -rewrite Zdigit_slice by omega. +rewrite Zdigit_slice by lia. rewrite Zdigit_div_pow by assumption. apply f_equal. ring. @@ -685,15 +690,15 @@ rewrite Zdigit_plus. rewrite Zdigit_scale with (1 := Hk). destruct (Zle_or_lt (l1 + l2) k) as [Hk2|Hk2]. rewrite Zdigit_slice_out with (1 := Hk2). -now rewrite 2!Zdigit_slice_out by omega. +now rewrite 2!Zdigit_slice_out by lia. rewrite Zdigit_slice with (1 := conj Hk Hk2). destruct (Zle_or_lt l1 k) as [Hk1|Hk1]. rewrite Zdigit_slice_out with (1 := Hk1). -rewrite Zdigit_slice by omega. +rewrite Zdigit_slice by lia. simpl ; apply f_equal. ring. rewrite Zdigit_slice with (1 := conj Hk Hk1). -rewrite (Zdigit_lt _ (k - l1)) by omega. +rewrite (Zdigit_lt _ (k - l1)) by lia. apply Zplus_0_r. rewrite Zmult_comm. apply Zsame_sign_trans_weak with n. @@ -713,7 +718,7 @@ left. now apply Zdigit_slice_out. right. apply Zdigit_lt. -omega. +lia. Qed. Section digits_aux. @@ -788,7 +793,7 @@ pattern (radix_val beta) at 2 5 ; replace (radix_val beta) with (Zpower beta 1) rewrite <- Zpower_plus. rewrite Zplus_comm. apply IHu. -clear -Hv ; omega. +clear -Hv ; lia. split. now ring_simplify (1 + v - 1)%Z. now rewrite Zplus_assoc. @@ -928,7 +933,7 @@ intros x y Zx Hxy. assert (Hx := Zdigits_correct x). assert (Hy := Zdigits_correct y). apply (Zpower_lt_Zpower beta). -zify ; omega. +zify ; lia. Qed. Theorem lt_Zdigits : @@ -938,7 +943,7 @@ Theorem lt_Zdigits : (x < y)%Z. Proof. intros x y Hy. -cut (y <= x -> Zdigits y <= Zdigits x)%Z. omega. +cut (y <= x -> Zdigits y <= Zdigits x)%Z. lia. now apply Zdigits_le. Qed. @@ -951,7 +956,7 @@ intros e x Hex. destruct (Zdigits_correct x) as [H1 H2]. apply Z.le_trans with (2 := H1). apply Zpower_le. -clear -Hex ; omega. +clear -Hex ; lia. Qed. Theorem Zdigits_le_Zpower : @@ -961,7 +966,7 @@ Theorem Zdigits_le_Zpower : Proof. intros e x. generalize (Zpower_le_Zdigits e x). -omega. +lia. Qed. Theorem Zpower_gt_Zdigits : @@ -982,7 +987,7 @@ Theorem Zdigits_gt_Zpower : Proof. intros e x Hex. generalize (Zpower_gt_Zdigits e x). -omega. +lia. Qed. (** Number of digits of a product. @@ -1010,8 +1015,8 @@ apply Zdigits_correct. apply Zlt_le_succ. rewrite <- (Z.abs_eq y) at 1 by easy. apply Zdigits_correct. -clear -Hx ; omega. -clear -Hy ; omega. +clear -Hx ; lia. +clear -Hy ; lia. change Z0 with (0 + 0 + 0)%Z. apply Zplus_le_compat. now apply Zplus_le_compat. @@ -1031,7 +1036,7 @@ apply Zdigits_le. apply Zabs_pos. rewrite Zabs_Zmult. generalize (Zabs_pos x) (Zabs_pos y). -omega. +lia. apply Zdigits_mult_strong ; apply Zabs_pos. Qed. @@ -1041,7 +1046,7 @@ Theorem Zdigits_mult_ge : (Zdigits x + Zdigits y - 1 <= Zdigits (x * y))%Z. Proof. intros x y Zx Zy. -cut ((Zdigits x - 1) + (Zdigits y - 1) < Zdigits (x * y))%Z. omega. +cut ((Zdigits x - 1) + (Zdigits y - 1) < Zdigits (x * y))%Z. lia. apply Zdigits_gt_Zpower. rewrite Zabs_Zmult. rewrite Zpower_exp. @@ -1052,8 +1057,8 @@ apply Zpower_le_Zdigits. apply Zlt_pred. apply Zpower_ge_0. apply Zpower_ge_0. -generalize (Zdigits_gt_0 x). omega. -generalize (Zdigits_gt_0 y). omega. +generalize (Zdigits_gt_0 x). lia. +generalize (Zdigits_gt_0 y). lia. Qed. Theorem Zdigits_div_Zpower : @@ -1073,7 +1078,7 @@ destruct (Zle_lt_or_eq _ _ (proj2 He)) as [He'|He']. replace (Zdigits m - e - 1)%Z with (Zdigits m - 1 - e)%Z by ring. rewrite Z.pow_sub_r. 2: apply Zgt_not_eq, radix_gt_0. - 2: clear -He He' ; omega. + 2: clear -He He' ; lia. apply Z_div_le with (2 := H1). now apply Z.lt_gt, Zpower_gt_0. apply Zmult_lt_reg_r with (Zpower beta e). @@ -1118,13 +1123,6 @@ rewrite <- Zpower_nat_Z. apply digits2_Pnat_correct. Qed. -Fixpoint digits2_pos (n : positive) : positive := - match n with - | xH => xH - | xO p => Pos.succ (digits2_pos p) - | xI p => Pos.succ (digits2_pos p) - end. - Theorem Zpos_digits2_pos : forall m : positive, Zpos (digits2_pos m) = Zdigits radix2 (Zpos m). @@ -1137,13 +1135,6 @@ induction m ; simpl ; try easy ; apply f_equal, IHm. Qed. -Definition Zdigits2 n := - match n with - | Z0 => n - | Zpos p => Zpos (digits2_pos p) - | Zneg p => Zpos (digits2_pos p) - end. - Lemma Zdigits2_Zdigits : forall n, Zdigits2 n = Zdigits radix2 n. Proof. diff --git a/flocq/Core/FIX.v b/flocq/Core/FIX.v index 4e0a25e6..779d94cb 100644 --- a/flocq/Core/FIX.v +++ b/flocq/Core/FIX.v @@ -18,6 +18,8 @@ COPYING file for more details. *) (** * Fixed-point format *) + +From Coq Require Import Lia. Require Import Raux Defs Round_pred Generic_fmt Ulp Round_NE. Section RND_FIX. @@ -86,9 +88,16 @@ intros x; unfold ulp. case Req_bool_spec; intros Zx. case (negligible_exp_spec FIX_exp). intros T; specialize (T (emin-1)%Z); contradict T. -unfold FIX_exp; omega. +unfold FIX_exp; lia. intros n _; reflexivity. reflexivity. Qed. +Global Instance exists_NE_FIX : + Exists_NE beta FIX_exp. +Proof. +unfold Exists_NE, FIX_exp; simpl. +right; split; auto. +Qed. + End RND_FIX. diff --git a/flocq/Core/FLT.v b/flocq/Core/FLT.v index bd48d4b7..7301328d 100644 --- a/flocq/Core/FLT.v +++ b/flocq/Core/FLT.v @@ -46,7 +46,7 @@ intros k. unfold FLT_exp. generalize (prec_gt_0 prec). repeat split ; - intros ; zify ; omega. + intros ; zify ; lia. Qed. Theorem generic_format_FLT : @@ -93,24 +93,28 @@ simpl in ex. specialize (He Hx0). apply Rlt_le_trans with (1 := proj2 He). apply bpow_le. -cut (ex' - prec <= ex)%Z. omega. +cut (ex' - prec <= ex)%Z. lia. unfold ex, FLT_exp. apply Z.le_max_l. apply Z.le_max_r. Qed. - -Theorem FLT_format_bpow : +Theorem generic_format_FLT_bpow : forall e, (emin <= e)%Z -> generic_format beta FLT_exp (bpow e). Proof. intros e He. apply generic_format_bpow; unfold FLT_exp. apply Z.max_case; try assumption. -unfold Prec_gt_0 in prec_gt_0_; omega. +unfold Prec_gt_0 in prec_gt_0_; lia. Qed. - - +Theorem FLT_format_bpow : + forall e, (emin <= e)%Z -> FLT_format (bpow e). +Proof. +intros e He. +apply FLT_format_generic. +now apply generic_format_FLT_bpow. +Qed. Theorem FLT_format_satisfies_any : satisfies_any FLT_format. @@ -136,12 +140,40 @@ apply Zmax_left. destruct (mag beta x) as (ex, He). unfold FLX_exp. simpl. specialize (He Hx0). -cut (emin + prec - 1 < ex)%Z. omega. +cut (emin + prec - 1 < ex)%Z. lia. apply (lt_bpow beta). apply Rle_lt_trans with (1 := Hx). apply He. Qed. +(** FLT is a nice format: it has a monotone exponent... *) +Global Instance FLT_exp_monotone : Monotone_exp FLT_exp. +Proof. +intros ex ey. +unfold FLT_exp. +zify ; lia. +Qed. + +(** and it allows a rounding to nearest, ties to even. *) +Global Instance exists_NE_FLT : + (Z.even beta = false \/ (1 < prec)%Z) -> + Exists_NE beta FLT_exp. +Proof. +intros [H|H]. +now left. +right. +intros e. +unfold FLT_exp. +destruct (Zmax_spec (e - prec) emin) as [(H1,H2)|(H1,H2)] ; + rewrite H2 ; clear H2. +generalize (Zmax_spec (e + 1 - prec) emin). +generalize (Zmax_spec (e - prec + 1 - prec) emin). +lia. +generalize (Zmax_spec (e + 1 - prec) emin). +generalize (Zmax_spec (emin + 1 - prec) emin). +lia. +Qed. + (** Links between FLT and FLX *) Theorem generic_format_FLT_FLX : forall x : R, @@ -192,7 +224,7 @@ apply Zmax_right. unfold FIX_exp. destruct (mag beta x) as (ex, Hex). simpl. -cut (ex - 1 < emin + prec)%Z. omega. +cut (ex - 1 < emin + prec)%Z. lia. apply (lt_bpow beta). apply Rle_lt_trans with (2 := Hx). now apply Hex. @@ -222,7 +254,7 @@ apply generic_inclusion_le... intros e He. unfold FIX_exp. apply Z.max_lub. -omega. +lia. apply Z.le_refl. Qed. @@ -238,45 +270,53 @@ destruct (Z.max_spec (n - prec) emin) as [(Hm, Hm')|(Hm, Hm')]. revert Hn prec_gt_0_; unfold FLT_exp, Prec_gt_0; rewrite Hm'; lia. Qed. -Theorem generic_format_FLT_1 (Hemin : (emin <= 0)%Z) : +Theorem generic_format_FLT_1 : + (emin <= 0)%Z -> generic_format beta FLT_exp 1. Proof. -unfold generic_format, scaled_mantissa, cexp, F2R; simpl. -rewrite Rmult_1_l, (mag_unique beta 1 1). -{ unfold FLT_exp. - destruct (Z.max_spec_le (1 - prec) emin) as [(H,Hm)|(H,Hm)]; rewrite Hm; - (rewrite <- IZR_Zpower; [|unfold Prec_gt_0 in prec_gt_0_; omega]); - (rewrite Ztrunc_IZR, IZR_Zpower, <-bpow_plus; - [|unfold Prec_gt_0 in prec_gt_0_; omega]); - now replace (_ + _)%Z with Z0 by ring. } -rewrite Rabs_R1; simpl; split; [now right|]. -rewrite IZR_Zpower_pos; simpl; rewrite Rmult_1_r; apply IZR_lt. -apply (Z.lt_le_trans _ 2); [omega|]; apply Zle_bool_imp_le, beta. +intros Hemin. +now apply (generic_format_FLT_bpow 0). Qed. -Theorem ulp_FLT_small: forall x, (Rabs x < bpow (emin+prec))%R -> - ulp beta FLT_exp x = bpow emin. -Proof with auto with typeclass_instances. +Theorem ulp_FLT_0 : + ulp beta FLT_exp 0 = bpow emin. +Proof. +unfold ulp. +rewrite Req_bool_true by easy. +case negligible_exp_spec. +- intros T. + elim Zle_not_lt with (2 := T emin). + apply Z.le_max_r. +- intros n Hn. + apply f_equal. + assert (H: FLT_exp emin = emin). + apply Z.max_r. + generalize (prec_gt_0 prec). + clear ; lia. + rewrite <- H. + apply fexp_negligible_exp_eq. + apply FLT_exp_valid. + exact Hn. + rewrite H. + apply Z.le_refl. +Qed. + +Theorem ulp_FLT_small : + forall x, (Rabs x < bpow (emin + prec))%R -> + ulp beta FLT_exp x = bpow emin. +Proof. intros x Hx. -unfold ulp; case Req_bool_spec; intros Hx2. -(* x = 0 *) -case (negligible_exp_spec FLT_exp). -intros T; specialize (T (emin-1)%Z); contradict T. -apply Zle_not_lt; unfold FLT_exp. -apply Z.le_trans with (2:=Z.le_max_r _ _); omega. -assert (V:FLT_exp emin = emin). -unfold FLT_exp; apply Z.max_r. -unfold Prec_gt_0 in prec_gt_0_; omega. -intros n H2; rewrite <-V. -apply f_equal, fexp_negligible_exp_eq... -omega. -(* x <> 0 *) -apply f_equal; unfold cexp, FLT_exp. +destruct (Req_dec x 0%R) as [Zx|Zx]. +{ rewrite Zx. + apply ulp_FLT_0. } +rewrite ulp_neq_0 by easy. +apply f_equal. apply Z.max_r. -assert (mag beta x-1 < emin+prec)%Z;[idtac|omega]. -destruct (mag beta x) as (e,He); simpl. +destruct (mag beta x) as [e He]. +simpl. +cut (e - 1 < emin + prec)%Z. lia. apply lt_bpow with beta. -apply Rle_lt_trans with (2:=Hx). +apply Rle_lt_trans with (2 := Hx). now apply He. Qed. @@ -295,8 +335,8 @@ apply Rle_trans with (bpow (e-1)*bpow (1-prec))%R. rewrite <- bpow_plus. right; apply f_equal. replace (e - 1 + (1 - prec))%Z with (e - prec)%Z by ring. -apply Z.max_l. -assert (emin+prec-1 < e)%Z; try omega. +apply Z.max_l; simpl. +assert (emin+prec-1 < e)%Z; try lia. apply lt_bpow with beta. apply Rle_lt_trans with (1:=Hx). now apply He. @@ -334,7 +374,7 @@ unfold ulp; rewrite Req_bool_false; [|now intro H; apply Nzx, (Rmult_eq_reg_r (bpow e)); [rewrite Rmult_0_l|apply Rgt_not_eq, Rlt_gt, bpow_gt_0]]. rewrite (Req_bool_false _ _ Nzx), <- bpow_plus; f_equal; unfold cexp, FLT_exp. -rewrite (mag_mult_bpow _ _ _ Nzx), !Z.max_l; omega. +rewrite (mag_mult_bpow _ _ _ Nzx), !Z.max_l; lia. Qed. Lemma succ_FLT_exact_shift_pos : @@ -375,32 +415,106 @@ fold (Req_bool (-x) (bpow (mag beta (-x) - 1))); case Req_bool. rewrite ulp_FLT_exact_shift; [ring|lra| |]; rewrite mag_opp; lia. Qed. -(** FLT is a nice format: it has a monotone exponent... *) -Global Instance FLT_exp_monotone : Monotone_exp FLT_exp. -Proof. -intros ex ey. -unfold FLT_exp. -zify ; omega. -Qed. - -(** and it allows a rounding to nearest, ties to even. *) -Hypothesis NE_prop : Z.even beta = false \/ (1 < prec)%Z. - -Global Instance exists_NE_FLT : Exists_NE beta FLT_exp. +Theorem ulp_FLT_pred_pos : + forall x, + generic_format beta FLT_exp x -> + (0 <= x)%R -> + ulp beta FLT_exp (pred beta FLT_exp x) = ulp beta FLT_exp x \/ + (x = bpow (mag beta x - 1) /\ ulp beta FLT_exp (pred beta FLT_exp x) = (ulp beta FLT_exp x / IZR beta)%R). Proof. -destruct NE_prop as [H|H]. -now left. -right. -intros e. -unfold FLT_exp. -destruct (Zmax_spec (e - prec) emin) as [(H1,H2)|(H1,H2)] ; - rewrite H2 ; clear H2. -generalize (Zmax_spec (e + 1 - prec) emin). -generalize (Zmax_spec (e - prec + 1 - prec) emin). -omega. -generalize (Zmax_spec (e + 1 - prec) emin). -generalize (Zmax_spec (emin + 1 - prec) emin). -omega. +intros x Fx [Hx|Hx] ; cycle 1. +{ rewrite <- Hx. + rewrite pred_0. + rewrite ulp_opp. + left. + apply ulp_ulp_0. + apply FLT_exp_valid. + typeclasses eauto. } +assert (Hp: (0 <= pred beta FLT_exp x)%R). +{ apply pred_ge_gt ; try easy. + apply FLT_exp_valid. + apply generic_format_0. } +destruct (Rle_or_lt (bpow (emin + prec)) x) as [Hs|Hs]. +- unfold ulp. + rewrite Req_bool_false ; cycle 1. + { intros Zp. + apply Rle_not_lt with (1 := Hs). + generalize (f_equal (succ beta FLT_exp) Zp). + rewrite succ_pred. + rewrite succ_0, ulp_FLT_0. + intros H. + rewrite H. + apply bpow_lt. + generalize (prec_gt_0 prec). + lia. + apply FLT_exp_valid. + exact Fx. } + rewrite Req_bool_false by now apply Rgt_not_eq. + unfold cexp. + destruct (mag beta x) as [e He]. + simpl. + specialize (He (Rgt_not_eq _ _ Hx)). + rewrite Rabs_pos_eq in He by now apply Rlt_le. + destruct (proj1 He) as [Hb|Hb]. + + left. + apply (f_equal (fun v => bpow (FLT_exp v))). + apply mag_unique. + rewrite Rabs_pos_eq by easy. + split. + * apply pred_ge_gt ; try easy. + apply FLT_exp_valid. + apply generic_format_FLT_bpow. + apply Z.lt_le_pred. + apply lt_bpow with beta. + apply Rle_lt_trans with (2 := proj2 He). + apply Rle_trans with (2 := Hs). + apply bpow_le. + generalize (prec_gt_0 prec). + lia. + * apply pred_lt_le. + now apply Rgt_not_eq. + now apply Rlt_le. + + right. + split. + easy. + replace (FLT_exp _) with (FLT_exp e + -1)%Z. + rewrite bpow_plus. + now rewrite <- (Zmult_1_r beta). + rewrite <- Hb. + unfold FLT_exp at 1 2. + replace (mag_val _ _ (mag _ _)) with (e - 1)%Z. + rewrite <- Hb in Hs. + apply le_bpow in Hs. + zify ; lia. + apply eq_sym, mag_unique. + rewrite Hb. + rewrite Rabs_pos_eq by easy. + split ; cycle 1. + { apply pred_lt_id. + now apply Rgt_not_eq. } + apply pred_ge_gt. + apply FLT_exp_valid. + apply generic_format_FLT_bpow. + cut (emin + 1 < e)%Z. lia. + apply lt_bpow with beta. + apply Rle_lt_trans with (2 := proj2 He). + apply Rle_trans with (2 := Hs). + apply bpow_le. + generalize (prec_gt_0 prec). + lia. + exact Fx. + apply Rlt_le_trans with (2 := proj1 He). + apply bpow_lt. + apply Z.lt_pred_l. +- left. + rewrite (ulp_FLT_small x). + apply ulp_FLT_small. + rewrite Rabs_pos_eq by easy. + apply pred_lt_le. + now apply Rgt_not_eq. + now apply Rlt_le. + rewrite Rabs_pos_eq by now apply Rlt_le. + exact Hs. Qed. End RND_FLT. diff --git a/flocq/Core/FLX.v b/flocq/Core/FLX.v index 803d96ef..78bffba5 100644 --- a/flocq/Core/FLX.v +++ b/flocq/Core/FLX.v @@ -48,7 +48,7 @@ Proof. intros k. unfold FLX_exp. generalize prec_gt_0. -repeat split ; intros ; omega. +repeat split ; intros ; lia. Qed. Theorem FIX_format_FLX : @@ -212,7 +212,7 @@ Proof. case (negligible_exp_spec FLX_exp). intros _; reflexivity. intros n H2; contradict H2. -unfold FLX_exp; unfold Prec_gt_0 in prec_gt_0_; omega. +unfold FLX_exp; unfold Prec_gt_0 in prec_gt_0_; lia. Qed. Theorem generic_format_FLX_1 : @@ -221,13 +221,13 @@ Proof. unfold generic_format, scaled_mantissa, cexp, F2R; simpl. rewrite Rmult_1_l, (mag_unique beta 1 1). { unfold FLX_exp. - rewrite <- IZR_Zpower; [|unfold Prec_gt_0 in prec_gt_0_; omega]. - rewrite Ztrunc_IZR, IZR_Zpower; [|unfold Prec_gt_0 in prec_gt_0_; omega]. + rewrite <- IZR_Zpower; [|unfold Prec_gt_0 in prec_gt_0_; lia]. + rewrite Ztrunc_IZR, IZR_Zpower; [|unfold Prec_gt_0 in prec_gt_0_; lia]. rewrite <- bpow_plus. now replace (_ + _)%Z with Z0 by ring. } rewrite Rabs_R1; simpl; split; [now right|]. unfold Z.pow_pos; simpl; rewrite Zmult_1_r; apply IZR_lt. -assert (H := Zle_bool_imp_le _ _ (radix_prop beta)); omega. +assert (H := Zle_bool_imp_le _ _ (radix_prop beta)); lia. Qed. Theorem ulp_FLX_0: (ulp beta FLX_exp 0 = 0)%R. @@ -356,7 +356,7 @@ destruct NE_prop as [H|H]. now left. right. unfold FLX_exp. -split ; omega. +split ; lia. Qed. End RND_FLX. diff --git a/flocq/Core/FTZ.v b/flocq/Core/FTZ.v index 1a93bcd9..d6bae6ea 100644 --- a/flocq/Core/FTZ.v +++ b/flocq/Core/FTZ.v @@ -18,6 +18,8 @@ COPYING file for more details. *) (** * Floating-point format with abrupt underflow *) + +From Coq Require Import Lia. Require Import Raux Defs Round_pred Generic_fmt. Require Import Float_prop Ulp FLX. @@ -48,22 +50,22 @@ unfold FTZ_exp. generalize (Zlt_cases (k - prec) emin). case (Zlt_bool (k - prec) emin) ; intros H1. split ; intros H2. -omega. +lia. split. generalize (Zlt_cases (emin + prec + 1 - prec) emin). case (Zlt_bool (emin + prec + 1 - prec) emin) ; intros H3. -omega. +lia. generalize (Zlt_cases (emin + prec - 1 + 1 - prec) emin). generalize (prec_gt_0 prec). -case (Zlt_bool (emin + prec - 1 + 1 - prec) emin) ; omega. +case (Zlt_bool (emin + prec - 1 + 1 - prec) emin) ; lia. intros l H3. generalize (Zlt_cases (l - prec) emin). -case (Zlt_bool (l - prec) emin) ; omega. +case (Zlt_bool (l - prec) emin) ; lia. split ; intros H2. generalize (Zlt_cases (k + 1 - prec) emin). -case (Zlt_bool (k + 1 - prec) emin) ; omega. +case (Zlt_bool (k + 1 - prec) emin) ; lia. generalize (prec_gt_0 prec). -split ; intros ; omega. +split ; intros ; lia. Qed. Theorem FLXN_format_FTZ : @@ -94,7 +96,7 @@ rewrite Zlt_bool_false. apply Z.le_refl. rewrite Hx1, mag_F2R with (1 := Zxm). cut (prec - 1 < mag beta (IZR xm))%Z. -clear -Hx3 ; omega. +clear -Hx3 ; lia. apply mag_gt_Zpower with (1 := Zxm). apply Hx2. apply generic_format_FLXN. @@ -135,7 +137,7 @@ change (0 < F2R (Float beta (Z.abs (Ztrunc (x * bpow (- (emin + prec - 1))))) (e rewrite F2R_Zabs, <- Hx2. now apply Rabs_pos_lt. apply bpow_le. -omega. +lia. rewrite Hx2. eexists ; repeat split ; simpl. apply le_IZR. @@ -186,7 +188,7 @@ intros e He. unfold FTZ_exp. rewrite Zlt_bool_false. apply Z.le_refl. -omega. +lia. Qed. Theorem ulp_FTZ_0 : @@ -196,12 +198,12 @@ unfold ulp; rewrite Req_bool_true; trivial. case (negligible_exp_spec FTZ_exp). intros T; specialize (T (emin-1)%Z); contradict T. apply Zle_not_lt; unfold FTZ_exp; unfold Prec_gt_0 in prec_gt_0_. -rewrite Zlt_bool_true; omega. +rewrite Zlt_bool_true; lia. assert (V:(FTZ_exp (emin+prec-1) = emin+prec-1)%Z). -unfold FTZ_exp; rewrite Zlt_bool_true; omega. +unfold FTZ_exp; rewrite Zlt_bool_true; lia. intros n H2; rewrite <-V. apply f_equal, fexp_negligible_exp_eq... -omega. +lia. Qed. @@ -290,12 +292,12 @@ apply Rle_trans with (2 := proj1 He). apply bpow_le. unfold FLX_exp. generalize (prec_gt_0 prec). -clear -He' ; omega. +clear -He' ; lia. apply bpow_ge_0. unfold FLX_exp, FTZ_exp. rewrite Zlt_bool_false. apply refl_equal. -clear -He' ; omega. +clear -He' ; lia. Qed. Theorem round_FTZ_small : @@ -331,7 +333,7 @@ intros He'. elim Rlt_not_le with (1 := Hx). apply Rle_trans with (2 := proj1 He). apply bpow_le. -omega. +lia. apply bpow_ge_0. Qed. diff --git a/flocq/Core/Float_prop.v b/flocq/Core/Float_prop.v index 804dd397..a1f48d04 100644 --- a/flocq/Core/Float_prop.v +++ b/flocq/Core/Float_prop.v @@ -18,6 +18,8 @@ COPYING file for more details. *) (** * Basic properties of floating-point formats: lemmas about mantissa, exponent... *) + +From Coq Require Import Lia. Require Import Raux Defs Digits. Section Float_prop. @@ -360,7 +362,7 @@ unfold F2R. simpl. apply Rmult_le_compat_r. apply bpow_ge_0. apply IZR_le. -omega. +lia. Qed. Theorem F2R_lt_bpow : @@ -379,7 +381,7 @@ rewrite <-IZR_Zpower. 2: now apply Zle_left. now apply IZR_lt. elim Zlt_not_le with (1 := Hm). simpl. -cut (e' - e < 0)%Z. 2: omega. +cut (e' - e < 0)%Z. 2: lia. clear. case (e' - e)%Z ; try easy. intros p _. @@ -413,7 +415,7 @@ now elim (Zle_not_lt _ _ (Zabs_pos m)). (* . *) replace (e - e' + p)%Z with (e - (e' - p))%Z by ring. apply F2R_change_exp. -cut (e' - 1 < e + p)%Z. omega. +cut (e' - 1 < e + p)%Z. lia. apply (lt_bpow beta). apply Rle_lt_trans with (1 := Hf). rewrite <- F2R_Zabs, Zplus_comm, bpow_plus. @@ -472,10 +474,10 @@ assert (Hd := Zdigits_correct beta n). assert (Hd' := Zdigits_gt_0 beta n). apply Zle_antisym ; apply (bpow_lt_bpow beta). apply Rle_lt_trans with (2 := proj2 He). -rewrite <- IZR_Zpower by omega. +rewrite <- IZR_Zpower by lia. now apply IZR_le. apply Rle_lt_trans with (1 := proj1 He). -rewrite <- IZR_Zpower by omega. +rewrite <- IZR_Zpower by lia. now apply IZR_lt. Qed. diff --git a/flocq/Core/Generic_fmt.v b/flocq/Core/Generic_fmt.v index cb37bd91..af1bf3c1 100644 --- a/flocq/Core/Generic_fmt.v +++ b/flocq/Core/Generic_fmt.v @@ -18,6 +18,8 @@ COPYING file for more details. *) (** * What is a real number belonging to a format, and many properties. *) + +From Coq Require Import Lia. Require Import Raux Defs Round_pred Float_prop. Section Generic. @@ -52,7 +54,7 @@ apply Znot_ge_lt. intros Hl. apply Z.ge_le in Hl. assert (H' := proj2 (proj2 (valid_exp l) Hl) k). -omega. +lia. Qed. Theorem valid_exp_large' : @@ -67,7 +69,7 @@ apply Z.ge_le in H'. assert (Hl := Z.le_trans _ _ _ H H'). apply valid_exp in Hl. assert (H1 := proj2 Hl k H'). -omega. +lia. Qed. Definition cexp x := @@ -425,7 +427,7 @@ rewrite Gx. replace (Ztrunc (scaled_mantissa x)) with Z0. apply F2R_0. cut (Z.abs (Ztrunc (scaled_mantissa x)) < 1)%Z. -clear ; zify ; omega. +clear ; zify ; lia. apply lt_IZR. rewrite abs_IZR. now rewrite <- scaled_mantissa_generic. @@ -522,7 +524,7 @@ specialize (Ex Hxz). apply Rlt_le_trans with (1 := proj2 Ex). apply bpow_le. specialize (Hp ex). -omega. +lia. Qed. Theorem generic_format_bpow_inv' : @@ -544,7 +546,7 @@ apply bpow_gt_0. split. apply bpow_ge_0. apply (bpow_lt _ _ 0). -clear -He ; omega. +clear -He ; lia. Qed. Theorem generic_format_bpow_inv : @@ -555,7 +557,7 @@ Proof. intros e He. apply generic_format_bpow_inv' in He. assert (H := valid_exp_large' (e + 1) e). -omega. +lia. Qed. Section Fcore_generic_round_pos. @@ -587,7 +589,7 @@ rewrite <- (Zrnd_IZR (Zceil x)). apply Zrnd_le. apply Zceil_ub. rewrite Zceil_floor_neq. -omega. +lia. intros H. rewrite <- H in Hx. rewrite Zfloor_IZR, Zrnd_IZR in Hx. @@ -630,7 +632,7 @@ apply Rmult_le_compat_r. apply bpow_ge_0. assert (Hf: IZR (Zpower beta (ex - 1 - fexp ex)) = bpow (ex - 1 + - fexp ex)). apply IZR_Zpower. -omega. +lia. rewrite <- Hf. apply IZR_le. apply Zfloor_lub. @@ -657,7 +659,7 @@ apply Rmult_le_compat_r. apply bpow_ge_0. assert (Hf: IZR (Zpower beta (ex - fexp ex)) = bpow (ex - fexp ex)). apply IZR_Zpower. -omega. +lia. rewrite <- Hf. apply IZR_le. apply Zceil_glb. @@ -738,7 +740,7 @@ destruct (Zle_or_lt ex (fexp ex)) as [Hx1|Hx1]. apply bpow_le. apply valid_exp, proj2 in Hx1. specialize (Hx1 ey). - omega. + lia. apply Rle_trans with (bpow ex). now apply round_bounded_large_pos. apply bpow_le. @@ -1380,7 +1382,7 @@ specialize (He (Rgt_not_eq _ _ Hx)). rewrite Rabs_pos_eq in He. 2: now apply Rlt_le. apply Rle_trans with (bpow (ex - 1)). apply bpow_le. -cut (e < ex)%Z. omega. +cut (e < ex)%Z. lia. apply (lt_bpow beta). now apply Rle_lt_trans with (2 := proj2 He). destruct (Zle_or_lt ex (fexp ex)). @@ -1389,7 +1391,7 @@ rewrite Hr in Hd. elim Rlt_irrefl with (1 := Hd). rewrite Hr. apply bpow_le. -omega. +lia. apply (round_bounded_large_pos rnd x ex H He). Qed. @@ -1526,7 +1528,7 @@ unfold cexp. set (ex := mag beta x). generalize (exp_not_FTZ ex). generalize (proj2 (proj2 (valid_exp _) He) (fexp ex + 1)%Z). -omega. +lia. rewrite <- H. rewrite <- mult_IZR, Ztrunc_IZR. unfold F2R. simpl. @@ -1802,7 +1804,7 @@ Theorem Znearest_imp : Proof. intros x n Hd. cut (Z.abs (Znearest x - n) < 1)%Z. -clear ; zify ; omega. +clear ; zify ; lia. apply lt_IZR. rewrite abs_IZR, minus_IZR. replace (IZR (Znearest x) - IZR n)%R with (- (x - IZR (Znearest x)) + (x - IZR n))%R by ring. @@ -1937,7 +1939,7 @@ replace (- _ + _)%Z with 0%Z by ring; simpl; rewrite Rmult_1_r. apply (Rlt_le_trans _ _ _ (proj2 Hex)). apply Rle_trans with (bpow (fexp (mag beta x) - 1)). - apply bpow_le. - rewrite (mag_unique beta x ex); [omega|]. + rewrite (mag_unique beta x ex); [lia|]. now rewrite Rabs_right. - unfold Zminus; rewrite bpow_plus. rewrite Rmult_comm. @@ -2012,6 +2014,68 @@ Qed. End rndNA. +Notation Znearest0 := (Znearest (fun x => (Zlt_bool x 0))). + +Section rndN0. + +Global Instance valid_rnd_N0 : Valid_rnd Znearest0 := valid_rnd_N _. + +Theorem round_N0_pt : + forall x, + Rnd_N0_pt generic_format x (round Znearest0 x). +Proof. +intros x. +generalize (round_N_pt (fun t => Zlt_bool t 0) x). +set (f := round (Znearest (fun t => Zlt_bool t 0)) x). +intros Rxf. +destruct (Req_dec (x - round Zfloor x) (round Zceil x - x)) as [Hm|Hm]. +(* *) +apply Rnd_N0_pt_N. +apply generic_format_0. +exact Rxf. +destruct (Rle_or_lt 0 x) as [Hx|Hx]. +(* . *) +rewrite Rabs_pos_eq with (1 := Hx). +rewrite Rabs_pos_eq. +unfold f. +rewrite round_N_middle with (1 := Hm). +rewrite Zlt_bool_false. +now apply round_DN_pt. +apply Zfloor_lub. +apply Rmult_le_pos with (1 := Hx). +apply bpow_ge_0. +apply Rnd_N_pt_ge_0 with (2 := Hx) (3 := Rxf). +apply generic_format_0. +(* . *) +rewrite Rabs_left with (1 := Hx). +rewrite Rabs_left1. +apply Ropp_le_contravar. +unfold f. +rewrite round_N_middle with (1 := Hm). +rewrite Zlt_bool_true. +now apply round_UP_pt. +apply lt_IZR. +apply Rle_lt_trans with (scaled_mantissa x). +apply Zfloor_lb. +simpl. +rewrite <- (Rmult_0_l (bpow (- (cexp x))%Z)%R). +apply Rmult_lt_compat_r with (2 := Hx). +apply bpow_gt_0. +apply Rnd_N_pt_le_0 with (3 := Rxf). +apply generic_format_0. +now apply Rlt_le. +(* *) +split. +apply Rxf. +intros g Rxg. +rewrite Rnd_N_pt_unique with (3 := Hm) (4 := Rxf) (5 := Rxg). +apply Rle_refl. +apply round_DN_pt; easy. +apply round_UP_pt; easy. +Qed. + +End rndN0. + Section rndN_opp. Theorem Znearest_opp : @@ -2055,6 +2119,31 @@ rewrite opp_IZR. now rewrite Ropp_mult_distr_l_reverse. Qed. +Lemma round_N0_opp : + forall x, + (round Znearest0 (- x) = - round Znearest0 x)%R. +Proof. +intros x. +rewrite round_N_opp. +apply Ropp_eq_compat. +apply round_ext. +clear x; intro x. +unfold Znearest. +case_eq (Rcompare (x - IZR (Zfloor x)) (/ 2)); intro C; +[|reflexivity|reflexivity]. +apply Rcompare_Eq_inv in C. +assert (H : negb (- (Zfloor x + 1) <? 0)%Z = (Zfloor x <? 0)%Z); + [|now rewrite H]. +rewrite negb_Zlt_bool. +case_eq (Zfloor x <? 0)%Z; intro C'. +apply Zlt_is_lt_bool in C'. +apply Zle_bool_true. +lia. +apply Z.ltb_ge in C'. +apply Zle_bool_false. +lia. +Qed. + End rndN_opp. Lemma round_N_small : @@ -2293,10 +2382,10 @@ rewrite negb_Zle_bool. case_eq (0 <=? Zfloor x)%Z; intro C'. - apply Zle_bool_imp_le in C'. apply Zlt_bool_true. - omega. + lia. - rewrite Z.leb_gt in C'. apply Zlt_bool_false. - omega. + lia. Qed. End rndNA_opp. diff --git a/flocq/Core/Raux.v b/flocq/Core/Raux.v index 8273a55b..455190dc 100644 --- a/flocq/Core/Raux.v +++ b/flocq/Core/Raux.v @@ -18,7 +18,7 @@ COPYING file for more details. *) (** * Missing definitions/lemmas *) -Require Import Psatz. +Require Export Psatz. Require Export Reals ZArith. Require Export Zaux. @@ -907,6 +907,18 @@ rewrite Ropp_involutive. apply Zfloor_lb. Qed. +Theorem Zceil_lb : + forall x : R, + (IZR (Zceil x) < x + 1)%R. +Proof. +intros x. +unfold Zceil. +rewrite opp_IZR. +rewrite <-(Ropp_involutive (x + 1)), Ropp_plus_distr. +apply Ropp_lt_contravar, (Rplus_lt_reg_r 1); ring_simplify. +apply Zfloor_ub. +Qed. + Theorem Zceil_glb : forall n x, (x <= IZR n)%R -> @@ -1305,9 +1317,9 @@ rewrite Ropp_inv_permute with (1 := Zy'). rewrite <- 2!opp_IZR. rewrite <- Zmod_opp_opp. apply H. -clear -Hy. omega. +clear -Hy. lia. apply H. -clear -Zy Hy. omega. +clear -Zy Hy. lia. (* *) split. pattern (IZR (x / y)) at 1 ; rewrite <- Rplus_0_r. @@ -1454,7 +1466,7 @@ rewrite <- (Rmult_1_r (bpow e1)). rewrite bpow_plus. apply Rmult_lt_compat_l. apply bpow_gt_0. -assert (0 < e2 - e1)%Z by omega. +assert (0 < e2 - e1)%Z by lia. destruct (e2 - e1)%Z ; try discriminate H0. clear. rewrite <- IZR_Zpower by easy. @@ -1756,7 +1768,7 @@ rewrite Rabs_right in Hex; [|now apply Rle_ge; apply Rlt_le]. rewrite Rabs_right in Hey; [|now apply Rle_ge; apply Rlt_le]. apply (Rlt_le_trans _ _ _ Hex). apply Rle_trans with (bpow (ey - 1)); [|exact Hey]. -now apply bpow_le; omega. +now apply bpow_le; lia. Qed. Theorem mag_bpow : @@ -1900,7 +1912,7 @@ apply bpow_le. now apply Zlt_le_weak. apply IZR_le. clear -Zm. -zify ; omega. +zify ; lia. Qed. Lemma mag_mult : @@ -1999,7 +2011,7 @@ assert (Hbeta : (2 <= r)%Z). { destruct r as (beta_val,beta_prop). now apply Zle_bool_imp_le. } intros x y Px Py Hln. -assert (Oxy : (y < x)%R); [apply lt_mag;[assumption|omega]|]. +assert (Oxy : (y < x)%R); [apply lt_mag;[assumption|lia]|]. destruct (mag x) as (ex,Hex). destruct (mag y) as (ey,Hey). simpl in Hln |- *. @@ -2096,7 +2108,7 @@ split. unfold Rsqr ; rewrite <- bpow_plus. apply bpow_le. generalize (Zdiv2_odd_eqn (e + 1)). - destruct Z.odd ; intros ; omega. + destruct Z.odd ; intros ; lia. - rewrite <- (Rabs_pos_eq (bpow _)) by apply bpow_ge_0. apply Rsqr_lt_abs_0. rewrite Rsqr_sqrt by now apply Rlt_le. @@ -2104,7 +2116,7 @@ split. unfold Rsqr ; rewrite <- bpow_plus. apply bpow_le. generalize (Zdiv2_odd_eqn (e + 1)). - destruct Z.odd ; intros ; omega. + destruct Z.odd ; intros ; lia. Qed. Lemma mag_1 : mag 1 = 1%Z :> Z. @@ -2324,7 +2336,7 @@ refine (Rle_not_lt _ _ (lub (/ (INR (S N) + 1))%R _) _). refine (H _ _ Py). apply INR_lt in Hy. clear -Hy HyN. - omega. + lia. now apply Rlt_le, Rinv_0_lt_compat. rewrite S_INR, HN. ring_simplify (IZR (up (/ l)) - 1 + 1)%R. @@ -2369,7 +2381,7 @@ rewrite <- (Z.opp_involutive n). rewrite <- (Z.abs_neq n). rewrite <- Zabs2Nat.id_abs. apply K. -omega. +lia. Qed. diff --git a/flocq/Core/Round_NE.v b/flocq/Core/Round_NE.v index 20b60ef5..b7387a62 100644 --- a/flocq/Core/Round_NE.v +++ b/flocq/Core/Round_NE.v @@ -18,6 +18,8 @@ COPYING file for more details. *) (** * Rounding to nearest, ties to even: existence, unicity... *) + +From Coq Require Import Lia. Require Import Raux Defs Round_pred Generic_fmt Float_prop Ulp. Notation ZnearestE := (Znearest (fun x => negb (Z.even x))). @@ -148,7 +150,7 @@ split. apply (round_DN_pt beta fexp x). apply generic_format_bpow. ring_simplify (ex - 1 + 1)%Z. -omega. +lia. apply Hex. apply Rle_lt_trans with (2 := proj2 Hex). apply (round_DN_pt beta fexp x). @@ -209,14 +211,14 @@ rewrite Z.even_add. rewrite eqb_sym. simpl. fold (negb (Z.even (beta ^ (ex - fexp ex)))). rewrite Bool.negb_involutive. -rewrite (Z.even_pow beta (ex - fexp ex)). 2: omega. +rewrite (Z.even_pow beta (ex - fexp ex)) by lia. destruct exists_NE_. rewrite H. apply Zeven_Zpower_odd with (2 := H). now apply Zle_minus_le_0. apply Z.even_pow. specialize (H ex). -omega. +lia. (* - xu < bpow ex *) revert Hud. rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq]. @@ -413,18 +415,18 @@ now rewrite Hs in Hr. destruct (Hs ex) as (H,_). rewrite Z.even_pow. exact Hr. -omega. +lia. assert (Z.even (Zfloor mx) = true). 2: now rewrite H in Hmx. -replace (Zfloor mx) with (Zceil mx + -1)%Z by omega. +replace (Zfloor mx) with (Zceil mx + -1)%Z by lia. rewrite Z.even_add. apply eqb_true. unfold mx. replace (Zceil (scaled_mantissa beta fexp x)) with (Zpower beta (ex - fexp ex)). rewrite Zeven_Zpower_odd with (2 := Hr). easy. -omega. +lia. apply eq_IZR. -rewrite IZR_Zpower. 2: omega. +rewrite IZR_Zpower by lia. apply Rmult_eq_reg_r with (bpow (fexp ex)). unfold Zminus. rewrite bpow_plus. @@ -434,7 +436,7 @@ now apply sym_eq. apply Rgt_not_eq. apply bpow_gt_0. generalize (proj1 (valid_exp ex) He). -omega. +lia. (* .. small pos *) assert (Z.even (Zfloor mx) = true). 2: now rewrite H in Hmx. unfold mx, scaled_mantissa. diff --git a/flocq/Core/Round_pred.v b/flocq/Core/Round_pred.v index 428a4bac..b7b6778f 100644 --- a/flocq/Core/Round_pred.v +++ b/flocq/Core/Round_pred.v @@ -42,6 +42,9 @@ Definition Rnd_NG (F : R -> Prop) (P : R -> R -> Prop) (rnd : R -> R) := Definition Rnd_NA (F : R -> Prop) (rnd : R -> R) := forall x : R, Rnd_NA_pt F x (rnd x). +Definition Rnd_N0 (F : R -> Prop) (rnd : R -> R) := + forall x : R, Rnd_N0_pt F x (rnd x). + Theorem round_val_of_pred : forall rnd : R -> R -> Prop, round_pred rnd -> @@ -1021,6 +1024,251 @@ intros F x f (Hf,_) Hx. now apply Rnd_N_pt_idempotent with F. Qed. +Theorem Rnd_N0_NG_pt : + forall F : R -> Prop, + F 0 -> + forall x f, + Rnd_N0_pt F x f <-> Rnd_NG_pt F (fun x f => Rabs f <= Rabs x) x f. +Proof. +intros F HF x f. +destruct (Rle_or_lt 0 x) as [Hx|Hx]. +(* *) +split ; intros (H1, H2). +(* . *) +assert (Hf := Rnd_N_pt_ge_0 F HF x f Hx H1). +split. +exact H1. +destruct (Rnd_N_pt_DN_or_UP _ _ _ H1) as [H3|H3]. +(* . . *) +left. +rewrite Rabs_pos_eq with (1 := Hf). +rewrite Rabs_pos_eq with (1 := Hx). +apply H3. +(* . . *) +right. +intros f2 Hxf2. +specialize (H2 _ Hxf2). +destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf2) as [H4|H4]. +apply Rle_antisym. +apply Rle_trans with x. +apply H4. +apply H3. +rewrite Rabs_pos_eq with (1 := Hf) in H2. +rewrite Rabs_pos_eq in H2. +exact H2. +now apply Rnd_N_pt_ge_0 with F x. +eapply Rnd_UP_pt_unique ; eassumption. +(* . *) +split. +exact H1. +intros f2 Hxf2. +destruct H2 as [H2|H2]. +assert (Hf := Rnd_N_pt_ge_0 F HF x f Hx H1). +assert (Hf2 := Rnd_N_pt_ge_0 F HF x f2 Hx Hxf2). +rewrite 2!Rabs_pos_eq ; trivial. +rewrite 2!Rabs_pos_eq in H2 ; trivial. +destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf2) as [H3|H3]. +apply H3. +apply H1. +apply H2. +apply Rle_trans with (1 := H2). +apply H3. +rewrite (H2 _ Hxf2). +apply Rle_refl. +(* *) +assert (Hx' := Rlt_le _ _ Hx). +clear Hx. rename Hx' into Hx. +split ; intros (H1, H2). +(* . *) +assert (Hf := Rnd_N_pt_le_0 F HF x f Hx H1). +split. +exact H1. +destruct (Rnd_N_pt_DN_or_UP _ _ _ H1) as [H3|H3]. +(* . . *) +right. +intros f2 Hxf2. +specialize (H2 _ Hxf2). +destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf2) as [H4|H4]. +eapply Rnd_DN_pt_unique ; eassumption. +apply Rle_antisym. +2: apply Rle_trans with x. +2: apply H3. +2: apply H4. +rewrite Rabs_left1 with (1 := Hf) in H2. +rewrite Rabs_left1 in H2. +now apply Ropp_le_cancel. +now apply Rnd_N_pt_le_0 with F x. +(* . . *) +left. +rewrite Rabs_left1 with (1 := Hf). +rewrite Rabs_left1 with (1 := Hx). +apply Ropp_le_contravar. +apply H3. +(* . *) +split. +exact H1. +intros f2 Hxf2. +destruct H2 as [H2|H2]. +assert (Hf := Rnd_N_pt_le_0 F HF x f Hx H1). +assert (Hf2 := Rnd_N_pt_le_0 F HF x f2 Hx Hxf2). +rewrite 2!Rabs_left1 ; trivial. +rewrite 2!Rabs_left1 in H2 ; trivial. +apply Ropp_le_contravar. +apply Ropp_le_cancel in H2. +destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf2) as [H3|H3]. +2: apply H3. +2: apply H1. +2: apply H2. +apply Rle_trans with (2 := H2). +apply H3. +rewrite (H2 _ Hxf2). +apply Rle_refl. +Qed. + +Lemma Rnd_N0_pt_unique_prop : + forall F : R -> Prop, + F 0 -> + Rnd_NG_pt_unique_prop F (fun x f => Rabs f <= Rabs x). +Proof. +intros F HF x d u Hxd1 Hxd2 Hxu1 Hxu2 Hd Hu. +apply Rle_antisym. +apply Rle_trans with x. +apply Hxd1. +apply Hxu1. +destruct (Rle_or_lt 0 x) as [Hx|Hx]. +apply Hxd1. +apply Hxu1. +rewrite Rabs_pos_eq with (1 := Hx) in Hu. +rewrite Rabs_pos_eq in Hu. +exact Hu. +apply Rle_trans with (1:=Hx). +apply Hxu1. +(* *) +apply Hxu1. +apply Hxd1. +rewrite Rabs_left with (1 := Hx) in Hd. +rewrite Rabs_left1 in Hd. +now apply Ropp_le_cancel. +apply Rlt_le, Rle_lt_trans with (2:=Hx). +apply Hxd1. +Qed. + +Theorem Rnd_N0_pt_unique : + forall F : R -> Prop, + F 0 -> + forall x f1 f2 : R, + Rnd_N0_pt F x f1 -> Rnd_N0_pt F x f2 -> + f1 = f2. +Proof. +intros F HF x f1 f2 H1 H2. +apply (Rnd_NG_pt_unique F _ (Rnd_N0_pt_unique_prop F HF) x). +now apply -> Rnd_N0_NG_pt. +now apply -> Rnd_N0_NG_pt. +Qed. + +Theorem Rnd_N0_pt_N : + forall F : R -> Prop, + F 0 -> + forall x f : R, + Rnd_N_pt F x f -> + (Rabs f <= Rabs x)%R -> + Rnd_N0_pt F x f. +Proof. +intros F HF x f Rxf Hxf. +split. +apply Rxf. +intros g Rxg. +destruct (Rabs_eq_Rabs (f - x) (g - x)) as [H|H]. +apply Rle_antisym. +apply Rxf. +apply Rxg. +apply Rxg. +apply Rxf. +(* *) +replace g with f. +apply Rle_refl. +apply Rplus_eq_reg_r with (1 := H). +(* *) +assert (g = 2 * x - f)%R. +replace (2 * x - f)%R with (x - (f - x))%R by ring. +rewrite H. +ring. +destruct (Rle_lt_dec 0 x) as [Hx|Hx]. +(* . *) +revert Hxf. +rewrite Rabs_pos_eq with (1 := Hx). +rewrite 2!Rabs_pos_eq ; try ( apply (Rnd_N_pt_ge_0 F HF x) ; assumption ). +intros Hxf. +rewrite H0. +apply Rplus_le_reg_r with f. +ring_simplify. +apply Rmult_le_compat_l with (2 := Hxf). +now apply IZR_le. +(* . *) +revert Hxf. +apply Rlt_le in Hx. +rewrite Rabs_left1 with (1 := Hx). +rewrite 2!Rabs_left1 ; try ( apply (Rnd_N_pt_le_0 F HF x) ; assumption ). +intros Hxf. +rewrite H0. +apply Ropp_le_contravar. +apply Rplus_le_reg_r with f. +ring_simplify. +apply Rmult_le_compat_l. +now apply IZR_le. +now apply Ropp_le_cancel. +Qed. + +Theorem Rnd_N0_unique : + forall (F : R -> Prop), + F 0 -> + forall rnd1 rnd2 : R -> R, + Rnd_N0 F rnd1 -> Rnd_N0 F rnd2 -> + forall x, rnd1 x = rnd2 x. +Proof. +intros F HF rnd1 rnd2 H1 H2 x. +now apply Rnd_N0_pt_unique with F x. +Qed. + +Theorem Rnd_N0_pt_monotone : + forall F : R -> Prop, + F 0 -> + round_pred_monotone (Rnd_N0_pt F). +Proof. +intros F HF x y f g Hxf Hyg Hxy. +apply (Rnd_NG_pt_monotone F _ (Rnd_N0_pt_unique_prop F HF) x y). +now apply -> Rnd_N0_NG_pt. +now apply -> Rnd_N0_NG_pt. +exact Hxy. +Qed. + +Theorem Rnd_N0_pt_refl : + forall F : R -> Prop, + forall x : R, F x -> + Rnd_N0_pt F x x. +Proof. +intros F x Hx. +split. +now apply Rnd_N_pt_refl. +intros f Hxf. +apply Req_le. +apply f_equal. +now apply sym_eq, Rnd_N_pt_idempotent with (1 := Hxf). +Qed. + +Theorem Rnd_N0_pt_idempotent : + forall F : R -> Prop, + forall x f : R, + Rnd_N0_pt F x f -> F x -> + f = x. +Proof. +intros F x f (Hf,_) Hx. +now apply Rnd_N_pt_idempotent with F. +Qed. + + + + Theorem round_pred_ge_0 : forall P : R -> R -> Prop, round_pred_monotone P -> @@ -1405,4 +1653,38 @@ apply Rnd_NA_pt_monotone. apply Hany. Qed. +Theorem satisfies_any_imp_N0 : + forall F : R -> Prop, + F 0 -> satisfies_any F -> + round_pred (Rnd_N0_pt F). +Proof. +intros F HF0 Hany. +split. +assert (H : round_pred_total (Rnd_NG_pt F (fun a b => (Rabs b <= Rabs a)%R))). +apply satisfies_any_imp_NG. +apply Hany. +intros x d u Hf Hd Hu. +destruct (Rle_lt_dec 0 x) as [Hx|Hx]. +right. +rewrite Rabs_pos_eq with (1 := Hx). +rewrite Rabs_pos_eq. +apply Hd. +apply Hd; try easy. +left. +rewrite Rabs_left with (1 := Hx). +rewrite Rabs_left1. +apply Ropp_le_contravar. +apply Hu. +apply Hu; try easy. +now apply Rlt_le. +intros x. +destruct (H x) as (f, Hf). +exists f. +apply <- Rnd_N0_NG_pt. +apply Hf. +apply HF0. +apply Rnd_N0_pt_monotone. +apply HF0. +Qed. + End RND_prop. diff --git a/flocq/Core/Ulp.v b/flocq/Core/Ulp.v index 4f4a5674..c42b3e65 100644 --- a/flocq/Core/Ulp.v +++ b/flocq/Core/Ulp.v @@ -57,7 +57,7 @@ Proof. unfold negligible_exp; destruct LPO_Z as [(n,Hn)|Hn]. now apply negligible_Some. apply negligible_None. -intros n; specialize (Hn n); omega. +intros n; specialize (Hn n); lia. Qed. Lemma negligible_exp_spec': (negligible_exp = None /\ forall n, (fexp n < n)%Z) @@ -66,7 +66,7 @@ Proof. unfold negligible_exp; destruct LPO_Z as [(n,Hn)|Hn]. right; simpl; exists n; now split. left; split; trivial. -intros n; specialize (Hn n); omega. +intros n; specialize (Hn n); lia. Qed. Context { valid_exp : Valid_exp fexp }. @@ -75,8 +75,8 @@ Lemma fexp_negligible_exp_eq: forall n m, (n <= fexp n)%Z -> (m <= fexp m)%Z -> Proof. intros n m Hn Hm. case (Zle_or_lt n m); intros H. -apply valid_exp; omega. -apply sym_eq, valid_exp; omega. +apply valid_exp; lia. +apply sym_eq, valid_exp; lia. Qed. @@ -198,6 +198,17 @@ rewrite V. apply generic_format_0. Qed. +Theorem ulp_canonical : + forall m e, + m <> 0%Z -> + canonical beta fexp (Float beta m e) -> + ulp (F2R (Float beta m e)) = bpow e. +Proof. +intros m e Hm Hc. +rewrite ulp_neq_0 by now apply F2R_neq_0. +apply f_equal. +now apply sym_eq. +Qed. Theorem ulp_bpow : forall e, ulp (bpow e) = bpow (fexp (e + 1)). @@ -216,7 +227,6 @@ apply bpow_ge_0. apply Rgt_not_eq, Rlt_gt, bpow_gt_0. Qed. - Lemma generic_format_ulp_0 : F (ulp 0). Proof. @@ -238,17 +248,17 @@ rewrite Req_bool_true; trivial. case negligible_exp_spec. intros H1 _. apply generic_format_bpow. -specialize (H1 (e+1)%Z); omega. +specialize (H1 (e+1)%Z); lia. intros n H1 H2. apply generic_format_bpow. case (Zle_or_lt (e+1) (fexp (e+1))); intros H4. absurd (e+1 <= e)%Z. -omega. +lia. apply Z.le_trans with (1:=H4). replace (fexp (e+1)) with (fexp n). now apply le_bpow with beta. now apply fexp_negligible_exp_eq. -omega. +lia. Qed. (** The three following properties are equivalent: @@ -300,10 +310,10 @@ case (Zle_or_lt l (fexp l)); intros Hl. rewrite (fexp_negligible_exp_eq n l); trivial; apply Z.le_refl. case (Zle_or_lt (fexp n) (fexp l)); trivial; intros K. absurd (fexp n <= fexp l)%Z. -omega. +lia. apply Z.le_trans with (2:= H _). apply Zeq_le, sym_eq, valid_exp; trivial. -omega. +lia. Qed. Lemma not_FTZ_ulp_ge_ulp_0: @@ -374,8 +384,6 @@ rewrite Hn1 in H; discriminate. now apply bpow_mag_le. Qed. - - (** Definition and properties of pred and succ *) Definition pred_pos x := @@ -432,6 +440,17 @@ unfold pred. now rewrite Ropp_involutive. Qed. +Theorem pred_bpow : + forall e, pred (bpow e) = (bpow e - bpow (fexp e))%R. +Proof. +intros e. +rewrite pred_eq_pos by apply bpow_ge_0. +unfold pred_pos. +rewrite mag_bpow. +replace (e + 1 - 1)%Z with e by ring. +now rewrite Req_bool_true. +Qed. + (** pred and succ are in the format *) (* cannont be x <> ulp 0, due to the counter-example 1-bit FP format fexp: e -> e-1 *) @@ -450,7 +469,7 @@ apply gt_0_F2R with beta (cexp beta fexp x). rewrite <- Fx. apply Rle_lt_trans with (2:=Hx). apply bpow_ge_0. -omega. +lia. case (Zle_lt_or_eq _ _ H); intros Hm. (* *) pattern x at 1 ; rewrite Fx. @@ -533,7 +552,7 @@ rewrite ulp_neq_0. intro H. assert (ex-1 < cexp beta fexp x < ex)%Z. split ; apply (lt_bpow beta) ; rewrite <- H ; easy. -clear -H0. omega. +clear -H0. lia. now apply Rgt_not_eq. apply Ex'. apply Rle_lt_trans with (2 := proj2 Ex'). @@ -555,7 +574,7 @@ apply gt_0_F2R with beta (cexp beta fexp x). rewrite <- Fx. apply Rle_lt_trans with (2:=proj1 Ex'). apply bpow_ge_0. -omega. +lia. now apply Rgt_not_eq. Qed. @@ -579,7 +598,7 @@ rewrite minus_IZR, IZR_Zpower. rewrite Rmult_minus_distr_r, Rmult_1_l. rewrite <- bpow_plus. now replace (e - 1 - fexp (e - 1) + fexp (e - 1))%Z with (e-1)%Z by ring. -omega. +lia. rewrite H. apply generic_format_F2R. intros _. @@ -592,7 +611,7 @@ split. apply Rplus_le_reg_l with (bpow (fexp (e-1))). ring_simplify. apply Rle_trans with (bpow (e - 2) + bpow (e - 2))%R. -apply Rplus_le_compat ; apply bpow_le ; omega. +apply Rplus_le_compat ; apply bpow_le ; lia. apply Rle_trans with (2*bpow (e - 2))%R;[right; ring|idtac]. apply Rle_trans with (bpow 1*bpow (e - 2))%R. apply Rmult_le_compat_r. @@ -614,7 +633,7 @@ apply Ropp_lt_contravar. apply bpow_gt_0. apply Rle_ge; apply Rle_0_minus. apply bpow_le. -omega. +lia. replace f with 0%R. apply generic_format_0. unfold f. @@ -842,7 +861,7 @@ assert (ex - 1 < fexp ex < ex)%Z. split ; apply (lt_bpow beta) ; rewrite <- M by easy. lra. apply Hex. -omega. +lia. rewrite 2!ulp_neq_0 by lra. apply f_equal. unfold cexp ; apply f_equal. @@ -907,7 +926,7 @@ split. apply Rplus_le_reg_l with (bpow (fexp (e-1))). ring_simplify. apply Rle_trans with (bpow (e - 2) + bpow (e - 2))%R. -apply Rplus_le_compat; apply bpow_le; omega. +apply Rplus_le_compat; apply bpow_le; lia. apply Rle_trans with (2*bpow (e - 2))%R;[right; ring|idtac]. apply Rle_trans with (bpow 1*bpow (e - 2))%R. apply Rmult_le_compat_r. @@ -930,7 +949,7 @@ apply bpow_gt_0. apply Rle_ge; apply Rle_0_minus. rewrite Hxe. apply bpow_le. -omega. +lia. (* *) contradict Zp. rewrite Hxe, He; ring. @@ -953,12 +972,12 @@ unfold ulp; rewrite Req_bool_true; trivial. case negligible_exp_spec. intros K. specialize (K (e-1)%Z). -contradict K; omega. +contradict K; lia. intros n Hn. rewrite H3; apply f_equal. case (Zle_or_lt n (e-1)); intros H6. -apply valid_exp; omega. -apply sym_eq, valid_exp; omega. +apply valid_exp; lia. +apply sym_eq, valid_exp; lia. Qed. (** The following one is false for x = 0 in FTZ *) @@ -1081,7 +1100,7 @@ exfalso ; lra. intros n Hn H. assert (fexp (mag beta eps) = fexp n). apply valid_exp; try assumption. -assert(mag beta eps-1 < fexp n)%Z;[idtac|omega]. +assert(mag beta eps-1 < fexp n)%Z;[idtac|lia]. apply lt_bpow with beta. apply Rle_lt_trans with (2:=proj2 H). destruct (mag beta eps) as (e,He). @@ -1105,7 +1124,6 @@ rewrite <- P, round_0; trivial. apply valid_rnd_DN. Qed. - Theorem round_UP_plus_eps_pos : forall x, (0 <= x)%R -> F x -> forall eps, (0 < eps <= ulp x)%R -> @@ -1147,7 +1165,7 @@ lra. intros n Hn H. assert (fexp (mag beta eps) = fexp n). apply valid_exp; try assumption. -assert(mag beta eps-1 < fexp n)%Z;[idtac|omega]. +assert(mag beta eps-1 < fexp n)%Z;[idtac|lia]. apply lt_bpow with beta. apply Rle_lt_trans with (2:=H). destruct (mag beta eps) as (e,He). @@ -1172,7 +1190,6 @@ apply round_generic... apply generic_format_ulp_0. Qed. - Theorem round_UP_pred_plus_eps_pos : forall x, (0 < x)%R -> F x -> forall eps, (0 < eps <= ulp (pred x) )%R -> @@ -1210,7 +1227,6 @@ apply Ropp_lt_contravar. now apply Heps. Qed. - Theorem round_DN_plus_eps: forall x, F x -> forall eps, (0 <= eps < if (Rle_bool 0 x) then (ulp x) @@ -1248,7 +1264,6 @@ now apply Ropp_0_gt_lt_contravar. now apply generic_format_opp. Qed. - Theorem round_UP_plus_eps : forall x, F x -> forall eps, (0 < eps <= if (Rle_bool 0 x) then (ulp x) @@ -1334,11 +1349,11 @@ now apply Rgt_not_eq. case (Zle_lt_or_eq _ _ H2); intros Hexy. assert (fexp ex = fexp (ey-1))%Z. apply valid_exp. -omega. +lia. rewrite <- H1. -omega. +lia. absurd (0 < Ztrunc (scaled_mantissa beta fexp x) < 1)%Z. -omega. +lia. split. apply gt_0_F2R with beta (cexp beta fexp x). now rewrite <- Fx. @@ -1380,9 +1395,9 @@ apply sym_eq; apply mag_unique. rewrite H1, Rabs_right. split. apply bpow_le. -omega. +lia. apply bpow_lt. -omega. +lia. apply Rle_ge; apply bpow_ge_0. apply mag_unique. apply Hey. @@ -1527,7 +1542,7 @@ rewrite mag_bpow. replace (fexp n + 1 - 1)%Z with (fexp n) by ring. rewrite Req_bool_true; trivial. apply Rminus_diag_eq, f_equal. -apply sym_eq, valid_exp; omega. +apply sym_eq, valid_exp; lia. Qed. Theorem succ_0 : @@ -1904,7 +1919,7 @@ rewrite ulp_neq_0; trivial. apply f_equal. unfold cexp. apply valid_exp; trivial. -assert (mag beta x -1 < fexp n)%Z;[idtac|omega]. +assert (mag beta x -1 < fexp n)%Z;[idtac|lia]. apply lt_bpow with beta. destruct (mag beta x) as (e,He). simpl. @@ -2252,9 +2267,9 @@ rewrite Hn1; easy. now apply ulp_ge_ulp_0. Qed. - -Lemma ulp_succ_pos : forall x, F x -> (0 < x)%R -> - ulp (succ x) = ulp x \/ succ x = bpow (mag beta x). +Lemma ulp_succ_pos : + forall x, F x -> (0 < x)%R -> + ulp (succ x) = ulp x \/ succ x = bpow (mag beta x). Proof with auto with typeclass_instances. intros x Fx Hx. generalize (Rlt_le _ _ Hx); intros Hx'. @@ -2281,6 +2296,39 @@ apply ulp_ge_0. now apply sym_eq, mag_unique_pos. Qed. +Theorem ulp_pred_pos : + forall x, F x -> (0 < pred x)%R -> + ulp (pred x) = ulp x \/ x = bpow (mag beta x - 1). +Proof. +intros x Fx Hx. +assert (Hx': (0 < x)%R). + apply Rlt_le_trans with (1 := Hx). + apply pred_le_id. +assert (Zx : x <> 0%R). + now apply Rgt_not_eq. +rewrite (ulp_neq_0 x) by easy. +unfold cexp. +destruct (mag beta x) as [e He]. +simpl. +assert (bpow (e - 1) <= x < bpow e)%R. + rewrite <- (Rabs_pos_eq x) by now apply Rlt_le. + now apply He. +destruct (proj1 H) as [H1|H1]. +2: now right. +left. +apply pred_ge_gt with (2 := Fx) in H1. +rewrite ulp_neq_0 by now apply Rgt_not_eq. +apply (f_equal (fun e => bpow (fexp e))). +apply mag_unique_pos. +apply (conj H1). +apply Rle_lt_trans with (2 := proj2 H). +apply pred_le_id. +apply generic_format_bpow. +apply Z.lt_le_pred. +replace (_ + 1)%Z with e by ring. +rewrite <- (mag_unique_pos _ _ _ H). +now apply mag_generic_gt. +Qed. Lemma ulp_round_pos : forall { Not_FTZ_ : Exp_not_FTZ fexp}, @@ -2333,7 +2381,6 @@ replace (fexp n) with (fexp e); try assumption. now apply fexp_negligible_exp_eq. Qed. - Theorem ulp_round : forall { Not_FTZ_ : Exp_not_FTZ fexp}, forall rnd { Zrnd : Valid_rnd rnd } x, ulp (round beta fexp rnd x) = ulp x @@ -2373,6 +2420,18 @@ destruct (round_DN_or_UP beta fexp rnd x) as [Hr|Hr]; rewrite Hr. apply succ_ge_id. Qed. +Lemma pred_round_le_id : + forall rnd { Zrnd : Valid_rnd rnd } x, + (pred (round beta fexp rnd x) <= x)%R. +Proof. +intros rnd Vrnd x. +apply (Rle_trans _ (round beta fexp Raux.Zfloor x)). +2: now apply round_DN_pt. +destruct (round_DN_or_UP beta fexp rnd x) as [Hr|Hr]; rewrite Hr. +2: now apply pred_UP_le_DN. +apply pred_le_id. +Qed. + (** Properties of rounding to nearest and ulp *) Theorem round_N_le_midp: forall choice u v, @@ -2432,6 +2491,73 @@ unfold pred. right; field. Qed. +Lemma round_N_ge_ge_midp : forall choice u v, + F u -> + (u <= round beta fexp (Znearest choice) v)%R -> + ((u + pred u) / 2 <= v)%R. +Proof with auto with typeclass_instances. +intros choice u v Hu H2. +assert (K: ((u=0)%R /\ negligible_exp = None) \/ (pred u < u)%R). +case (Req_dec u 0); intros Zu. +case_eq (negligible_exp). +intros n Hn; right. +rewrite Zu, pred_0. +unfold ulp; rewrite Req_bool_true, Hn; try easy. +rewrite <- Ropp_0. +apply Ropp_lt_contravar, bpow_gt_0. +intros _; left; split; easy. +right. +apply pred_lt_id... +(* *) +case K. +intros (K1,K2). +(* . *) +rewrite K1, pred_0. +unfold ulp; rewrite Req_bool_true, K2; try easy. +replace ((0+-0)/2)%R with 0%R by field. +case (Rle_or_lt 0 v); try easy. +intros H3; contradict H2. +rewrite K1; apply Rlt_not_le. +assert (H4: (round beta fexp (Znearest choice) v <= 0)%R). +apply round_le_generic... +apply generic_format_0... +now left. +case H4; try easy. +intros H5. +absurd (v=0)%R; try auto with real. +apply eq_0_round_0_negligible_exp with (Znearest choice)... +(* . *) +intros K1. +case (Rle_or_lt ((u + pred u) / 2) v); try easy. +intros H3. +absurd (u <= round beta fexp (Znearest choice) v)%R; try easy. +apply Rlt_not_le. +apply Rle_lt_trans with (2:=K1). +apply round_N_le_midp... +apply generic_format_pred... +rewrite succ_pred... +apply Rlt_le_trans with (1:=H3). +right; f_equal; ring. +Qed. + + +Lemma round_N_le_le_midp : forall choice u v, + F u -> + (round beta fexp (Znearest choice) v <= u)%R -> + (v <= (u + succ u) / 2)%R. +Proof with auto with typeclass_instances. +intros choice u v Hu H2. +apply Ropp_le_cancel. +apply Rle_trans with (((-u)+pred (-u))/2)%R. +rewrite pred_opp; right; field. +apply round_N_ge_ge_midp with + (choice := fun t:Z => negb (choice (- (t + 1))%Z))... +apply generic_format_opp... +rewrite <- (Ropp_involutive (round _ _ _ _)). +rewrite <- round_N_opp, Ropp_involutive. +apply Ropp_le_contravar; easy. +Qed. + Lemma round_N_eq_DN: forall choice x, let d:=round beta fexp Zfloor x in @@ -2518,4 +2644,18 @@ rewrite round_generic; [now apply succ_le_plus_ulp|now simpl|]. now apply generic_format_plus_ulp, generic_format_round. Qed. + +Lemma round_N_eq_ties: forall c1 c2 x, + (x - round beta fexp Zfloor x <> round beta fexp Zceil x - x)%R -> + (round beta fexp (Znearest c1) x = round beta fexp (Znearest c2) x)%R. +Proof with auto with typeclass_instances. +intros c1 c2 x. +pose (d:=round beta fexp Zfloor x); pose (u:=round beta fexp Zceil x); fold d; fold u; intros H. +case (Rle_or_lt ((d+u)/2) x); intros L. +2:rewrite 2!round_N_eq_DN... +destruct L as [L|L]. +rewrite 2!round_N_eq_UP... +contradict H; rewrite <- L; field. +Qed. + End Fcore_ulp. diff --git a/flocq/Core/Zaux.v b/flocq/Core/Zaux.v index e21d93a4..b40b0c4f 100644 --- a/flocq/Core/Zaux.v +++ b/flocq/Core/Zaux.v @@ -17,8 +17,12 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the COPYING file for more details. *) -Require Import ZArith Omega. -Require Import Zquot. +From Coq Require Import ZArith Lia Zquot. + +Require Import SpecFloatCompat. + +Notation cond_Zopp := cond_Zopp (only parsing). +Notation iter_pos := iter_pos (only parsing). Section Zmissing. @@ -262,7 +266,7 @@ apply Z.le_refl. split. easy. apply Zpower_gt_1. -clear -He ; omega. +clear -He ; lia. apply Zle_minus_le_0. now apply Zlt_le_weak. revert H1. @@ -282,7 +286,7 @@ apply Znot_gt_le. intros H. apply Zlt_not_le with (1 := He). apply Zpower_le. -clear -H ; omega. +clear -H ; lia. Qed. Theorem Zpower_gt_id : @@ -302,7 +306,7 @@ clear. apply Zlt_0_minus_lt. replace (r * (Z_of_nat n0 + 1) - (Z_of_nat n0 + 1))%Z with ((r - 1) * (Z_of_nat n0 + 1))%Z by ring. apply Zmult_lt_0_compat. -cut (2 <= r)%Z. omega. +cut (2 <= r)%Z. lia. apply Zle_bool_imp_le. apply r. apply (Zle_lt_succ 0). @@ -420,7 +424,7 @@ apply Z.opp_inj. rewrite <- Zquot_opp_l, Z.opp_0. apply Z.quot_small. generalize (Zabs_non_eq a). -omega. +lia. Qed. Theorem ZOmod_small_abs : @@ -437,7 +441,7 @@ apply Z.opp_inj. rewrite <- Zrem_opp_l. apply Z.rem_small. generalize (Zabs_non_eq a). -omega. +lia. Qed. Theorem ZOdiv_plus : @@ -702,8 +706,6 @@ End Zcompare. Section cond_Zopp. -Definition cond_Zopp (b : bool) m := if b then Z.opp m else m. - Theorem cond_Zopp_negb : forall x y, cond_Zopp (negb x) y = Z.opp (cond_Zopp x y). Proof. @@ -921,16 +923,9 @@ intros x. apply IHp. Qed. -Fixpoint iter_pos (n : positive) (x : A) {struct n} : A := - match n with - | xI n' => iter_pos n' (iter_pos n' (f x)) - | xO n' => iter_pos n' (iter_pos n' x) - | xH => f x - end. - Lemma iter_pos_nat : forall (p : positive) (x : A), - iter_pos p x = iter_nat (Pos.to_nat p) x. + iter_pos f p x = iter_nat (Pos.to_nat p) x. Proof. induction p ; intros x. rewrite Pos2Nat.inj_xI. diff --git a/flocq/IEEE754/Binary.v b/flocq/IEEE754/Binary.v index ac38c761..35d15cb3 100644 --- a/flocq/IEEE754/Binary.v +++ b/flocq/IEEE754/Binary.v @@ -627,6 +627,52 @@ Proof. now rewrite Pcompare_antisym. Qed. +Theorem bounded_le_emax_minus_prec : + forall mx ex, + bounded mx ex = true -> + (F2R (Float radix2 (Zpos mx) ex) + <= bpow radix2 emax - bpow radix2 (emax - prec))%R. +Proof. +intros mx ex Hx. +destruct (andb_prop _ _ Hx) as (H1,H2). +generalize (Zeq_bool_eq _ _ H1). clear H1. intro H1. +generalize (Zle_bool_imp_le _ _ H2). clear H2. intro H2. +generalize (mag_F2R_Zdigits radix2 (Zpos mx) ex). +destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as (e',Ex). +unfold mag_val. +intros H. +elim Ex; [|now apply Rgt_not_eq, F2R_gt_0]; intros _. +rewrite <-F2R_Zabs; simpl; clear Ex; intros Ex. +generalize (Rmult_lt_compat_r (bpow radix2 (-ex)) _ _ (bpow_gt_0 _ _) Ex). +unfold F2R; simpl; rewrite Rmult_assoc, <-!bpow_plus. +rewrite H; [|intro H'; discriminate H']. +rewrite <-Z.add_assoc, Z.add_opp_diag_r, Z.add_0_r, Rmult_1_r. +rewrite <-(IZR_Zpower _ _ (Zdigits_ge_0 _ _)); clear Ex; intro Ex. +generalize (Zlt_le_succ _ _ (lt_IZR _ _ Ex)); clear Ex; intro Ex. +generalize (IZR_le _ _ Ex). +rewrite succ_IZR; clear Ex; intro Ex. +generalize (Rplus_le_compat_r (-1) _ _ Ex); clear Ex; intro Ex. +ring_simplify in Ex; revert Ex. +rewrite (IZR_Zpower _ _ (Zdigits_ge_0 _ _)); intro Ex. +generalize (Rmult_le_compat_r (bpow radix2 ex) _ _ (bpow_ge_0 _ _) Ex). +intro H'; apply (Rle_trans _ _ _ H'). +rewrite Rmult_minus_distr_r, Rmult_1_l, <-bpow_plus. +revert H1; unfold fexp, FLT_exp; intro H1. +generalize (Z.le_max_l (Z.pos (digits2_pos mx) + ex - prec) emin). +rewrite H1; intro H1'. +generalize (proj1 (Z.le_sub_le_add_r _ _ _) H1'). +rewrite Zpos_digits2_pos; clear H1'; intro H1'. +apply (Rle_trans _ _ _ (Rplus_le_compat_r _ _ _ (bpow_le _ _ _ H1'))). +replace emax with (emax - prec - ex + (ex + prec))%Z at 1 by ring. +replace (emax - prec)%Z with (emax - prec - ex + ex)%Z at 2 by ring. +do 2 rewrite (bpow_plus _ (emax - prec - ex)). +rewrite <-Rmult_minus_distr_l. +rewrite <-(Rmult_1_l (_ + _)). +apply Rmult_le_compat_r. +{ apply Rle_0_minus, bpow_le; unfold Prec_gt_0 in prec_gt_0_; lia. } +change 1%R with (bpow radix2 0); apply bpow_le; lia. +Qed. + Theorem bounded_lt_emax : forall mx ex, bounded mx ex = true -> @@ -651,7 +697,7 @@ rewrite H. 2: discriminate. revert H1. clear -H2. rewrite Zpos_digits2_pos. unfold fexp, FLT_exp. -intros ; zify ; omega. +intros ; zify ; lia. Qed. Theorem bounded_ge_emin : @@ -679,7 +725,18 @@ unfold fexp, FLT_exp. clear -prec_gt_0_. unfold Prec_gt_0 in prec_gt_0_. clearbody emin. -intros ; zify ; omega. +intros ; zify ; lia. +Qed. + +Theorem abs_B2R_le_emax_minus_prec : + forall x, + (Rabs (B2R x) <= bpow radix2 emax - bpow radix2 (emax - prec))%R. +Proof. +intros [sx|sx|sx plx Hx|sx mx ex Hx] ; simpl ; + [rewrite Rabs_R0 ; apply Rle_0_minus, bpow_le ; + revert prec_gt_0_; unfold Prec_gt_0; lia..|]. +rewrite <- F2R_Zabs, abs_cond_Zopp. +now apply bounded_le_emax_minus_prec. Qed. Theorem abs_B2R_lt_emax : @@ -728,7 +785,7 @@ rewrite Cx. unfold cexp, fexp, FLT_exp. destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as (e',Ex). simpl. apply Z.max_lub. -cut (e' - 1 < emax)%Z. clear ; omega. +cut (e' - 1 < emax)%Z. clear ; lia. apply lt_bpow with radix2. apply Rle_lt_trans with (2 := Bx). change (Zpos mx) with (Z.abs (Zpos mx)). @@ -738,7 +795,7 @@ apply Rgt_not_eq. now apply F2R_gt_0. unfold emin. generalize (prec_gt_0 prec). -clear -Hmax ; omega. +clear -Hmax ; lia. Qed. (** Truncation *) @@ -889,7 +946,7 @@ now inversion H. (* *) intros p Hp. assert (He: (e <= fexp (Zdigits radix2 m + e))%Z). -clear -Hp ; zify ; omega. +clear -Hp ; zify ; lia. destruct (inbetween_float_ex radix2 m e l) as (x, Hx). generalize (inbetween_shr x m e l (fexp (Zdigits radix2 m + e) - e) Hm Hx). assert (Hx0 : (0 <= x)%R). @@ -1091,18 +1148,18 @@ rewrite Zpos_digits2_pos. replace (Zdigits radix2 (Zpos (match (Zpower 2 prec - 1)%Z with Zpos p => p | _ => xH end))) with prec. unfold fexp, FLT_exp, emin. generalize (prec_gt_0 prec). -clear -Hmax ; zify ; omega. +clear -Hmax ; zify ; lia. change 2%Z with (radix_val radix2). case_eq (Zpower radix2 prec - 1)%Z. simpl Zdigits. generalize (Zpower_gt_1 radix2 prec (prec_gt_0 prec)). -clear ; omega. +clear ; lia. intros p Hp. apply Zle_antisym. -cut (prec - 1 < Zdigits radix2 (Zpos p))%Z. clear ; omega. +cut (prec - 1 < Zdigits radix2 (Zpos p))%Z. clear ; lia. apply Zdigits_gt_Zpower. simpl Z.abs. rewrite <- Hp. -cut (Zpower radix2 (prec - 1) < Zpower radix2 prec)%Z. clear ; omega. +cut (Zpower radix2 (prec - 1) < Zpower radix2 prec)%Z. clear ; lia. apply lt_IZR. rewrite 2!IZR_Zpower. 2: now apply Zlt_le_weak. apply bpow_lt. @@ -1113,7 +1170,7 @@ simpl Z.abs. rewrite <- Hp. apply Zlt_pred. intros p Hp. generalize (Zpower_gt_1 radix2 _ (prec_gt_0 prec)). -clear -Hp ; zify ; omega. +clear -Hp ; zify ; lia. apply Rnot_lt_le. intros Hx. generalize (refl_equal (bounded m2 e2)). @@ -1271,18 +1328,18 @@ rewrite Zpos_digits2_pos. replace (Zdigits radix2 (Zpos (match (Zpower 2 prec - 1)%Z with Zpos p => p | _ => xH end))) with prec. unfold fexp, FLT_exp, emin. generalize (prec_gt_0 prec). -clear -Hmax ; zify ; omega. +clear -Hmax ; zify ; lia. change 2%Z with (radix_val radix2). case_eq (Zpower radix2 prec - 1)%Z. simpl Zdigits. generalize (Zpower_gt_1 radix2 prec (prec_gt_0 prec)). -clear ; omega. +clear ; lia. intros p Hp. apply Zle_antisym. -cut (prec - 1 < Zdigits radix2 (Zpos p))%Z. clear ; omega. +cut (prec - 1 < Zdigits radix2 (Zpos p))%Z. clear ; lia. apply Zdigits_gt_Zpower. simpl Z.abs. rewrite <- Hp. -cut (Zpower radix2 (prec - 1) < Zpower radix2 prec)%Z. clear ; omega. +cut (Zpower radix2 (prec - 1) < Zpower radix2 prec)%Z. clear ; lia. apply lt_IZR. rewrite 2!IZR_Zpower. 2: now apply Zlt_le_weak. apply bpow_lt. @@ -1293,7 +1350,7 @@ simpl Z.abs. rewrite <- Hp. apply Zlt_pred. intros p Hp. generalize (Zpower_gt_1 radix2 _ (prec_gt_0 prec)). -clear -Hp ; zify ; omega. +clear -Hp ; zify ; lia. apply Rnot_lt_le. intros Hx. generalize (refl_equal (bounded m2 e2)). @@ -1370,7 +1427,7 @@ clear -Hmax. unfold emin. intros dx dy dxy Hx Hy Hxy. zify ; intros ; subst. -omega. +lia. (* *) case sx ; case sy. apply Rlt_bool_false. @@ -1479,7 +1536,7 @@ case_eq (ex' - ex)%Z ; simpl. intros H. now rewrite Zminus_eq with (1 := H). intros p. -clear -He ; zify ; omega. +clear -He ; zify ; lia. intros. apply refl_equal. Qed. @@ -1580,7 +1637,7 @@ now rewrite is_finite_FF2B. rewrite Bsign_FF2B, Rz''. rewrite Rcompare_Gt... apply F2R_gt_0. -simpl. zify; omega. +simpl. zify; lia. intros Hz' (Vz, Rz). rewrite B2FF_FF2B, Rz. apply f_equal. @@ -1599,7 +1656,7 @@ now rewrite is_finite_FF2B. rewrite Bsign_FF2B, Rz''. rewrite Rcompare_Lt... apply F2R_lt_0. -simpl. zify; omega. +simpl. zify; lia. intros Hz' (Vz, Rz). rewrite B2FF_FF2B, Rz. apply f_equal. @@ -2150,7 +2207,7 @@ set (e' := Z.min _ _). assert (2 * e' <= ex)%Z as He. { assert (e' <= Z.div2 ex)%Z by apply Z.le_min_r. rewrite (Zdiv2_odd_eqn ex). - destruct Z.odd ; omega. } + destruct Z.odd ; lia. } generalize (Fsqrt_core_correct radix2 (Zpos mx) ex e' eq_refl He). unfold Fsqrt_core. set (mx' := match (ex - 2 * e')%Z with Z0 => _ | _ => _ end). @@ -2187,7 +2244,7 @@ apply Rlt_le_trans with (1 := Heps). fold (bpow radix2 0). apply bpow_le. generalize (prec_gt_0 prec). -clear ; omega. +clear ; lia. apply Rsqr_incrst_0. 3: apply bpow_ge_0. rewrite Rsqr_mult. @@ -2211,7 +2268,7 @@ now apply IZR_le. change 4%R with (bpow radix2 2). apply bpow_le. generalize (prec_gt_0 prec). -clear -Hmax ; omega. +clear -Hmax ; lia. apply Rmult_le_pos. apply sqrt_ge_0. rewrite <- (Rplus_opp_r 1). @@ -2230,7 +2287,7 @@ unfold Rsqr. rewrite <- bpow_plus. apply bpow_le. unfold emin. -clear -Hmax ; omega. +clear -Hmax ; lia. apply generic_format_ge_bpow with fexp. intros. apply Z.le_max_r. diff --git a/flocq/IEEE754/Bits.v b/flocq/IEEE754/Bits.v index 3a84edfe..68bc541a 100644 --- a/flocq/IEEE754/Bits.v +++ b/flocq/IEEE754/Bits.v @@ -18,6 +18,8 @@ COPYING file for more details. *) (** * IEEE-754 encoding of binary floating-point data *) + +From Coq Require Import Lia. Require Import Core Digits Binary. Section Binary_Bits. @@ -43,10 +45,10 @@ Proof. intros s m e Hm He. assert (0 <= mw)%Z as Hmw. destruct mw as [|mw'|mw'] ; try easy. - clear -Hm ; simpl in Hm ; omega. + clear -Hm ; simpl in Hm ; lia. assert (0 <= ew)%Z as Hew. destruct ew as [|ew'|ew'] ; try easy. - clear -He ; simpl in He ; omega. + clear -He ; simpl in He ; lia. unfold join_bits. rewrite Z.shiftl_mul_pow2 by easy. split. @@ -54,9 +56,9 @@ split. rewrite <- (Zmult_0_l (2^mw)). apply Zmult_le_compat_r. case s. - clear -He ; omega. + clear -He ; lia. now rewrite Zmult_0_l. - clear -Hm ; omega. + clear -Hm ; lia. - apply Z.lt_le_trans with (((if s then 2 ^ ew else 0) + e + 1) * 2 ^ mw)%Z. rewrite (Zmult_plus_distr_l _ 1). apply Zplus_lt_compat_l. @@ -65,9 +67,9 @@ split. apply Zmult_le_compat_r. rewrite Zpower_plus by easy. change (2^1)%Z with 2%Z. - case s ; clear -He ; omega. - clear -Hm ; omega. - clear -Hew ; omega. + case s ; clear -He ; lia. + clear -Hm ; lia. + clear -Hew ; lia. easy. Qed. @@ -85,10 +87,10 @@ Proof. intros s m e Hm He. assert (0 <= mw)%Z as Hmw. destruct mw as [|mw'|mw'] ; try easy. - clear -Hm ; simpl in Hm ; omega. + clear -Hm ; simpl in Hm ; lia. assert (0 <= ew)%Z as Hew. destruct ew as [|ew'|ew'] ; try easy. - clear -He ; simpl in He ; omega. + clear -He ; simpl in He ; lia. unfold split_bits, join_bits. rewrite Z.shiftl_mul_pow2 by easy. apply f_equal2 ; [apply f_equal2|]. @@ -99,7 +101,7 @@ apply f_equal2 ; [apply f_equal2|]. apply Zplus_le_0_compat. apply Zmult_le_0_compat. apply He. - clear -Hm ; omega. + clear -Hm ; lia. apply Hm. + apply Zle_bool_false. apply Zplus_lt_reg_l with (2^mw * (-e))%Z. @@ -108,12 +110,12 @@ apply f_equal2 ; [apply f_equal2|]. apply Z.lt_le_trans with (2^mw * 1)%Z. now apply Zmult_lt_compat_r. apply Zmult_le_compat_l. - clear -He ; omega. - clear -Hm ; omega. + clear -He ; lia. + clear -Hm ; lia. - rewrite Zplus_comm. rewrite Z_mod_plus_full. now apply Zmod_small. -- rewrite Z_div_plus_full_l by (clear -Hm ; omega). +- rewrite Z_div_plus_full_l by (clear -Hm ; lia). rewrite Zdiv_small with (1 := Hm). rewrite Zplus_0_r. case s. @@ -175,7 +177,7 @@ rewrite Zdiv_Zdiv. apply sym_eq. case Zle_bool_spec ; intros Hs. apply Zle_antisym. -cut (x / (2^mw * 2^ew) < 2)%Z. clear ; omega. +cut (x / (2^mw * 2^ew) < 2)%Z. clear ; lia. apply Zdiv_lt_upper_bound. now apply Zmult_lt_0_compat. rewrite <- Zpower_exp ; try ( apply Z.le_ge ; apply Zlt_le_weak ; assumption ). @@ -244,8 +246,8 @@ Theorem split_bits_of_binary_float_correct : split_bits (bits_of_binary_float x) = split_bits_of_binary_float x. Proof. intros [sx|sx|sx plx Hplx|sx mx ex Hx] ; - try ( simpl ; apply split_join_bits ; split ; try apply Z.le_refl ; try apply Zlt_pred ; trivial ; omega ). -simpl. apply split_join_bits; split; try (zify; omega). + try ( simpl ; apply split_join_bits ; split ; try apply Z.le_refl ; try apply Zlt_pred ; trivial ; lia ). +simpl. apply split_join_bits; split; try (zify; lia). destruct (digits2_Pnat_correct plx). unfold nan_pl in Hplx. rewrite Zpos_digits2_pos, <- Z_of_nat_S_digits2_Pnat in Hplx. @@ -253,7 +255,7 @@ rewrite Zpower_nat_Z in H0. eapply Z.lt_le_trans. apply H0. change 2%Z with (radix_val radix2). apply Zpower_le. rewrite Z.ltb_lt in Hplx. -unfold prec in *. zify; omega. +unfold prec in *. zify; lia. (* *) unfold bits_of_binary_float, split_bits_of_binary_float. assert (Hf: (emin <= ex /\ Zdigits radix2 (Zpos mx) <= prec)%Z). @@ -263,14 +265,14 @@ rewrite Zpos_digits2_pos in Hx'. generalize (Zeq_bool_eq _ _ Hx'). unfold FLT_exp. unfold emin. -clear ; zify ; omega. +clear ; zify ; lia. case Zle_bool_spec ; intros H ; [ apply -> Z.le_0_sub in H | apply -> Z.lt_sub_0 in H ] ; apply split_join_bits ; try now split. (* *) split. -clear -He_gt_0 H ; omega. -cut (Zpos mx < 2 * 2^mw)%Z. clear ; omega. +clear -He_gt_0 H ; lia. +cut (Zpos mx < 2 * 2^mw)%Z. clear ; lia. replace (2 * 2^mw)%Z with (2^prec)%Z. apply (Zpower_gt_Zdigits radix2 _ (Zpos mx)). apply Hf. @@ -282,12 +284,12 @@ now apply Zlt_le_weak. (* *) split. generalize (proj1 Hf). -clear ; omega. +clear ; lia. destruct (andb_prop _ _ Hx) as (_, Hx'). unfold emin. replace (2^ew)%Z with (2 * emax)%Z. generalize (Zle_bool_imp_le _ _ Hx'). -clear ; omega. +clear ; lia. apply sym_eq. rewrite (Zsucc_pred ew). unfold Z.succ. @@ -305,7 +307,7 @@ intros [sx|sx|sx pl pl_range|sx mx ex H]. - apply join_bits_range ; now split. - apply join_bits_range. now split. - clear -He_gt_0 ; omega. + clear -He_gt_0 ; lia. - apply Z.ltb_lt in pl_range. apply join_bits_range. split. @@ -313,7 +315,7 @@ intros [sx|sx|sx pl pl_range|sx mx ex H]. apply (Zpower_gt_Zdigits radix2 _ (Zpos pl)). apply Z.lt_succ_r. now rewrite <- Zdigits2_Zdigits. - clear -He_gt_0 ; omega. + clear -He_gt_0 ; lia. - unfold bounded in H. apply Bool.andb_true_iff in H ; destruct H as [A B]. apply Z.leb_le in B. @@ -321,22 +323,22 @@ intros [sx|sx|sx pl pl_range|sx mx ex H]. case Zle_bool_spec ; intros H. + apply join_bits_range. * split. - clear -H ; omega. + clear -H ; lia. rewrite Zpos_digits2_pos in A. cut (Zpos mx < 2 ^ prec)%Z. unfold prec. - rewrite Zpower_plus by (clear -Hmw ; omega). + rewrite Zpower_plus by (clear -Hmw ; lia). change (2^1)%Z with 2%Z. - clear ; omega. + clear ; lia. apply (Zpower_gt_Zdigits radix2 _ (Zpos mx)). - clear -A ; zify ; omega. + clear -A ; zify ; lia. * split. - unfold emin ; clear -A ; zify ; omega. + unfold emin ; clear -A ; zify ; lia. replace ew with ((ew - 1) + 1)%Z by ring. - rewrite Zpower_plus by (clear - Hew ; omega). + rewrite Zpower_plus by (clear - Hew ; lia). unfold emin, emax in *. change (2^1)%Z with 2%Z. - clear -B ; omega. + clear -B ; lia. + apply -> Z.lt_sub_0 in H. apply join_bits_range ; now split. Qed. @@ -370,7 +372,7 @@ unfold binary_float_of_bits_aux, split_bits. assert (Hnan: nan_pl prec 1 = true). apply Z.ltb_lt. simpl. unfold prec. - clear -Hmw ; omega. + clear -Hmw ; lia. case Zeq_bool_spec ; intros He1. case_eq (x mod 2^mw)%Z ; try easy. (* subnormal *) @@ -389,7 +391,7 @@ unfold Fexp, FLT_exp. apply sym_eq. apply Zmax_right. clear -H Hprec. -unfold prec ; omega. +unfold prec ; lia. apply Rnot_le_lt. intros H0. refine (_ (mag_le radix2 _ _ _ H0)). @@ -397,20 +399,20 @@ rewrite mag_bpow. rewrite mag_F2R_Zdigits. 2: discriminate. unfold emin, prec. apply Zlt_not_le. -cut (0 < emax)%Z. clear -H Hew ; omega. +cut (0 < emax)%Z. clear -H Hew ; lia. apply (Zpower_gt_0 radix2). -clear -Hew ; omega. +clear -Hew ; lia. apply bpow_gt_0. case Zeq_bool_spec ; intros He2. case_eq (x mod 2 ^ mw)%Z; try easy. (* nan *) intros plx Eqplx. apply Z.ltb_lt. rewrite Zpos_digits2_pos. -assert (forall a b, a <= b -> a < b+1)%Z by (intros; omega). apply H. clear H. +assert (forall a b, a <= b -> a < b+1)%Z by (intros; lia). apply H. clear H. apply Zdigits_le_Zpower. simpl. rewrite <- Eqplx. edestruct Z_mod_lt; eauto. change 2%Z with (radix_val radix2). -apply Z.lt_gt, Zpower_gt_0. omega. +apply Z.lt_gt, Zpower_gt_0. lia. case_eq (x mod 2^mw + 2^mw)%Z ; try easy. (* normal *) intros px Hm. @@ -452,7 +454,7 @@ revert He1. fold ex. cut (0 <= ex)%Z. unfold emin. -clear ; intros H1 H2 ; omega. +clear ; intros H1 H2 ; lia. eapply Z_mod_lt. apply Z.lt_gt. apply (Zpower_gt_0 radix2). @@ -471,12 +473,12 @@ revert He2. set (ex := ((x / 2^mw) mod 2^ew)%Z). cut (ex < 2^ew)%Z. replace (2^ew)%Z with (2 * emax)%Z. -clear ; intros H1 H2 ; omega. +clear ; intros H1 H2 ; lia. replace ew with (1 + (ew - 1))%Z by ring. rewrite Zpower_exp. apply refl_equal. discriminate. -clear -Hew ; omega. +clear -Hew ; lia. eapply Z_mod_lt. apply Z.lt_gt. apply (Zpower_gt_0 radix2). @@ -503,13 +505,13 @@ apply refl_equal. simpl. rewrite Zeq_bool_false. now rewrite Zeq_bool_true. -cut (1 < 2^ew)%Z. clear ; omega. +cut (1 < 2^ew)%Z. clear ; lia. now apply (Zpower_gt_1 radix2). (* *) simpl. rewrite Zeq_bool_false. rewrite Zeq_bool_true; auto. -cut (1 < 2^ew)%Z. clear ; omega. +cut (1 < 2^ew)%Z. clear ; lia. now apply (Zpower_gt_1 radix2). (* *) unfold split_bits_of_binary_float. @@ -522,19 +524,19 @@ destruct (andb_prop _ _ Bx) as (_, H1). generalize (Zle_bool_imp_le _ _ H1). unfold emin. replace (2^ew)%Z with (2 * emax)%Z. -clear ; omega. +clear ; lia. replace ew with (1 + (ew - 1))%Z by ring. rewrite Zpower_exp. apply refl_equal. discriminate. -clear -Hew ; omega. +clear -Hew ; lia. destruct (andb_prop _ _ Bx) as (H1, _). generalize (Zeq_bool_eq _ _ H1). rewrite Zpos_digits2_pos. unfold FLT_exp, emin. generalize (Zdigits radix2 (Zpos mx)). clear. -intros ; zify ; omega. +intros ; zify ; lia. (* . *) rewrite Zeq_bool_true. 2: apply refl_equal. simpl. @@ -547,7 +549,7 @@ apply -> Z.lt_sub_0 in Hm. generalize (Zdigits_le_Zpower radix2 _ (Zpos mx) Hm). generalize (Zdigits radix2 (Zpos mx)). clear. -intros ; zify ; omega. +intros ; zify ; lia. Qed. Theorem bits_of_binary_float_of_bits : @@ -588,12 +590,12 @@ case Zeq_bool_spec ; intros He2. case_eq mx; intros Hm. now rewrite He2. now rewrite He2. -intros. zify; omega. +intros. zify; lia. (* normal *) case_eq (mx + 2 ^ mw)%Z. intros Hm. apply False_ind. -clear -Bm Hm ; omega. +clear -Bm Hm ; lia. intros p Hm Jx Cx. rewrite <- Hm. rewrite Zle_bool_true. @@ -601,7 +603,7 @@ now ring_simplify (mx + 2^mw - 2^mw)%Z (ex + emin - 1 - emin + 1)%Z. now ring_simplify. intros p Hm. apply False_ind. -clear -Bm Hm ; zify ; omega. +clear -Bm Hm ; zify ; lia. Qed. End Binary_Bits. @@ -623,6 +625,12 @@ Proof. apply refl_equal. Qed. +Let Hemax : (3 <= 128)%Z. +Proof. +intros H. +discriminate H. +Qed. + Definition default_nan_pl32 : { nan : binary32 | is_nan 24 128 nan = true } := exist _ (@B754_nan 24 128 false (iter_nat xO 22 xH) (refl_equal true)) (refl_equal true). @@ -639,16 +647,28 @@ Definition binop_nan_pl32 (f1 f2 : binary32) : { nan : binary32 | is_nan 24 128 | _, _ => default_nan_pl32 end. +Definition ternop_nan_pl32 (f1 f2 f3 : binary32) : { nan : binary32 | is_nan 24 128 nan = true } := + match f1, f2, f3 with + | B754_nan s1 pl1 Hpl1, _, _ => exist _ (B754_nan s1 pl1 Hpl1) (refl_equal true) + | _, B754_nan s2 pl2 Hpl2, _ => exist _ (B754_nan s2 pl2 Hpl2) (refl_equal true) + | _, _, B754_nan s3 pl3 Hpl3 => exist _ (B754_nan s3 pl3 Hpl3) (refl_equal true) + | _, _, _ => default_nan_pl32 + end. + Definition b32_erase : binary32 -> binary32 := erase 24 128. Definition b32_opp : binary32 -> binary32 := Bopp 24 128 unop_nan_pl32. Definition b32_abs : binary32 -> binary32 := Babs 24 128 unop_nan_pl32. -Definition b32_sqrt : mode -> binary32 -> binary32 := Bsqrt _ _ Hprec Hprec_emax unop_nan_pl32. +Definition b32_pred : binary32 -> binary32 := Bpred _ _ Hprec Hprec_emax Hemax unop_nan_pl32. +Definition b32_succ : binary32 -> binary32 := Bsucc _ _ Hprec Hprec_emax Hemax unop_nan_pl32. +Definition b32_sqrt : mode -> binary32 -> binary32 := Bsqrt _ _ Hprec Hprec_emax unop_nan_pl32. Definition b32_plus : mode -> binary32 -> binary32 -> binary32 := Bplus _ _ Hprec Hprec_emax binop_nan_pl32. Definition b32_minus : mode -> binary32 -> binary32 -> binary32 := Bminus _ _ Hprec Hprec_emax binop_nan_pl32. Definition b32_mult : mode -> binary32 -> binary32 -> binary32 := Bmult _ _ Hprec Hprec_emax binop_nan_pl32. Definition b32_div : mode -> binary32 -> binary32 -> binary32 := Bdiv _ _ Hprec Hprec_emax binop_nan_pl32. +Definition b32_fma : mode -> binary32 -> binary32 -> binary32 -> binary32 := Bfma _ _ Hprec Hprec_emax ternop_nan_pl32. + Definition b32_compare : binary32 -> binary32 -> option comparison := Bcompare 24 128. Definition b32_of_bits : Z -> binary32 := binary_float_of_bits 23 8 (refl_equal _) (refl_equal _) (refl_equal _). Definition bits_of_b32 : binary32 -> Z := bits_of_binary_float 23 8. @@ -672,6 +692,12 @@ Proof. apply refl_equal. Qed. +Let Hemax : (3 <= 1024)%Z. +Proof. +intros H. +discriminate H. +Qed. + Definition default_nan_pl64 : { nan : binary64 | is_nan 53 1024 nan = true } := exist _ (@B754_nan 53 1024 false (iter_nat xO 51 xH) (refl_equal true)) (refl_equal true). @@ -688,9 +714,19 @@ Definition binop_nan_pl64 (f1 f2 : binary64) : { nan : binary64 | is_nan 53 1024 | _, _ => default_nan_pl64 end. +Definition ternop_nan_pl64 (f1 f2 f3 : binary64) : { nan : binary64 | is_nan 53 1024 nan = true } := + match f1, f2, f3 with + | B754_nan s1 pl1 Hpl1, _, _ => exist _ (B754_nan s1 pl1 Hpl1) (refl_equal true) + | _, B754_nan s2 pl2 Hpl2, _ => exist _ (B754_nan s2 pl2 Hpl2) (refl_equal true) + | _, _, B754_nan s3 pl3 Hpl3 => exist _ (B754_nan s3 pl3 Hpl3) (refl_equal true) + | _, _, _ => default_nan_pl64 + end. + Definition b64_erase : binary64 -> binary64 := erase 53 1024. Definition b64_opp : binary64 -> binary64 := Bopp 53 1024 unop_nan_pl64. Definition b64_abs : binary64 -> binary64 := Babs 53 1024 unop_nan_pl64. +Definition b64_pred : binary64 -> binary64 := Bpred _ _ Hprec Hprec_emax Hemax unop_nan_pl64. +Definition b64_succ : binary64 -> binary64 := Bsucc _ _ Hprec Hprec_emax Hemax unop_nan_pl64. Definition b64_sqrt : mode -> binary64 -> binary64 := Bsqrt _ _ Hprec Hprec_emax unop_nan_pl64. Definition b64_plus : mode -> binary64 -> binary64 -> binary64 := Bplus _ _ Hprec Hprec_emax binop_nan_pl64. @@ -698,6 +734,8 @@ Definition b64_minus : mode -> binary64 -> binary64 -> binary64 := Bminus _ _ Hp Definition b64_mult : mode -> binary64 -> binary64 -> binary64 := Bmult _ _ Hprec Hprec_emax binop_nan_pl64. Definition b64_div : mode -> binary64 -> binary64 -> binary64 := Bdiv _ _ Hprec Hprec_emax binop_nan_pl64. +Definition b64_fma : mode -> binary64 -> binary64 -> binary64 -> binary64 := Bfma _ _ Hprec Hprec_emax ternop_nan_pl64. + Definition b64_compare : binary64 -> binary64 -> option comparison := Bcompare 53 1024. Definition b64_of_bits : Z -> binary64 := binary_float_of_bits 52 11 (refl_equal _) (refl_equal _) (refl_equal _). Definition bits_of_b64 : binary64 -> Z := bits_of_binary_float 52 11. diff --git a/flocq/IEEE754/SpecFloatCompat.v b/flocq/IEEE754/SpecFloatCompat.v new file mode 100644 index 00000000..e2ace4d5 --- /dev/null +++ b/flocq/IEEE754/SpecFloatCompat.v @@ -0,0 +1,435 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2018-2019 Guillaume Bertholon +#<br /># +Copyright (C) 2018-2019 Érik Martin-Dorel +#<br /># +Copyright (C) 2018-2019 Pierre Roux + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +COPYING file for more details. +*) + +Require Import ZArith. + +(** ** Inductive specification of floating-point numbers + +Similar to [IEEE754.Binary.full_float], but with no NaN payload. *) +Variant spec_float := + | S754_zero (s : bool) + | S754_infinity (s : bool) + | S754_nan + | S754_finite (s : bool) (m : positive) (e : Z). + +(** ** Parameterized definitions + +[prec] is the number of bits of the mantissa including the implicit one; +[emax] is the exponent of the infinities. + +For instance, Binary64 is defined by [prec = 53] and [emax = 1024]. *) +Section FloatOps. + Variable prec emax : Z. + + Definition emin := (3-emax-prec)%Z. + Definition fexp e := Z.max (e - prec) emin. + + Section Zdigits2. + Fixpoint digits2_pos (n : positive) : positive := + match n with + | xH => xH + | xO p => Pos.succ (digits2_pos p) + | xI p => Pos.succ (digits2_pos p) + end. + + Definition Zdigits2 n := + match n with + | Z0 => n + | Zpos p => Zpos (digits2_pos p) + | Zneg p => Zpos (digits2_pos p) + end. + End Zdigits2. + + Section ValidBinary. + Definition canonical_mantissa m e := + Zeq_bool (fexp (Zpos (digits2_pos m) + e)) e. + + Definition bounded m e := + andb (canonical_mantissa m e) (Zle_bool e (emax - prec)). + + Definition valid_binary x := + match x with + | S754_finite _ m e => bounded m e + | _ => true + end. + End ValidBinary. + + Section Iter. + Context {A : Type}. + Variable (f : A -> A). + + Fixpoint iter_pos (n : positive) (x : A) {struct n} : A := + match n with + | xI n' => iter_pos n' (iter_pos n' (f x)) + | xO n' => iter_pos n' (iter_pos n' x) + | xH => f x + end. + End Iter. + + Section Rounding. + Inductive location := loc_Exact | loc_Inexact : comparison -> location. + + Record shr_record := { shr_m : Z ; shr_r : bool ; shr_s : bool }. + + Definition shr_1 mrs := + let '(Build_shr_record m r s) := mrs in + let s := orb r s in + match m with + | Z0 => Build_shr_record Z0 false s + | Zpos xH => Build_shr_record Z0 true s + | Zpos (xO p) => Build_shr_record (Zpos p) false s + | Zpos (xI p) => Build_shr_record (Zpos p) true s + | Zneg xH => Build_shr_record Z0 true s + | Zneg (xO p) => Build_shr_record (Zneg p) false s + | Zneg (xI p) => Build_shr_record (Zneg p) true s + end. + + Definition loc_of_shr_record mrs := + match mrs with + | Build_shr_record _ false false => loc_Exact + | Build_shr_record _ false true => loc_Inexact Lt + | Build_shr_record _ true false => loc_Inexact Eq + | Build_shr_record _ true true => loc_Inexact Gt + end. + + Definition shr_record_of_loc m l := + match l with + | loc_Exact => Build_shr_record m false false + | loc_Inexact Lt => Build_shr_record m false true + | loc_Inexact Eq => Build_shr_record m true false + | loc_Inexact Gt => Build_shr_record m true true + end. + + Definition shr mrs e n := + match n with + | Zpos p => (iter_pos shr_1 p mrs, (e + n)%Z) + | _ => (mrs, e) + end. + + Definition shr_fexp m e l := + shr (shr_record_of_loc m l) e (fexp (Zdigits2 m + e) - e). + + Definition round_nearest_even mx lx := + match lx with + | loc_Exact => mx + | loc_Inexact Lt => mx + | loc_Inexact Eq => if Z.even mx then mx else (mx + 1)%Z + | loc_Inexact Gt => (mx + 1)%Z + end. + + Definition binary_round_aux sx mx ex lx := + let '(mrs', e') := shr_fexp mx ex lx in + let '(mrs'', e'') := shr_fexp (round_nearest_even (shr_m mrs') (loc_of_shr_record mrs')) e' loc_Exact in + match shr_m mrs'' with + | Z0 => S754_zero sx + | Zpos m => if Zle_bool e'' (emax - prec) then S754_finite sx m e'' else S754_infinity sx + | _ => S754_nan + end. + + Definition shl_align mx ex ex' := + match (ex' - ex)%Z with + | Zneg d => (shift_pos d mx, ex') + | _ => (mx, ex) + end. + + Definition binary_round sx mx ex := + let '(mz, ez) := shl_align mx ex (fexp (Zpos (digits2_pos mx) + ex))in + binary_round_aux sx (Zpos mz) ez loc_Exact. + + Definition binary_normalize m e szero := + match m with + | Z0 => S754_zero szero + | Zpos m => binary_round false m e + | Zneg m => binary_round true m e + end. + End Rounding. + + (** ** Define operations *) + + Definition SFopp x := + match x with + | S754_nan => S754_nan + | S754_infinity sx => S754_infinity (negb sx) + | S754_finite sx mx ex => S754_finite (negb sx) mx ex + | S754_zero sx => S754_zero (negb sx) + end. + + Definition SFabs x := + match x with + | S754_nan => S754_nan + | S754_infinity sx => S754_infinity false + | S754_finite sx mx ex => S754_finite false mx ex + | S754_zero sx => S754_zero false + end. + + Definition SFcompare f1 f2 := + match f1, f2 with + | S754_nan , _ | _, S754_nan => None + | S754_infinity s1, S754_infinity s2 => + Some match s1, s2 with + | true, true => Eq + | false, false => Eq + | true, false => Lt + | false, true => Gt + end + | S754_infinity s, _ => Some (if s then Lt else Gt) + | _, S754_infinity s => Some (if s then Gt else Lt) + | S754_finite s _ _, S754_zero _ => Some (if s then Lt else Gt) + | S754_zero _, S754_finite s _ _ => Some (if s then Gt else Lt) + | S754_zero _, S754_zero _ => Some Eq + | S754_finite s1 m1 e1, S754_finite s2 m2 e2 => + Some match s1, s2 with + | true, false => Lt + | false, true => Gt + | false, false => + match Z.compare e1 e2 with + | Lt => Lt + | Gt => Gt + | Eq => Pcompare m1 m2 Eq + end + | true, true => + match Z.compare e1 e2 with + | Lt => Gt + | Gt => Lt + | Eq => CompOpp (Pcompare m1 m2 Eq) + end + end + end. + + Definition SFeqb f1 f2 := + match SFcompare f1 f2 with + | Some Eq => true + | _ => false + end. + + Definition SFltb f1 f2 := + match SFcompare f1 f2 with + | Some Lt => true + | _ => false + end. + + Definition SFleb f1 f2 := + match SFcompare f1 f2 with + | Some (Lt | Eq) => true + | _ => false + end. + + Variant float_class : Set := + | PNormal | NNormal | PSubn | NSubn | PZero | NZero | PInf | NInf | NaN. + + Definition SFclassify f := + match f with + | S754_nan => NaN + | S754_infinity false => PInf + | S754_infinity true => NInf + | S754_zero false => NZero + | S754_zero true => PZero + | S754_finite false m _ => + if (digits2_pos m =? Z.to_pos prec)%positive then PNormal + else PSubn + | S754_finite true m _ => + if (digits2_pos m =? Z.to_pos prec)%positive then NNormal + else NSubn + end. + + Definition SFmul x y := + match x, y with + | S754_nan, _ | _, S754_nan => S754_nan + | S754_infinity sx, S754_infinity sy => S754_infinity (xorb sx sy) + | S754_infinity sx, S754_finite sy _ _ => S754_infinity (xorb sx sy) + | S754_finite sx _ _, S754_infinity sy => S754_infinity (xorb sx sy) + | S754_infinity _, S754_zero _ => S754_nan + | S754_zero _, S754_infinity _ => S754_nan + | S754_finite sx _ _, S754_zero sy => S754_zero (xorb sx sy) + | S754_zero sx, S754_finite sy _ _ => S754_zero (xorb sx sy) + | S754_zero sx, S754_zero sy => S754_zero (xorb sx sy) + | S754_finite sx mx ex, S754_finite sy my ey => + binary_round_aux (xorb sx sy) (Zpos (mx * my)) (ex + ey) loc_Exact + end. + + Definition cond_Zopp (b : bool) m := if b then Z.opp m else m. + + Definition SFadd x y := + match x, y with + | S754_nan, _ | _, S754_nan => S754_nan + | S754_infinity sx, S754_infinity sy => + if Bool.eqb sx sy then x else S754_nan + | S754_infinity _, _ => x + | _, S754_infinity _ => y + | S754_zero sx, S754_zero sy => + if Bool.eqb sx sy then x else + S754_zero false + | S754_zero _, _ => y + | _, S754_zero _ => x + | S754_finite sx mx ex, S754_finite sy my ey => + let ez := Z.min ex ey in + binary_normalize (Zplus (cond_Zopp sx (Zpos (fst (shl_align mx ex ez)))) (cond_Zopp sy (Zpos (fst (shl_align my ey ez))))) + ez false + end. + + Definition SFsub x y := + match x, y with + | S754_nan, _ | _, S754_nan => S754_nan + | S754_infinity sx, S754_infinity sy => + if Bool.eqb sx (negb sy) then x else S754_nan + | S754_infinity _, _ => x + | _, S754_infinity sy => S754_infinity (negb sy) + | S754_zero sx, S754_zero sy => + if Bool.eqb sx (negb sy) then x else + S754_zero false + | S754_zero _, S754_finite sy my ey => S754_finite (negb sy) my ey + | _, S754_zero _ => x + | S754_finite sx mx ex, S754_finite sy my ey => + let ez := Z.min ex ey in + binary_normalize (Zminus (cond_Zopp sx (Zpos (fst (shl_align mx ex ez)))) (cond_Zopp sy (Zpos (fst (shl_align my ey ez))))) + ez false + end. + + Definition new_location_even nb_steps k := + if Zeq_bool k 0 then loc_Exact + else loc_Inexact (Z.compare (2 * k) nb_steps). + + Definition new_location_odd nb_steps k := + if Zeq_bool k 0 then loc_Exact + else + loc_Inexact + match Z.compare (2 * k + 1) nb_steps with + | Lt => Lt + | Eq => Lt + | Gt => Gt + end. + + Definition new_location nb_steps := + if Z.even nb_steps then new_location_even nb_steps else new_location_odd nb_steps. + + Definition SFdiv_core_binary m1 e1 m2 e2 := + let d1 := Zdigits2 m1 in + let d2 := Zdigits2 m2 in + let e' := Z.min (fexp (d1 + e1 - (d2 + e2))) (e1 - e2) in + let s := (e1 - e2 - e')%Z in + let m' := + match s with + | Zpos _ => Z.shiftl m1 s + | Z0 => m1 + | Zneg _ => Z0 + end in + let '(q, r) := Z.div_eucl m' m2 in + (q, e', new_location m2 r). + + Definition SFdiv x y := + match x, y with + | S754_nan, _ | _, S754_nan => S754_nan + | S754_infinity sx, S754_infinity sy => S754_nan + | S754_infinity sx, S754_finite sy _ _ => S754_infinity (xorb sx sy) + | S754_finite sx _ _, S754_infinity sy => S754_zero (xorb sx sy) + | S754_infinity sx, S754_zero sy => S754_infinity (xorb sx sy) + | S754_zero sx, S754_infinity sy => S754_zero (xorb sx sy) + | S754_finite sx _ _, S754_zero sy => S754_infinity (xorb sx sy) + | S754_zero sx, S754_finite sy _ _ => S754_zero (xorb sx sy) + | S754_zero sx, S754_zero sy => S754_nan + | S754_finite sx mx ex, S754_finite sy my ey => + let '(mz, ez, lz) := SFdiv_core_binary (Zpos mx) ex (Zpos my) ey in + binary_round_aux (xorb sx sy) mz ez lz + end. + + Definition SFsqrt_core_binary m e := + let d := Zdigits2 m in + let e' := Z.min (fexp (Z.div2 (d + e + 1))) (Z.div2 e) in + let s := (e - 2 * e')%Z in + let m' := + match s with + | Zpos p => Z.shiftl m s + | Z0 => m + | Zneg _ => Z0 + end in + let (q, r) := Z.sqrtrem m' in + let l := + if Zeq_bool r 0 then loc_Exact + else loc_Inexact (if Zle_bool r q then Lt else Gt) in + (q, e', l). + + Definition SFsqrt x := + match x with + | S754_nan => S754_nan + | S754_infinity false => x + | S754_infinity true => S754_nan + | S754_finite true _ _ => S754_nan + | S754_zero _ => x + | S754_finite sx mx ex => + let '(mz, ez, lz) := SFsqrt_core_binary (Zpos mx) ex in + binary_round_aux false mz ez lz + end. + + Definition SFnormfr_mantissa f := + match f with + | S754_finite _ mx ex => + if Z.eqb ex (-prec) then Npos mx else 0%N + | _ => 0%N + end. + + Definition SFldexp f e := + match f with + | S754_finite sx mx ex => binary_round sx mx (ex+e) + | _ => f + end. + + Definition SFfrexp f := + match f with + | S754_finite sx mx ex => + if (Z.to_pos prec <=? digits2_pos mx)%positive then + (S754_finite sx mx (-prec), (ex+prec)%Z) + else + let d := (prec - Z.pos (digits2_pos mx))%Z in + (S754_finite sx (shift_pos (Z.to_pos d) mx) (-prec), (ex+prec-d)%Z) + | _ => (f, (-2*emax-prec)%Z) + end. + + Definition SFone := binary_round false 1 0. + + Definition SFulp x := SFldexp SFone (fexp (snd (SFfrexp x))). + + Definition SFpred_pos x := + match x with + | S754_finite _ mx _ => + let d := + if (mx~0 =? shift_pos (Z.to_pos prec) 1)%positive then + SFldexp SFone (fexp (snd (SFfrexp x) - 1)) + else + SFulp x in + SFsub x d + | _ => x + end. + + Definition SFmax_float := + S754_finite false (shift_pos (Z.to_pos prec) 1 - 1) (emax - prec). + + Definition SFsucc x := + match x with + | S754_zero _ => SFldexp SFone emin + | S754_infinity false => x + | S754_infinity true => SFopp SFmax_float + | S754_nan => x + | S754_finite false _ _ => SFadd x (SFulp x) + | S754_finite true _ _ => SFopp (SFpred_pos (SFopp x)) + end. + + Definition SFpred f := SFopp (SFsucc (SFopp f)). +End FloatOps. diff --git a/flocq/Prop/Div_sqrt_error.v b/flocq/Prop/Div_sqrt_error.v index 79220438..9aa9c508 100644 --- a/flocq/Prop/Div_sqrt_error.v +++ b/flocq/Prop/Div_sqrt_error.v @@ -42,9 +42,7 @@ rewrite H; apply generic_format_0. rewrite Hx, Hy, <- F2R_plus. apply generic_format_F2R. intros _. -case_eq (Fplus fx fy). -intros mz ez Hz. -rewrite <- Hz. +change (F2R _) with (F2R (Fplus fx fy)). apply Z.le_trans with (Z.min (Fexp fx) (Fexp fy)). rewrite F2R_plus, <- Hx, <- Hy. unfold cexp. @@ -52,7 +50,7 @@ apply Z.le_trans with (1:=Hfexp _). apply Zplus_le_reg_l with prec; ring_simplify. apply mag_le_bpow with (1 := H). now apply Z.min_case. -rewrite <- Fexp_Fplus, Hz. +rewrite <- Fexp_Fplus. apply Z.le_refl. Qed. @@ -100,7 +98,7 @@ apply Rlt_le_trans with (1 := Heps1). change 1%R with (bpow 0). apply bpow_le. generalize (prec_gt_0 prec). -clear ; omega. +clear ; lia. rewrite Rmult_1_r. rewrite Hx2, <- Hx1. unfold cexp. @@ -193,7 +191,7 @@ now apply IZR_lt. rewrite <- Rmult_assoc, Rinv_r, Rmult_1_l. apply Rle_trans with (bpow (-1)). apply bpow_le. -omega. +lia. replace (2 * (-1 + 5 / 4))%R with (/2)%R by field. apply Rinv_le. now apply IZR_lt. @@ -280,11 +278,11 @@ apply Rle_not_lt. rewrite <- Hr1. apply abs_round_ge_generic... apply generic_format_bpow. -unfold FLX_exp; omega. +unfold FLX_exp; lia. apply Es. apply Rlt_le_trans with (1:=H). apply bpow_le. -omega. +lia. now apply Rlt_le. Qed. @@ -319,7 +317,7 @@ rewrite <- bpow_plus; apply bpow_le; unfold e; set (mxm1 := (_ - 1)%Z). replace (_ * _)%Z with (2 * (mxm1 / 2) + mxm1 mod 2 - mxm1 mod 2)%Z by ring. rewrite <- Z.div_mod; [|now simpl]. apply (Zplus_le_reg_r _ _ (mxm1 mod 2 - mag beta x)%Z). -unfold mxm1; destruct (Z.mod_bound_or (mag beta x - 1) 2); omega. +unfold mxm1; destruct (Z.mod_bound_or (mag beta x - 1) 2); lia. Qed. Notation u_ro := (u_ro beta prec). @@ -346,7 +344,7 @@ assert (Hulp1p2eps : (ulp beta (FLX_exp prec) (1 + 2 * u_ro) = 2 * u_ro)%R). rewrite succ_FLX_1, mag_1, bpow_1, <- H2eps; simpl. apply (Rlt_le_trans _ 2); [apply Rplus_lt_compat_l|]. { unfold u_ro; rewrite <-Rmult_assoc, Rinv_r, Rmult_1_l; [|lra]. - change R1 with (bpow 0); apply bpow_lt; omega. } + change R1 with (bpow 0); apply bpow_lt; lia. } apply IZR_le, Zle_bool_imp_le, radix_prop. } assert (Hsucc1p2eps : (succ beta (FLX_exp prec) (1 + 2 * u_ro) = 1 + 4 * u_ro)%R). @@ -383,7 +381,7 @@ ring_simplify; apply Rsqr_incr_0_var. apply Rmult_le_pos; [|now apply pow_le]. assert (Heps_le_half : (u_ro <= 1 / 2)%R). { unfold u_ro, Rdiv; rewrite Rmult_comm; apply Rmult_le_compat_r; [lra|]. - change 1%R with (bpow 0); apply bpow_le; omega. } + change 1%R with (bpow 0); apply bpow_le; lia. } apply (Rle_trans _ (-8 * u_ro + 4)); [lra|]. apply Rplus_le_compat_r, Rmult_le_compat_r; [apply Pu_ro|]. now assert (H : (0 <= u_ro ^ 2)%R); [apply pow2_ge_0|lra]. } @@ -447,13 +445,13 @@ destruct (sqrt_error_N_FLX_aux2 _ Fmu HmuGe1) as [Hmu'|[Hmu'|Hmu']]. { rewrite Rminus_diag_eq, Rabs_R0; [|now simpl]. now apply Rmult_le_pos; [|apply Rabs_pos]. } apply generic_format_bpow'; [now apply FLX_exp_valid|]. - unfold FLX_exp; omega. } + unfold FLX_exp; lia. } { assert (Hsqrtmu : (1 <= sqrt mu < 1 + u_ro)%R); [rewrite Hmu'; split|]. { rewrite <- sqrt_1 at 1; apply sqrt_le_1_alt; lra. } { rewrite <- sqrt_square; [|lra]; apply sqrt_lt_1_alt; split; [lra|]. ring_simplify; assert (0 < u_ro ^ 2)%R; [apply pow_lt|]; lra. } assert (Fbpowe : generic_format beta (FLX_exp prec) (bpow e)). - { apply generic_format_bpow; unfold FLX_exp; omega. } + { apply generic_format_bpow; unfold FLX_exp; lia. } assert (Hrt : rt = bpow e :> R). { unfold rt; fold t; rewrite Ht; simpl; apply Rle_antisym. { apply round_N_le_midp; [now apply FLX_exp_valid|exact Fbpowe|]. @@ -495,7 +493,7 @@ assert (Hulpt : (ulp beta (FLX_exp prec) t = 2 * u_ro * bpow e)%R). { apply sqrt_lt_1_alt; split; [lra|]. apply (Rlt_le_trans _ _ _ HmuLtsqradix); right. now unfold bpow, Z.pow_pos; simpl; rewrite Zmult_1_r, mult_IZR. } - apply IZR_le, (Z.le_trans _ 2), Zle_bool_imp_le, radix_prop; omega. } + apply IZR_le, (Z.le_trans _ 2), Zle_bool_imp_le, radix_prop; lia. } rewrite Hmagt; ring. } rewrite Ht; apply Rmult_lt_0_compat; [|now apply bpow_gt_0]. now apply (Rlt_le_trans _ 1); [lra|rewrite <- sqrt_1; apply sqrt_le_1_alt]. } @@ -656,7 +654,7 @@ apply Fourier_util.Rle_mult_inv_pos; assumption. case (Zle_lt_or_eq 0 n); try exact H. clear H; intros H. case (Zle_lt_or_eq 1 n). -omega. +lia. clear H; intros H. set (ex := cexp beta fexp x). set (ey := cexp beta fexp y). @@ -715,7 +713,7 @@ rewrite Rinv_l, Rmult_1_r, Rmult_1_l. assert (mag beta x < mag beta y)%Z. case (Zle_or_lt (mag beta y) (mag beta x)); try easy. intros J; apply monotone_exp in J; clear -J Hexy. -unfold ex, ey, cexp in Hexy; omega. +unfold ex, ey, cexp in Hexy; lia. left; apply lt_mag with beta; easy. (* n = 1 -> Sterbenz + rnd_small *) intros Hn'; fold n; rewrite <- Hn'. diff --git a/flocq/Prop/Double_rounding.v b/flocq/Prop/Double_rounding.v index 055409bb..3e942fe0 100644 --- a/flocq/Prop/Double_rounding.v +++ b/flocq/Prop/Double_rounding.v @@ -122,7 +122,7 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx'']. apply (Rle_lt_trans _ _ _ Hr1). apply Rmult_lt_compat_l; [lra|]. apply bpow_lt. - omega. + lia. - (* x'' <> 0 *) assert (Lx'' : mag x'' = mag x :> Z). { apply Zle_antisym. @@ -203,7 +203,7 @@ destruct (Req_dec x' 0) as [Zx'|Nzx']. replace (2 * (/ 2 * _)) with (bpow (fexp1 (mag x) - mag x)) by field. apply Rle_trans with 1; [|lra]. change 1 with (bpow 0); apply bpow_le. - omega. + lia. - (* x' <> 0 *) assert (Px' : 0 < x'). { assert (0 <= x'); [|lra]. @@ -314,10 +314,10 @@ Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hf1 Hx Hx'. destruct (Zle_or_lt (fexp1 (mag x)) (fexp2 (mag x))) as [Hf2'|Hf2']. - (* fexp1 (mag x) <= fexp2 (mag x) *) - assert (Hf2'' : (fexp2 (mag x) = fexp1 (mag x) :> Z)%Z); [omega|]. + assert (Hf2'' : (fexp2 (mag x) = fexp1 (mag x) :> Z)%Z) by lia. now apply round_round_lt_mid_same_place. - (* fexp2 (mag x) < fexp1 (mag x) *) - assert (Hf2'' : (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z); [omega|]. + assert (Hf2'' : (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z) by lia. generalize (Hx' Hf2''); intro Hx''. now apply round_round_lt_mid_further_place. Qed. @@ -380,7 +380,7 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx'']. apply (Rle_lt_trans _ _ _ Hr1). apply Rmult_lt_compat_l; [lra|]. apply bpow_lt. - omega. + lia. - (* x'' <> 0 *) assert (Lx'' : mag x'' = mag x :> Z). { apply Zle_antisym. @@ -460,11 +460,11 @@ assert (Hx''pow : x'' = bpow (mag x)). unfold x'', round, F2R, scaled_mantissa, cexp; simpl. apply (Rmult_le_reg_r (bpow (- fexp2 (mag x)))); [now apply bpow_gt_0|]. bpow_simplify. - rewrite <- (IZR_Zpower _ (_ - _)); [|omega]. + rewrite <- (IZR_Zpower _ (_ - _)); [|lia]. apply IZR_le. apply Zlt_succ_le; unfold Z.succ. apply lt_IZR. - rewrite plus_IZR; rewrite IZR_Zpower; [|omega]. + rewrite plus_IZR; rewrite IZR_Zpower; [|lia]. apply (Rmult_lt_reg_r (bpow (fexp2 (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_plus_distr_r; rewrite Rmult_1_l. bpow_simplify. @@ -482,12 +482,12 @@ assert (Hr : Rabs (x - x'') < / 2 * ulp beta fexp1 x). - apply Rmult_lt_compat_l; [lra|]. rewrite 2!ulp_neq_0; try now apply Rgt_not_eq. unfold cexp; apply bpow_lt. - omega. } + lia. } unfold round, F2R, scaled_mantissa, cexp; simpl. assert (Hf : (0 <= mag x - fexp1 (mag x''))%Z). { rewrite Hx''pow. rewrite mag_bpow. - assert (fexp1 (mag x + 1) <= mag x)%Z; [|omega]. + assert (fexp1 (mag x + 1) <= mag x)%Z; [|lia]. destruct (Zle_or_lt (mag x) (fexp1 (mag x))) as [Hle|Hlt]; [|now apply Vfexp1]. assert (H : (mag x = fexp1 (mag x) :> Z)%Z); @@ -497,9 +497,9 @@ assert (Hf : (0 <= mag x - fexp1 (mag x''))%Z). rewrite (Znearest_imp _ _ (beta ^ (mag x - fexp1 (mag x'')))%Z). - rewrite (Znearest_imp _ _ (beta ^ (mag x - fexp1 (mag x)))%Z). + rewrite IZR_Zpower; [|exact Hf]. - rewrite IZR_Zpower; [|omega]. + rewrite IZR_Zpower; [|lia]. now bpow_simplify. - + rewrite IZR_Zpower; [|omega]. + + rewrite IZR_Zpower; [|lia]. apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; [|now apply Rle_ge; apply bpow_ge_0]. @@ -588,10 +588,10 @@ Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hf1 Hx Hx'. destruct (Zle_or_lt (fexp1 (mag x)) (fexp2 (mag x))) as [Hf2'|Hf2']. - (* fexp1 (mag x) <= fexp2 (mag x) *) - assert (Hf2'' : (fexp2 (mag x) = fexp1 (mag x) :> Z)%Z); [omega|]. + assert (Hf2'' : (fexp2 (mag x) = fexp1 (mag x) :> Z)%Z) by lia. now apply round_round_gt_mid_same_place. - (* fexp2 (mag x) < fexp1 (mag x) *) - assert (Hf2'' : (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z); [omega|]. + assert (Hf2'' : (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z) by lia. generalize (Hx' Hf2''); intro Hx''. now apply round_round_gt_mid_further_place. Qed. @@ -606,7 +606,7 @@ Lemma mag_mult_disj : Proof. intros x y Zx Zy. destruct (mag_mult beta x y Zx Zy). -omega. +lia. Qed. Definition round_round_mult_hyp fexp1 fexp2 := @@ -691,7 +691,7 @@ intros Hprec x y Fx Fy. apply round_round_mult; [|now apply generic_format_FLX|now apply generic_format_FLX]. unfold round_round_mult_hyp; split; intros ex ey; unfold FLX_exp; -omega. +lia. Qed. End Double_round_mult_FLX. @@ -721,7 +721,7 @@ generalize (Zmax_spec (ex + ey - prec') emin'); generalize (Zmax_spec (ex + ey - 1 - prec') emin'); generalize (Zmax_spec (ex - prec) emin); generalize (Zmax_spec (ey - prec) emin); -omega. +lia. Qed. End Double_round_mult_FLT. @@ -753,7 +753,7 @@ destruct (Z.ltb_spec (ex + ey - prec') emin'); destruct (Z.ltb_spec (ex - prec) emin); destruct (Z.ltb_spec (ey - prec) emin); destruct (Z.ltb_spec (ex + ey - 1 - prec') emin'); -omega. +lia. Qed. End Double_round_mult_FTZ. @@ -770,7 +770,7 @@ Lemma mag_plus_disj : Proof. intros x y Py Hxy. destruct (mag_plus beta x y Py Hxy). -omega. +lia. Qed. Lemma mag_plus_separated : @@ -798,10 +798,10 @@ Lemma mag_minus_disj : \/ (mag (x - y) = (mag x - 1)%Z :> Z)). Proof. intros x y Px Py Hln. -assert (Hxy : y < x); [now apply (lt_mag beta); [ |omega]|]. +assert (Hxy : y < x); [now apply (lt_mag beta); [ |lia]|]. generalize (mag_minus beta x y Py Hxy); intro Hln2. generalize (mag_minus_lb beta x y Px Py Hln); intro Hln3. -omega. +lia. Qed. Lemma mag_minus_separated : @@ -831,7 +831,7 @@ split. apply succ_le_lt; [apply Vfexp|idtac|exact Fx|assumption]. apply (generic_format_bpow beta fexp (mag x - 1)). replace (_ + _)%Z with (mag x : Z) by ring. - assert (fexp (mag x) < mag x)%Z; [|omega]. + assert (fexp (mag x) < mag x)%Z; [|lia]. now apply mag_generic_gt; [|now apply Rgt_not_eq|]. - rewrite Rabs_right. + apply Rlt_trans with x. @@ -884,7 +884,7 @@ destruct (Req_dec x 0) as [Zx|Nzx]. rewrite Rmult_plus_distr_r. rewrite <- Fx. rewrite mult_IZR. - rewrite IZR_Zpower; [|omega]. + rewrite IZR_Zpower; [|lia]. bpow_simplify. now rewrite <- Fy. } apply generic_format_F2R' with (f := fxy); [now rewrite Hxy|]. @@ -904,7 +904,7 @@ intros fexp1 fexp2 x y Hlnx Hlny Fx Fy. destruct (Z.le_gt_cases (fexp1 (mag x)) (fexp1 (mag y))) as [Hle|Hgt]. - now apply (round_round_plus_aux0_aux_aux fexp1). - rewrite Rplus_comm in Hlnx, Hlny |- *. - now apply (round_round_plus_aux0_aux_aux fexp1); [omega| | | |]. + now apply (round_round_plus_aux0_aux_aux fexp1); [lia| | | |]. Qed. (* fexp1 (mag x) - 1 <= mag y : @@ -927,20 +927,20 @@ destruct (Z.le_gt_cases (mag y) (fexp1 (mag x))) as [Hle|Hgt]. [now apply (mag_plus_separated fexp1)|]. apply (round_round_plus_aux0_aux fexp1); [| |assumption|assumption]; rewrite Lxy. - + now apply Hexp4; omega. - + now apply Hexp3; omega. + + now apply Hexp4; lia. + + now apply Hexp3; lia. - (* fexp1 (mag x) < mag y *) apply (round_round_plus_aux0_aux fexp1); [| |assumption|assumption]. destruct (mag_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy. - + now apply Hexp4; omega. + + now apply Hexp4; lia. + apply Hexp2; apply (mag_le beta y x Py) in Hyx. replace (_ - _)%Z with (mag x : Z) by ring. - omega. + lia. + destruct (mag_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy. - * now apply Hexp3; omega. + * now apply Hexp3; lia. * apply Hexp2. replace (_ - _)%Z with (mag x : Z) by ring. - omega. + lia. Qed. Lemma round_round_plus_aux1_aux : @@ -983,7 +983,7 @@ assert (UB : y * bpow (- fexp (mag x)) < / IZR (beta ^ k)). + bpow_simplify. rewrite bpow_opp. destruct k. - * omega. + * lia. * simpl; unfold Raux.bpow, Z.pow_pos. now apply Rle_refl. * casetype False; apply (Z.lt_irrefl 0). @@ -1003,7 +1003,7 @@ rewrite (Zfloor_imp mx). apply (Rlt_le_trans _ _ _ UB). rewrite bpow_opp. apply Rinv_le; [now apply bpow_gt_0|]. - now rewrite IZR_Zpower; [right|omega]. } + now rewrite IZR_Zpower; [right|lia]. } split. - rewrite <- Rplus_0_r at 1; apply Rplus_le_compat_l. now apply Rlt_le. @@ -1014,7 +1014,7 @@ split. apply Rlt_trans with (bpow (mag y)). + rewrite <- Rabs_right at 1; [|now apply Rle_ge; apply Rlt_le]. apply bpow_mag_gt. - + apply bpow_lt; omega. + + apply bpow_lt; lia. Qed. (* mag y <= fexp1 (mag x) - 2 : round_round_lt_mid applies. *) @@ -1034,18 +1034,18 @@ assert (Hbeta : (2 <= beta)%Z). now apply Zle_bool_imp_le. } intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Px Py Hly Fx. assert (Lxy : mag (x + y) = mag x :> Z); - [now apply (mag_plus_separated fexp1); [|apply Rlt_le| |omega]|]. + [now apply (mag_plus_separated fexp1); [|apply Rlt_le| |lia]|]. destruct Hexp as (_,(_,(_,Hexp4))). assert (Hf2 : (fexp2 (mag x) <= fexp1 (mag x))%Z); - [now apply Hexp4; omega|]. + [now apply Hexp4; lia|]. assert (Bpow2 : bpow (- 2) <= / 2 * / 2). { replace (/2 * /2) with (/4) by field. rewrite (bpow_opp _ 2). apply Rinv_le; [lra|]. apply (IZR_le (2 * 2) (beta * (beta * 1))). rewrite Zmult_1_r. - now apply Zmult_le_compat; omega. } -assert (P2 : (0 < 2)%Z) by omega. + now apply Zmult_le_compat; lia. } +assert (P2 : (0 < 2)%Z) by lia. unfold round_round_eq. apply round_round_lt_mid. - exact Vfexp1. @@ -1053,7 +1053,7 @@ apply round_round_lt_mid. - lra. - now rewrite Lxy. - rewrite Lxy. - assert (fexp1 (mag x) < mag x)%Z; [|omega]. + assert (fexp1 (mag x) < mag x)%Z; [|lia]. now apply mag_generic_gt; [|apply Rgt_not_eq|]. - unfold midp. apply (Rplus_lt_reg_r (- round beta fexp1 Zfloor (x + y))). @@ -1088,10 +1088,10 @@ apply round_round_lt_mid. replace (_ - _) with (- (/ 2)) by lra. apply Ropp_le_contravar. { apply Rle_trans with (bpow (- 1)). - - apply bpow_le; omega. + - apply bpow_le; lia. - unfold Raux.bpow, Z.pow_pos; simpl. apply Rinv_le; [lra|]. - apply IZR_le; omega. } + apply IZR_le; lia. } Qed. (* round_round_plus_aux{0,1} together *) @@ -1115,7 +1115,7 @@ destruct (Zle_or_lt (mag y) (fexp1 (mag x) - 2)) as [Hly|Hly]. rewrite (round_generic beta fexp2). + reflexivity. + now apply valid_rnd_N. - + assert (Hf1 : (fexp1 (mag x) - 1 <= mag y)%Z); [omega|]. + + assert (Hf1 : (fexp1 (mag x) - 1 <= mag y)%Z) by lia. now apply (round_round_plus_aux0 fexp1). Qed. @@ -1140,7 +1140,7 @@ destruct (Req_dec x 0) as [Zx|Nzx]. + reflexivity. + now apply valid_rnd_N. + apply (generic_inclusion_mag beta fexp1). - now intros _; apply Hexp4; omega. + now intros _; apply Hexp4; lia. exact Fy. - (* x <> 0 *) destruct (Req_dec y 0) as [Zy|Nzy]. @@ -1151,7 +1151,7 @@ destruct (Req_dec x 0) as [Zx|Nzx]. * reflexivity. * now apply valid_rnd_N. * apply (generic_inclusion_mag beta fexp1). - now intros _; apply Hexp4; omega. + now intros _; apply Hexp4; lia. exact Fx. + (* y <> 0 *) assert (Px : 0 < x); [lra|]. @@ -1199,21 +1199,21 @@ assert (Lyx : (mag y <= mag x)%Z); destruct (Z.lt_ge_cases (mag x - 2) (mag y)) as [Hlt|Hge]. - (* mag x - 2 < mag y *) assert (Hor : (mag y = mag x :> Z) - \/ (mag y = mag x - 1 :> Z)%Z); [omega|]. + \/ (mag y = mag x - 1 :> Z)%Z) by lia. destruct Hor as [Heq|Heqm1]. + (* mag y = mag x *) apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. * apply Hexp4. - apply Z.le_trans with (mag (x - y)); [omega|]. + apply Z.le_trans with (mag (x - y)); [lia|]. now apply mag_minus. * rewrite Heq. apply Hexp4. - apply Z.le_trans with (mag (x - y)); [omega|]. + apply Z.le_trans with (mag (x - y)); [lia|]. now apply mag_minus. + (* mag y = mag x - 1 *) apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. * apply Hexp4. - apply Z.le_trans with (mag (x - y)); [omega|]. + apply Z.le_trans with (mag (x - y)); [lia|]. now apply mag_minus. * rewrite Heqm1. apply Hexp4. @@ -1224,7 +1224,7 @@ destruct (Z.lt_ge_cases (mag x - 2) (mag y)) as [Hlt|Hge]. + (* mag (x - y) = mag x *) apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. * apply Hexp4. - omega. + lia. * now rewrite Lxmy; apply Hexp3. + (* mag (x - y) = mag x - 1 *) apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]; @@ -1261,8 +1261,8 @@ assert (Hfy : (fexp1 (mag y) < mag y)%Z); [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. - apply Z.le_trans with (fexp1 (mag (x - y))). - + apply Hexp4; omega. - + omega. + + apply Hexp4; lia. + + lia. - now apply Hexp3. Qed. @@ -1289,7 +1289,7 @@ assert (Hfy : (fexp (mag y) < mag y)%Z); destruct (Rlt_or_le (bpow (mag x - 1)) x) as [Hx|Hx]. - (* bpow (mag x - 1) < x *) assert (Lxy : mag (x - y) = mag x :> Z); - [now apply (mag_minus_separated fexp); [| | | | | |omega]|]. + [now apply (mag_minus_separated fexp); [| | | | | |lia]|]. assert (Rxy : round beta fexp Zceil (x - y) = x). { unfold round, F2R, scaled_mantissa, cexp; simpl. rewrite Lxy. @@ -1311,7 +1311,7 @@ destruct (Rlt_or_le (bpow (mag x - 1)) x) as [Hx|Hx]. + rewrite <- Rabs_right at 1; [|now apply Rle_ge; apply Rlt_le]. apply bpow_mag_gt. + apply bpow_le. - omega. + lia. - rewrite <- (Rplus_0_r (IZR _)) at 2. apply Rplus_le_compat_l. rewrite <- Ropp_0; apply Ropp_le_contravar. @@ -1334,9 +1334,9 @@ destruct (Rlt_or_le (bpow (mag x - 1)) x) as [Hx|Hx]. now intro Hx'; rewrite Hx' in Hxy; apply (Rlt_irrefl y). + rewrite Rabs_right; lra. - apply (mag_minus_lb beta x y Px Py). - omega. } + lia. } assert (Hfx1 : (fexp (mag x - 1) < mag x - 1)%Z); - [now apply (valid_exp_large fexp (mag y)); [|omega]|]. + [now apply (valid_exp_large fexp (mag y)); [|lia]|]. assert (Rxy : round beta fexp Zceil (x - y) <= x). { rewrite Xpow at 2. unfold round, F2R, scaled_mantissa, cexp; simpl. @@ -1344,10 +1344,10 @@ destruct (Rlt_or_le (bpow (mag x - 1)) x) as [Hx|Hx]. apply (Rmult_le_reg_r (bpow (- fexp (mag x - 1)%Z))); [now apply bpow_gt_0|]. bpow_simplify. - rewrite <- (IZR_Zpower beta (_ - _ - _)); [|omega]. + rewrite <- (IZR_Zpower beta (_ - _ - _)); [|lia]. apply IZR_le. apply Zceil_glb. - rewrite IZR_Zpower; [|omega]. + rewrite IZR_Zpower; [|lia]. rewrite Xpow at 1. rewrite Rmult_minus_distr_r. bpow_simplify. @@ -1383,7 +1383,7 @@ intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Py Hxy Hly Hly' Fx Fy. assert (Px := Rlt_trans 0 y x Py Hxy). destruct Hexp as (_,(_,(_,Hexp4))). assert (Hf2 : (fexp2 (mag x) <= fexp1 (mag x))%Z); - [now apply Hexp4; omega|]. + [now apply Hexp4; lia|]. assert (Hfx : (fexp1 (mag x) < mag x)%Z); [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. assert (Bpow2 : bpow (- 2) <= / 2 * / 2). @@ -1392,7 +1392,7 @@ assert (Bpow2 : bpow (- 2) <= / 2 * / 2). apply Rinv_le; [lra|]. apply (IZR_le (2 * 2) (beta * (beta * 1))). rewrite Zmult_1_r. - now apply Zmult_le_compat; omega. } + now apply Zmult_le_compat; lia. } assert (Ly : y < bpow (mag y)). { apply Rabs_lt_inv. apply bpow_mag_gt. } @@ -1401,19 +1401,19 @@ apply round_round_gt_mid. - exact Vfexp1. - exact Vfexp2. - lra. -- apply Hexp4; omega. -- assert (fexp1 (mag (x - y)) < mag (x - y))%Z; [|omega]. +- apply Hexp4; lia. +- assert (fexp1 (mag (x - y)) < mag (x - y))%Z; [|lia]. apply (valid_exp_large fexp1 (mag x - 1)). - + apply (valid_exp_large fexp1 (mag y)); [|omega]. + + apply (valid_exp_large fexp1 (mag y)); [|lia]. now apply mag_generic_gt; [|apply Rgt_not_eq|]. - + now apply mag_minus_lb; [| |omega]. + + now apply mag_minus_lb; [| |lia]. - unfold midp'. apply (Rplus_lt_reg_r (/ 2 * ulp beta fexp1 (x - y) - (x - y))). ring_simplify. replace (_ + _) with (round beta fexp1 Zceil (x - y) - (x - y)) by ring. apply Rlt_le_trans with (bpow (fexp1 (mag (x - y)) - 2)). + apply Rle_lt_trans with y; - [now apply round_round_minus_aux2_aux; try assumption; omega|]. + [now apply round_round_minus_aux2_aux; try assumption; lia|]. apply (Rlt_le_trans _ _ _ Ly). now apply bpow_le. + rewrite ulp_neq_0;[idtac|now apply sym_not_eq, Rlt_not_eq, Rgt_minus]. @@ -1428,7 +1428,7 @@ apply round_round_gt_mid. rewrite Zmult_1_r; apply Rinv_le. lra. now apply IZR_le. - * apply bpow_le; omega. + * apply bpow_le; lia. - intro Hf2'. unfold midp'. apply (Rplus_lt_reg_r (/ 2 * ulp beta fexp1 (x - y) - (x - y) @@ -1436,7 +1436,7 @@ apply round_round_gt_mid. ring_simplify. replace (_ + _) with (round beta fexp1 Zceil (x - y) - (x - y)) by ring. apply Rle_lt_trans with y; - [now apply round_round_minus_aux2_aux; try assumption; omega|]. + [now apply round_round_minus_aux2_aux; try assumption; lia|]. apply (Rlt_le_trans _ _ _ Ly). apply Rle_trans with (bpow (fexp1 (mag (x - y)) - 2)); [now apply bpow_le|]. @@ -1501,12 +1501,12 @@ destruct (Req_dec y x) as [Hy|Hy]. { rewrite (round_generic beta fexp2). - reflexivity. - now apply valid_rnd_N. - - assert (Hf1 : (fexp1 (mag (x - y)) - 1 <= mag y)%Z); [omega|]. + - assert (Hf1 : (fexp1 (mag (x - y)) - 1 <= mag y)%Z) by lia. now apply (round_round_minus_aux1 fexp1). } + rewrite (round_generic beta fexp2). * reflexivity. * now apply valid_rnd_N. - * assert (Hf1 : (fexp1 (mag x) - 1 <= mag y)%Z); [omega|]. + * assert (Hf1 : (fexp1 (mag x) - 1 <= mag y)%Z) by lia. now apply (round_round_minus_aux0 fexp1). Qed. @@ -1532,7 +1532,7 @@ destruct (Req_dec x 0) as [Zx|Nzx]. * now apply valid_rnd_N. * apply (generic_inclusion_mag beta fexp1). destruct Hexp as (_,(_,(_,Hexp4))). - now intros _; apply Hexp4; omega. + now intros _; apply Hexp4; lia. exact Fy. - (* x <> 0 *) destruct (Req_dec y 0) as [Zy|Nzy]. @@ -1543,7 +1543,7 @@ destruct (Req_dec x 0) as [Zx|Nzx]. * now apply valid_rnd_N. * apply (generic_inclusion_mag beta fexp1). destruct Hexp as (_,(_,(_,Hexp4))). - now intros _; apply Hexp4; omega. + now intros _; apply Hexp4; lia. exact Fx. + (* y <> 0 *) assert (Px : 0 < x); [lra|]. @@ -1626,9 +1626,9 @@ Proof. intros Hprec. unfold FLX_exp. unfold round_round_plus_hyp; split; [|split; [|split]]; -intros ex ey; try omega. +intros ex ey; try lia. unfold Prec_gt_0 in prec_gt_0_. -omega. +lia. Qed. Theorem round_round_plus_FLX : @@ -1683,19 +1683,19 @@ unfold round_round_plus_hyp; split; [|split; [|split]]; intros ex ey. - generalize (Zmax_spec (ex + 1 - prec) emin). generalize (Zmax_spec (ex - prec') emin'). generalize (Zmax_spec (ey - prec) emin). - omega. + lia. - generalize (Zmax_spec (ex - 1 - prec) emin). generalize (Zmax_spec (ex - prec') emin'). generalize (Zmax_spec (ey - prec) emin). - omega. + lia. - generalize (Zmax_spec (ex - prec) emin). generalize (Zmax_spec (ex - prec') emin'). generalize (Zmax_spec (ey - prec) emin). - omega. + lia. - unfold Prec_gt_0 in prec_gt_0_. generalize (Zmax_spec (ex - prec') emin'). generalize (Zmax_spec (ey - prec) emin). - omega. + lia. Qed. Theorem round_round_plus_FLT : @@ -1753,18 +1753,18 @@ unfold round_round_plus_hyp; split; [|split; [|split]]; intros ex ey. - destruct (Z.ltb_spec (ex + 1 - prec) emin); destruct (Z.ltb_spec (ex - prec') emin'); destruct (Z.ltb_spec (ey - prec) emin); - omega. + lia. - destruct (Z.ltb_spec (ex - 1 - prec) emin); destruct (Z.ltb_spec (ex - prec') emin'); destruct (Z.ltb_spec (ey - prec) emin); - omega. + lia. - destruct (Z.ltb_spec (ex - prec) emin); destruct (Z.ltb_spec (ex - prec') emin'); destruct (Z.ltb_spec (ey - prec) emin); - omega. + lia. - destruct (Z.ltb_spec (ex - prec') emin'); destruct (Z.ltb_spec (ey - prec) emin); - omega. + lia. Qed. Theorem round_round_plus_FTZ : @@ -1832,20 +1832,20 @@ destruct (Z.le_gt_cases (mag y) (fexp1 (mag x))) as [Hle|Hgt]. [now apply (mag_plus_separated fexp1)|]. apply (round_round_plus_aux0_aux fexp1); [| |assumption|assumption]; rewrite Lxy. - + now apply Hexp4; omega. - + now apply Hexp3; omega. + + now apply Hexp4; lia. + + now apply Hexp3; lia. - (* fexp1 (mag x) < mag y *) apply (round_round_plus_aux0_aux fexp1); [| |assumption|assumption]. destruct (mag_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy. - + now apply Hexp4; omega. + + now apply Hexp4; lia. + apply Hexp2; apply (mag_le beta y x Py) in Hyx. replace (_ - _)%Z with (mag x : Z) by ring. - omega. + lia. + destruct (mag_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy. - * now apply Hexp3; omega. + * now apply Hexp3; lia. * apply Hexp2. replace (_ - _)%Z with (mag x : Z) by ring. - omega. + lia. Qed. (* mag y <= fexp1 (mag x) - 1 : round_round_lt_mid applies. *) @@ -1863,16 +1863,16 @@ Lemma round_round_plus_radix_ge_3_aux1 : Proof. intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Px Py Hly Fx. assert (Lxy : mag (x + y) = mag x :> Z); - [now apply (mag_plus_separated fexp1); [|apply Rlt_le| |omega]|]. + [now apply (mag_plus_separated fexp1); [|apply Rlt_le| |lia]|]. destruct Hexp as (_,(_,(_,Hexp4))). assert (Hf2 : (fexp2 (mag x) <= fexp1 (mag x))%Z); - [now apply Hexp4; omega|]. + [now apply Hexp4; lia|]. assert (Bpow3 : bpow (- 1) <= / 3). { unfold Raux.bpow, Z.pow_pos; simpl. rewrite Zmult_1_r. apply Rinv_le; [lra|]. now apply IZR_le. } -assert (P1 : (0 < 1)%Z) by omega. +assert (P1 : (0 < 1)%Z) by lia. unfold round_round_eq. apply round_round_lt_mid. - exact Vfexp1. @@ -1880,7 +1880,7 @@ apply round_round_lt_mid. - lra. - now rewrite Lxy. - rewrite Lxy. - assert (fexp1 (mag x) < mag x)%Z; [|omega]. + assert (fexp1 (mag x) < mag x)%Z; [|lia]. now apply mag_generic_gt; [|apply Rgt_not_eq|]. - unfold midp. apply (Rplus_lt_reg_r (- round beta fexp1 Zfloor (x + y))). @@ -1914,7 +1914,7 @@ apply round_round_lt_mid. apply (Rplus_le_reg_r (- 1)); ring_simplify. replace (_ - _) with (- (/ 3)) by lra. apply Ropp_le_contravar. - now apply Rle_trans with (bpow (- 1)); [apply bpow_le; omega|]. + now apply Rle_trans with (bpow (- 1)); [apply bpow_le; lia|]. Qed. (* round_round_plus_radix_ge_3_aux{0,1} together *) @@ -1940,7 +1940,7 @@ destruct (Zle_or_lt (mag y) (fexp1 (mag x) - 1)) as [Hly|Hly]. rewrite (round_generic beta fexp2). + reflexivity. + now apply valid_rnd_N. - + assert (Hf1 : (fexp1 (mag x) <= mag y)%Z); [omega|]. + + assert (Hf1 : (fexp1 (mag x) <= mag y)%Z) by lia. now apply (round_round_plus_radix_ge_3_aux0 fexp1). Qed. @@ -1966,7 +1966,7 @@ destruct (Req_dec x 0) as [Zx|Nzx]. + reflexivity. + now apply valid_rnd_N. + apply (generic_inclusion_mag beta fexp1). - now intros _; apply Hexp4; omega. + now intros _; apply Hexp4; lia. exact Fy. - (* x <> 0 *) destruct (Req_dec y 0) as [Zy|Nzy]. @@ -1977,7 +1977,7 @@ destruct (Req_dec x 0) as [Zx|Nzx]. * reflexivity. * now apply valid_rnd_N. * apply (generic_inclusion_mag beta fexp1). - now intros _; apply Hexp4; omega. + now intros _; apply Hexp4; lia. exact Fx. + (* y <> 0 *) assert (Px : 0 < x); [lra|]. @@ -2009,21 +2009,21 @@ assert (Lyx : (mag y <= mag x)%Z); destruct (Z.lt_ge_cases (mag x - 2) (mag y)) as [Hlt|Hge]. - (* mag x - 2 < mag y *) assert (Hor : (mag y = mag x :> Z) - \/ (mag y = mag x - 1 :> Z)%Z); [omega|]. + \/ (mag y = mag x - 1 :> Z)%Z) by lia. destruct Hor as [Heq|Heqm1]. + (* mag y = mag x *) apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. * apply Hexp4. - apply Z.le_trans with (mag (x - y)); [omega|]. + apply Z.le_trans with (mag (x - y)); [lia|]. now apply mag_minus. * rewrite Heq. apply Hexp4. - apply Z.le_trans with (mag (x - y)); [omega|]. + apply Z.le_trans with (mag (x - y)); [lia|]. now apply mag_minus. + (* mag y = mag x - 1 *) apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. * apply Hexp4. - apply Z.le_trans with (mag (x - y)); [omega|]. + apply Z.le_trans with (mag (x - y)); [lia|]. now apply mag_minus. * rewrite Heqm1. apply Hexp4. @@ -2034,7 +2034,7 @@ destruct (Z.lt_ge_cases (mag x - 2) (mag y)) as [Hlt|Hge]. + (* mag (x - y) = mag x *) apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. * apply Hexp4. - omega. + lia. * now rewrite Lxmy; apply Hexp3. + (* mag (x - y) = mag x - 1 *) apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]; @@ -2071,8 +2071,8 @@ assert (Hfy : (fexp1 (mag y) < mag y)%Z); [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. - apply Z.le_trans with (fexp1 (mag (x - y))). - + apply Hexp4; omega. - + omega. + + apply Hexp4; lia. + + lia. - now apply Hexp3. Qed. @@ -2097,7 +2097,7 @@ intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Py Hxy Hly Hly' assert (Px := Rlt_trans 0 y x Py Hxy). destruct Hexp as (_,(_,(_,Hexp4))). assert (Hf2 : (fexp2 (mag x) <= fexp1 (mag x))%Z); - [now apply Hexp4; omega|]. + [now apply Hexp4; lia|]. assert (Hfx : (fexp1 (mag x) < mag x)%Z); [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. assert (Bpow3 : bpow (- 1) <= / 3). @@ -2113,12 +2113,12 @@ apply round_round_gt_mid. - exact Vfexp1. - exact Vfexp2. - lra. -- apply Hexp4; omega. -- assert (fexp1 (mag (x - y)) < mag (x - y))%Z; [|omega]. +- apply Hexp4; lia. +- assert (fexp1 (mag (x - y)) < mag (x - y))%Z; [|lia]. apply (valid_exp_large fexp1 (mag x - 1)). - + apply (valid_exp_large fexp1 (mag y)); [|omega]. + + apply (valid_exp_large fexp1 (mag y)); [|lia]. now apply mag_generic_gt; [|apply Rgt_not_eq|]. - + now apply mag_minus_lb; [| |omega]. + + now apply mag_minus_lb; [| |lia]. - unfold midp'. apply (Rplus_lt_reg_r (/ 2 * ulp beta fexp1 (x - y) - (x - y))). ring_simplify. @@ -2135,7 +2135,7 @@ apply round_round_gt_mid. apply Rmult_le_compat_r; [now apply bpow_ge_0|]. unfold Raux.bpow, Z.pow_pos; simpl. rewrite Zmult_1_r; apply Rinv_le; [lra|]. - now apply IZR_le; omega. + now apply IZR_le; lia. - intro Hf2'. unfold midp'. apply (Rplus_lt_reg_r (/ 2 * (ulp beta fexp1 (x - y) @@ -2164,7 +2164,7 @@ apply round_round_gt_mid. replace (_ - _) with (- / 3) by field. apply Ropp_le_contravar. apply Rle_trans with (bpow (- 1)). - * apply bpow_le; omega. + * apply bpow_le; lia. * unfold Raux.bpow, Z.pow_pos; simpl. rewrite Zmult_1_r; apply Rinv_le; [lra|]. now apply IZR_le. @@ -2204,12 +2204,12 @@ destruct (Req_dec y x) as [Hy|Hy]. { rewrite (round_generic beta fexp2). - reflexivity. - now apply valid_rnd_N. - - assert (Hf1 : (fexp1 (mag (x - y)) <= mag y)%Z); [omega|]. + - assert (Hf1 : (fexp1 (mag (x - y)) <= mag y)%Z) by lia. now apply (round_round_minus_radix_ge_3_aux1 fexp1). } + rewrite (round_generic beta fexp2). * reflexivity. * now apply valid_rnd_N. - * assert (Hf1 : (fexp1 (mag x) <= mag y)%Z); [omega|]. + * assert (Hf1 : (fexp1 (mag x) <= mag y)%Z) by lia. now apply (round_round_minus_radix_ge_3_aux0 fexp1). Qed. @@ -2236,7 +2236,7 @@ destruct (Req_dec x 0) as [Zx|Nzx]. * now apply valid_rnd_N. * apply (generic_inclusion_mag beta fexp1). destruct Hexp as (_,(_,(_,Hexp4))). - now intros _; apply Hexp4; omega. + now intros _; apply Hexp4; lia. exact Fy. - (* x <> 0 *) destruct (Req_dec y 0) as [Zy|Nzy]. @@ -2247,7 +2247,7 @@ destruct (Req_dec x 0) as [Zx|Nzx]. * now apply valid_rnd_N. * apply (generic_inclusion_mag beta fexp1). destruct Hexp as (_,(_,(_,Hexp4))). - now intros _; apply Hexp4; omega. + now intros _; apply Hexp4; lia. exact Fx. + (* y <> 0 *) assert (Px : 0 < x); [lra|]. @@ -2332,9 +2332,9 @@ Proof. intros Hprec. unfold FLX_exp. unfold round_round_plus_radix_ge_3_hyp; split; [|split; [|split]]; -intros ex ey; try omega. +intros ex ey; try lia. unfold Prec_gt_0 in prec_gt_0_. -omega. +lia. Qed. Theorem round_round_plus_radix_ge_3_FLX : @@ -2393,19 +2393,19 @@ unfold round_round_plus_radix_ge_3_hyp; split; [|split; [|split]]; intros ex ey. - generalize (Zmax_spec (ex + 1 - prec) emin). generalize (Zmax_spec (ex - prec') emin'). generalize (Zmax_spec (ey - prec) emin). - omega. + lia. - generalize (Zmax_spec (ex - 1 - prec) emin). generalize (Zmax_spec (ex - prec') emin'). generalize (Zmax_spec (ey - prec) emin). - omega. + lia. - generalize (Zmax_spec (ex - prec) emin). generalize (Zmax_spec (ex - prec') emin'). generalize (Zmax_spec (ey - prec) emin). - omega. + lia. - unfold Prec_gt_0 in prec_gt_0_. generalize (Zmax_spec (ex - prec') emin'). generalize (Zmax_spec (ey - prec) emin). - omega. + lia. Qed. Theorem round_round_plus_radix_ge_3_FLT : @@ -2467,18 +2467,18 @@ unfold round_round_plus_radix_ge_3_hyp; split; [|split; [|split]]; intros ex ey. - destruct (Z.ltb_spec (ex + 1 - prec) emin); destruct (Z.ltb_spec (ex - prec') emin'); destruct (Z.ltb_spec (ey - prec) emin); - omega. + lia. - destruct (Z.ltb_spec (ex - 1 - prec) emin); destruct (Z.ltb_spec (ex - prec') emin'); destruct (Z.ltb_spec (ey - prec) emin); - omega. + lia. - destruct (Z.ltb_spec (ex - prec) emin); destruct (Z.ltb_spec (ex - prec') emin'); destruct (Z.ltb_spec (ey - prec) emin); - omega. + lia. - destruct (Z.ltb_spec (ex - prec') emin'); destruct (Z.ltb_spec (ey - prec) emin); - omega. + lia. Qed. Theorem round_round_plus_radix_ge_3_FTZ : @@ -2546,11 +2546,11 @@ intros Cmid. destruct (generic_format_EM beta fexp1 x) as [Fx|Nfx]. - (* generic_format beta fexp1 x *) rewrite (round_generic beta fexp2); [reflexivity|now apply valid_rnd_N|]. - now apply (generic_inclusion_mag beta fexp1); [omega|]. + now apply (generic_inclusion_mag beta fexp1); [lia|]. - (* ~ generic_format beta fexp1 x *) assert (Hceil : round beta fexp1 Zceil x = rd + u1); [now apply round_UP_DN_ulp|]. - assert (Hf2' : (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z); [omega|]. + assert (Hf2' : (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z) by lia. destruct (Rlt_or_le (x - rd) (/ 2 * (u1 - u2))). + (* x - rd < / 2 * (u1 - u2) *) apply round_round_lt_mid_further_place; try assumption. @@ -2587,7 +2587,7 @@ Proof. intros x Px. rewrite (mag_sqrt beta x Px). generalize (Zdiv2_odd_eqn (mag x + 1)). -destruct Z.odd ; intros ; omega. +destruct Z.odd ; intros ; lia. Qed. Lemma round_round_sqrt_aux : @@ -2638,7 +2638,7 @@ assert (Pb : 0 < b). apply Rlt_Rminus. unfold u2, u1. apply bpow_lt. - omega. } + lia. } assert (Pb' : 0 < b'). { now unfold b'; rewrite Rmult_plus_distr_l; apply Rplus_lt_0_compat. } assert (Hr : sqrt x <= a + b'). @@ -2654,7 +2654,7 @@ assert (Hf1 : (2 * fexp1 (mag (sqrt x)) <= fexp1 (mag (x)))%Z); [destruct (mag_sqrt_disj x Px) as [H'|H']; rewrite H'; apply Hexp|]. assert (Hlx : (fexp1 (2 * mag (sqrt x)) < 2 * mag (sqrt x))%Z). { destruct (mag_sqrt_disj x Px) as [Hlx|Hlx]. - - apply (valid_exp_large fexp1 (mag x)); [|omega]. + - apply (valid_exp_large fexp1 (mag x)); [|lia]. now apply mag_generic_gt; [|apply Rgt_not_eq|]. - rewrite <- Hlx. now apply mag_generic_gt; [|apply Rgt_not_eq|]. } @@ -2698,7 +2698,7 @@ destruct (Req_dec a 0) as [Za|Nza]. unfold b'; change (bpow _) with u1. apply Rlt_le_trans with (/ 2 * (u1 + u1)); [|lra]. apply Rmult_lt_compat_l; [lra|]; apply Rplus_lt_compat_l. - unfold u2, u1, ulp, cexp; apply bpow_lt; omega. + unfold u2, u1, ulp, cexp; apply bpow_lt; lia. - (* a <> 0 *) assert (Pa : 0 < a); [lra|]. assert (Hla : (mag a = mag (sqrt x) :> Z)). @@ -2731,7 +2731,7 @@ destruct (Req_dec a 0) as [Za|Nza]. * apply pow2_ge_0. * unfold Raux.bpow, Z.pow_pos; simpl; rewrite Zmult_1_r. apply Rinv_le; [lra|]. - change 4%Z with (2 * 2)%Z; apply IZR_le, Zmult_le_compat; omega. + change 4%Z with (2 * 2)%Z; apply IZR_le, Zmult_le_compat; lia. * rewrite <- (Rplus_0_l (u1 ^ 2)) at 1; apply Rplus_le_compat_r. apply pow2_ge_0. } assert (Hr' : x <= a * a + u1 * a). @@ -2744,11 +2744,11 @@ destruct (Req_dec a 0) as [Za|Nza]. apply (Rmult_le_reg_r (bpow (- 2 * fexp1 (mag (sqrt x))))); [now apply bpow_gt_0|bpow_simplify]. rewrite Fx at 1; bpow_simplify. - rewrite <- IZR_Zpower; [|omega]. + rewrite <- IZR_Zpower; [|lia]. rewrite <- plus_IZR, <- 2!mult_IZR. apply IZR_le, Zlt_succ_le, lt_IZR. unfold Z.succ; rewrite plus_IZR; do 2 rewrite mult_IZR; rewrite plus_IZR. - rewrite IZR_Zpower; [|omega]. + rewrite IZR_Zpower; [|lia]. apply (Rmult_lt_reg_r (bpow (2 * fexp1 (mag (sqrt x))))); [now apply bpow_gt_0|bpow_simplify]. rewrite <- Fx. @@ -2787,12 +2787,12 @@ destruct (Req_dec a 0) as [Za|Nza]. apply Rinv_le; [lra|]. apply IZR_le. rewrite <- (Zmult_1_l 2). - apply Zmult_le_compat; omega. + apply Zmult_le_compat; lia. + assert (u2 ^ 2 < u1 ^ 2); [|unfold b'; lra]. unfold pow; do 2 rewrite Rmult_1_r. assert (H' : 0 <= u2); [unfold u2, ulp; apply bpow_ge_0|]. assert (u2 < u1); [|now apply Rmult_lt_compat]. - unfold u1, u2, ulp, cexp; apply bpow_lt; omega. } + unfold u1, u2, ulp, cexp; apply bpow_lt; lia. } apply (Rlt_irrefl (a * a + u1 * a)). apply Rlt_le_trans with (a * a + u1 * a - u2 * a + b * b). + rewrite <- (Rplus_0_r (a * a + _)) at 1. @@ -2835,7 +2835,8 @@ destruct (Rle_or_lt x 0) as [Npx|Px]. generalize ((proj1 (proj2 Hexp)) 1%Z). replace (_ - 1)%Z with 1%Z by ring. intro Hexp10. - assert (Hf0 : (fexp1 1 < 1)%Z); [omega|clear Hexp10]. + assert (Hf0 : (fexp1 1 < 1)%Z) by lia. + clear Hexp10. apply (valid_exp_large fexp1 1); [exact Hf0|]. apply mag_ge_bpow. rewrite Zeq_minus; [|reflexivity]. @@ -2847,18 +2848,18 @@ destruct (Rle_or_lt x 0) as [Npx|Px]. assert (Hf2 : (fexp2 (mag (sqrt x)) <= fexp1 (mag (sqrt x)) - 1)%Z). { assert (H : (fexp1 (2 * mag (sqrt x)) < 2 * mag (sqrt x))%Z). { destruct (mag_sqrt_disj x Px) as [Hlx|Hlx]. - - apply (valid_exp_large fexp1 (mag x)); [|omega]. + - apply (valid_exp_large fexp1 (mag x)); [|lia]. now apply mag_generic_gt; [|apply Rgt_not_eq|]. - rewrite <- Hlx. now apply mag_generic_gt; [|apply Rgt_not_eq|]. } generalize ((proj2 (proj2 Hexp)) (mag (sqrt x)) H). - omega. } + lia. } apply round_round_mid_cases. + exact Vfexp1. + exact Vfexp2. + now apply sqrt_lt_R0. - + omega. - + omega. + + lia. + + lia. + intros Hmid; casetype False; apply (Rle_not_lt _ _ Hmid). apply (round_round_sqrt_aux fexp1 fexp2 Vfexp1 Vfexp2 Hexp x Px Hf2 Fx). Qed. @@ -2878,7 +2879,7 @@ Proof. intros Hprec. unfold FLX_exp. unfold Prec_gt_0 in prec_gt_0_. -unfold round_round_sqrt_hyp; split; [|split]; intro ex; omega. +unfold round_round_sqrt_hyp; split; [|split]; intro ex; lia. Qed. Theorem round_round_sqrt_FLX : @@ -2919,14 +2920,14 @@ unfold Prec_gt_0 in prec_gt_0_. unfold round_round_sqrt_hyp; split; [|split]; intros ex. - generalize (Zmax_spec (ex - prec) emin). generalize (Zmax_spec (2 * ex - prec) emin). - omega. + lia. - generalize (Zmax_spec (ex - prec) emin). generalize (Zmax_spec (2 * ex - 1 - prec) emin). - omega. + lia. - generalize (Zmax_spec (2 * ex - prec) emin). generalize (Zmax_spec (ex - prec') emin'). generalize (Zmax_spec (ex - prec) emin). - omega. + lia. Qed. Theorem round_round_sqrt_FLT : @@ -2969,18 +2970,18 @@ unfold Prec_gt_0 in *. unfold round_round_sqrt_hyp; split; [|split]; intros ex. - destruct (Z.ltb_spec (ex - prec) emin); destruct (Z.ltb_spec (2 * ex - prec) emin); - omega. + lia. - destruct (Z.ltb_spec (ex - prec) emin); destruct (Z.ltb_spec (2 * ex - 1 - prec) emin); - omega. + lia. - intro H. destruct (Zle_or_lt emin (2 * ex - prec)) as [H'|H']. + destruct (Z.ltb_spec (ex - prec') emin'); destruct (Z.ltb_spec (ex - prec) emin); - omega. + lia. + casetype False. rewrite (Zlt_bool_true _ _ H') in H. - omega. + lia. Qed. Theorem round_round_sqrt_FTZ : @@ -3057,7 +3058,7 @@ assert (Pb : 0 < b). apply Rlt_Rminus. unfold u2, u1, ulp, cexp. apply bpow_lt. - omega. } + lia. } assert (Pb' : 0 < b'). { now unfold b'; rewrite Rmult_plus_distr_l; apply Rplus_lt_0_compat. } assert (Hr : sqrt x <= a + b'). @@ -3073,7 +3074,7 @@ assert (Hf1 : (2 * fexp1 (mag (sqrt x)) <= fexp1 (mag (x)))%Z); [destruct (mag_sqrt_disj x Px) as [H'|H']; rewrite H'; apply Hexp|]. assert (Hlx : (fexp1 (2 * mag (sqrt x)) < 2 * mag (sqrt x))%Z). { destruct (mag_sqrt_disj x Px) as [Hlx|Hlx]. - - apply (valid_exp_large fexp1 (mag x)); [|omega]. + - apply (valid_exp_large fexp1 (mag x)); [|lia]. now apply mag_generic_gt; [|apply Rgt_not_eq|]. - rewrite <- Hlx. now apply mag_generic_gt; [|apply Rgt_not_eq|]. } @@ -3117,7 +3118,7 @@ destruct (Req_dec a 0) as [Za|Nza]. unfold b'; change (bpow _) with u1. apply Rlt_le_trans with (/ 2 * (u1 + u1)); [|lra]. apply Rmult_lt_compat_l; [lra|]; apply Rplus_lt_compat_l. - unfold u2, u1, ulp, cexp; apply bpow_lt; omega. + unfold u2, u1, ulp, cexp; apply bpow_lt; lia. - (* a <> 0 *) assert (Pa : 0 < a); [lra|]. assert (Hla : (mag a = mag (sqrt x) :> Z)). @@ -3162,11 +3163,11 @@ destruct (Req_dec a 0) as [Za|Nza]. apply (Rmult_le_reg_r (bpow (- 2 * fexp1 (mag (sqrt x))))); [now apply bpow_gt_0|bpow_simplify]. rewrite Fx at 1; bpow_simplify. - rewrite <- IZR_Zpower; [|omega]. + rewrite <- IZR_Zpower; [|lia]. rewrite <- plus_IZR, <- 2!mult_IZR. apply IZR_le, Zlt_succ_le, lt_IZR. unfold Z.succ; rewrite plus_IZR; do 2 rewrite mult_IZR; rewrite plus_IZR. - rewrite IZR_Zpower; [|omega]. + rewrite IZR_Zpower; [|lia]. apply (Rmult_lt_reg_r (bpow (2 * fexp1 (mag (sqrt x))))); [now apply bpow_gt_0|bpow_simplify]. rewrite <- Fx. @@ -3203,12 +3204,12 @@ destruct (Req_dec a 0) as [Za|Nza]. unfold Raux.bpow; simpl; unfold Z.pow_pos; simpl. rewrite Zmult_1_r. apply Rinv_le; [lra|]. - apply IZR_le; omega. + apply IZR_le; lia. + assert (u2 ^ 2 < u1 ^ 2); [|unfold b'; lra]. unfold pow; do 2 rewrite Rmult_1_r. assert (H' : 0 <= u2); [unfold u2, ulp; apply bpow_ge_0|]. assert (u2 < u1); [|now apply Rmult_lt_compat]. - unfold u1, u2, ulp, cexp; apply bpow_lt; omega. } + unfold u1, u2, ulp, cexp; apply bpow_lt; lia. } apply (Rlt_irrefl (a * a + u1 * a)). apply Rlt_le_trans with (a * a + u1 * a - u2 * a + b * b). + rewrite <- (Rplus_0_r (a * a + _)) at 1. @@ -3263,7 +3264,8 @@ destruct (Rle_or_lt x 0) as [Npx|Px]. generalize ((proj1 (proj2 Hexp)) 1%Z). replace (_ - 1)%Z with 1%Z by ring. intro Hexp10. - assert (Hf0 : (fexp1 1 < 1)%Z); [omega|clear Hexp10]. + assert (Hf0 : (fexp1 1 < 1)%Z) by lia. + clear Hexp10. apply (valid_exp_large fexp1 1); [exact Hf0|]. apply mag_ge_bpow. rewrite Zeq_minus; [|reflexivity]. @@ -3275,18 +3277,18 @@ destruct (Rle_or_lt x 0) as [Npx|Px]. assert (Hf2 : (fexp2 (mag (sqrt x)) <= fexp1 (mag (sqrt x)) - 1)%Z). { assert (H : (fexp1 (2 * mag (sqrt x)) < 2 * mag (sqrt x))%Z). { destruct (mag_sqrt_disj x Px) as [Hlx|Hlx]. - - apply (valid_exp_large fexp1 (mag x)); [|omega]. + - apply (valid_exp_large fexp1 (mag x)); [|lia]. now apply mag_generic_gt; [|apply Rgt_not_eq|]. - rewrite <- Hlx. now apply mag_generic_gt; [|apply Rgt_not_eq|]. } generalize ((proj2 (proj2 Hexp)) (mag (sqrt x)) H). - omega. } + lia. } apply round_round_mid_cases. + exact Vfexp1. + exact Vfexp2. + now apply sqrt_lt_R0. - + omega. - + omega. + + lia. + + lia. + intros Hmid; casetype False; apply (Rle_not_lt _ _ Hmid). apply (round_round_sqrt_radix_ge_4_aux Hbeta fexp1 fexp2 Vfexp1 Vfexp2 Hexp x Px Hf2 Fx). @@ -3307,7 +3309,7 @@ Proof. intros Hprec. unfold FLX_exp. unfold Prec_gt_0 in prec_gt_0_. -unfold round_round_sqrt_radix_ge_4_hyp; split; [|split]; intro ex; omega. +unfold round_round_sqrt_radix_ge_4_hyp; split; [|split]; intro ex; lia. Qed. Theorem round_round_sqrt_radix_ge_4_FLX : @@ -3350,14 +3352,14 @@ unfold Prec_gt_0 in prec_gt_0_. unfold round_round_sqrt_radix_ge_4_hyp; split; [|split]; intros ex. - generalize (Zmax_spec (ex - prec) emin). generalize (Zmax_spec (2 * ex - prec) emin). - omega. + lia. - generalize (Zmax_spec (ex - prec) emin). generalize (Zmax_spec (2 * ex - 1 - prec) emin). - omega. + lia. - generalize (Zmax_spec (2 * ex - prec) emin). generalize (Zmax_spec (ex - prec') emin'). generalize (Zmax_spec (ex - prec) emin). - omega. + lia. Qed. Theorem round_round_sqrt_radix_ge_4_FLT : @@ -3402,18 +3404,18 @@ unfold Prec_gt_0 in *. unfold round_round_sqrt_radix_ge_4_hyp; split; [|split]; intros ex. - destruct (Z.ltb_spec (ex - prec) emin); destruct (Z.ltb_spec (2 * ex - prec) emin); - omega. + lia. - destruct (Z.ltb_spec (ex - prec) emin); destruct (Z.ltb_spec (2 * ex - 1 - prec) emin); - omega. + lia. - intro H. destruct (Zle_or_lt emin (2 * ex - prec)) as [H'|H']. + destruct (Z.ltb_spec (ex - prec') emin'); destruct (Z.ltb_spec (ex - prec) emin); - omega. + lia. + casetype False. rewrite (Zlt_bool_true _ _ H') in H. - omega. + lia. Qed. Theorem round_round_sqrt_radix_ge_4_FTZ : @@ -3479,7 +3481,7 @@ assert (Hf : F2R f = x). rewrite plus_IZR. rewrite Rmult_plus_distr_r. rewrite mult_IZR. - rewrite IZR_Zpower; [|omega]. + rewrite IZR_Zpower; [|lia]. unfold cexp at 2; bpow_simplify. unfold Zminus; rewrite bpow_plus. rewrite (Rmult_comm _ (bpow (- 1))). @@ -3489,11 +3491,11 @@ assert (Hf : F2R f = x). rewrite Ebeta. rewrite (mult_IZR 2). rewrite Rinv_mult_distr; - [|simpl; lra | apply IZR_neq; omega]. + [|simpl; lra | apply IZR_neq; lia]. rewrite <- Rmult_assoc; rewrite (Rmult_comm (IZR n)); rewrite (Rmult_assoc _ (IZR n)). rewrite Rinv_r; - [rewrite Rmult_1_r | apply IZR_neq; omega]. + [rewrite Rmult_1_r | apply IZR_neq; lia]. simpl; fold (cexp beta fexp1 x). rewrite <- 2!ulp_neq_0; try now apply Rgt_not_eq. fold u; rewrite Xmid at 2. @@ -3525,12 +3527,12 @@ assert (Hf : F2R f = x). unfold round, F2R, scaled_mantissa, cexp; simpl. bpow_simplify. rewrite Lrd. - rewrite <- (IZR_Zpower _ (_ - _)); [|omega]. + rewrite <- (IZR_Zpower _ (_ - _)); [|lia]. rewrite <- mult_IZR. rewrite (Zfloor_imp (Zfloor (x * bpow (- fexp1 (mag x))) * beta ^ (fexp1 (mag x) - fexp2 (mag x)))). + rewrite mult_IZR. - rewrite IZR_Zpower; [|omega]. + rewrite IZR_Zpower; [|lia]. bpow_simplify. now unfold rd. + split; [now apply Rle_refl|]. @@ -3557,7 +3559,7 @@ assert (Hlx : bpow (mag x - 1) <= x < bpow (mag x)). apply Hex. now apply Rgt_not_eq. } unfold round_round_eq. -rewrite (round_N_small_pos beta fexp1 _ x (mag x)); [|exact Hlx|omega]. +rewrite (round_N_small_pos beta fexp1 _ x (mag x)); [|exact Hlx|lia]. set (x'' := round beta fexp2 (Znearest choice2) x). destruct (Req_dec x'' 0) as [Zx''|Nzx'']; [now rewrite Zx''; rewrite round_0; [|apply valid_rnd_N]|]. @@ -3566,7 +3568,7 @@ destruct (Zle_or_lt (fexp2 (mag x)) (mag x)). destruct (Rlt_or_le x'' (bpow (mag x))). + (* x'' < bpow (mag x) *) rewrite (round_N_small_pos beta fexp1 _ _ (mag x)); - [reflexivity|split; [|exact H0]|omega]. + [reflexivity|split; [|exact H0]|lia]. apply round_large_pos_ge_bpow; [now apply valid_rnd_N| |now apply Hlx]. fold x''; assert (0 <= x''); [|lra]; unfold x''. rewrite <- (round_0 beta fexp2 (Znearest choice2)). @@ -3581,7 +3583,7 @@ destruct (Zle_or_lt (fexp2 (mag x)) (mag x)). unfold round, F2R, scaled_mantissa, cexp; simpl. rewrite mag_bpow. assert (Hf11 : (fexp1 (mag x + 1) = fexp1 (mag x) :> Z)%Z); - [apply Vfexp1; omega|]. + [apply Vfexp1; lia|]. rewrite Hf11. apply (Rmult_eq_reg_r (bpow (- fexp1 (mag x)))); [|now apply Rgt_not_eq; apply bpow_gt_0]. @@ -3590,7 +3592,7 @@ destruct (Zle_or_lt (fexp2 (mag x)) (mag x)). apply Znearest_imp. simpl; unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r. rewrite Rabs_right; [|now apply Rle_ge; apply bpow_ge_0]. - apply Rle_lt_trans with (bpow (- 2)); [now apply bpow_le; omega|]. + apply Rle_lt_trans with (bpow (- 2)); [now apply bpow_le; lia|]. unfold Raux.bpow, Z.pow_pos; simpl; rewrite Zmult_1_r. assert (Hbeta : (2 <= beta)%Z). { destruct beta as (beta_val,beta_prop); simpl. @@ -3598,11 +3600,11 @@ destruct (Zle_or_lt (fexp2 (mag x)) (mag x)). apply Rinv_lt_contravar. * apply Rmult_lt_0_compat; [lra|]. rewrite mult_IZR; apply Rmult_lt_0_compat; - apply IZR_lt; omega. + apply IZR_lt; lia. * apply IZR_lt. apply (Z.le_lt_trans _ _ _ Hbeta). rewrite <- (Zmult_1_r beta) at 1. - apply Zmult_lt_compat_l; omega. + apply Zmult_lt_compat_l; lia. - (* mag x < fexp2 (mag x) *) casetype False; apply Nzx''. now apply (round_N_small_pos beta _ _ _ (mag x)). @@ -3630,11 +3632,11 @@ assert (Hlx : bpow (mag x - 1) <= x < bpow (mag x)). apply Hex. now apply Rgt_not_eq. } rewrite (round_N_small_pos beta fexp1 choice1 x (mag x)); - [|exact Hlx|omega]. + [|exact Hlx|lia]. destruct (Req_dec x'' 0) as [Zx''|Nzx'']; [now rewrite Zx''; rewrite round_0; [reflexivity|apply valid_rnd_N]|]. rewrite (round_N_small_pos beta _ _ x'' (mag x)); - [reflexivity| |omega]. + [reflexivity| |lia]. split. - apply round_large_pos_ge_bpow. + now apply valid_rnd_N. @@ -3680,19 +3682,19 @@ set (u2 := ulp beta fexp2 x). intros Cz Clt Ceq Cgt. destruct (Ztrichotomy (mag x) (fexp1 (mag x) - 1)) as [Hlt|[Heq|Hgt]]. - (* mag x < fexp1 (mag x) - 1 *) - assert (H : (mag x <= fexp1 (mag x) - 2)%Z) by omega. + assert (H : (mag x <= fexp1 (mag x) - 2)%Z) by lia. now apply round_round_really_zero. - (* mag x = fexp1 (mag x) - 1 *) - assert (H : (fexp1 (mag x) = (mag x + 1))%Z) by omega. + assert (H : (fexp1 (mag x) = (mag x + 1))%Z) by lia. destruct (Rlt_or_le x (bpow (mag x) - / 2 * u2)) as [Hlt'|Hge']. + now apply round_round_zero. + now apply Cz. - (* mag x > fexp1 (mag x) - 1 *) - assert (H : (fexp1 (mag x) <= mag x)%Z) by omega. + assert (H : (fexp1 (mag x) <= mag x)%Z) by lia. destruct (Rtotal_order x (midp fexp1 x)) as [Hlt'|[Heq'|Hgt']]. + (* x < midp fexp1 x *) destruct (Rlt_or_le x (midp fexp1 x - / 2 * u2)) as [Hlt''|Hle'']. - * now apply round_round_lt_mid_further_place; [| | |omega| |]. + * now apply round_round_lt_mid_further_place; [| | |lia| |]. * now apply Clt; [|split]. + (* x = midp fexp1 x *) now apply Ceq. @@ -3703,12 +3705,11 @@ destruct (Ztrichotomy (mag x) (fexp1 (mag x) - 1)) as [Hlt|[Heq|Hgt]]. - (* generic_format beta fexp1 x *) unfold round_round_eq; rewrite (round_generic beta fexp2); [reflexivity|now apply valid_rnd_N|]. - now apply (generic_inclusion_mag beta fexp1); [omega|]. + now apply (generic_inclusion_mag beta fexp1); [lia|]. - (* ~ generic_format beta fexp1 x *) assert (Hceil : round beta fexp1 Zceil x = x' + u1); [now apply round_UP_DN_ulp|]. - assert (Hf2' : (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z); - [omega|]. + assert (Hf2' : (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z) by lia. assert (midp' fexp1 x + / 2 * ulp beta fexp2 x < x); [|now apply round_round_gt_mid_further_place]. revert Hle''; unfold midp, midp'; fold x'. @@ -3724,7 +3725,7 @@ Lemma mag_div_disj : Proof. intros x y Px Py. generalize (mag_div beta x y (Rgt_not_eq _ _ Px) (Rgt_not_eq _ _ Py)). -omega. +lia. Qed. Definition round_round_div_hyp fexp1 fexp2 := @@ -3829,7 +3830,7 @@ destruct (Zle_or_lt Z0 (fexp1 (mag x) - mag (x / y) replace (_ - _ + 1)%Z with ((mag x + 1) - mag y)%Z by ring. apply Hexp. { now assert (fexp1 (mag x + 1) <= mag x)%Z; - [apply valid_exp|omega]. } + [apply valid_exp|lia]. } { assumption. } replace (_ + 1 - _)%Z with (mag x - mag y + 1)%Z by ring. now rewrite <- Hxy. @@ -3842,7 +3843,7 @@ destruct (Zle_or_lt Z0 (fexp1 (mag x) - mag (x / y) bpow_simplify. rewrite (Rmult_comm p). unfold p; bpow_simplify. - rewrite <- IZR_Zpower; [|omega]. + rewrite <- IZR_Zpower; [|lia]. rewrite <- mult_IZR. rewrite <- minus_IZR. apply IZR_le. @@ -3850,7 +3851,7 @@ destruct (Zle_or_lt Z0 (fexp1 (mag x) - mag (x / y) apply Zlt_le_succ. apply lt_IZR. rewrite mult_IZR. - rewrite IZR_Zpower; [|omega]. + rewrite IZR_Zpower; [|lia]. apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|bpow_simplify]. rewrite <- Fx. @@ -4000,7 +4001,7 @@ destruct (Zle_or_lt Z0 (fexp1 (mag x) - fexp1 (mag (x / y)) replace (_ - _ + 1)%Z with ((mag x + 1) - mag y)%Z by ring. apply Hexp. { now assert (fexp1 (mag x + 1) <= mag x)%Z; - [apply valid_exp|omega]. } + [apply valid_exp|lia]. } { assumption. } replace (_ + 1 - _)%Z with (mag x - mag y + 1)%Z by ring. now rewrite <- Hxy. @@ -4016,7 +4017,7 @@ destruct (Zle_or_lt Z0 (fexp1 (mag x) - fexp1 (mag (x / y)) rewrite (Rmult_comm u1). unfold x', u1, round, F2R, ulp, scaled_mantissa, cexp; simpl. bpow_simplify. - rewrite <- (IZR_Zpower _ (_ - _)%Z); [|omega]. + rewrite <- (IZR_Zpower _ (_ - _)%Z); [|lia]. do 5 rewrite <- mult_IZR. rewrite <- plus_IZR. rewrite <- minus_IZR. @@ -4026,7 +4027,7 @@ destruct (Zle_or_lt Z0 (fexp1 (mag x) - fexp1 (mag (x / y)) apply lt_IZR. rewrite plus_IZR. do 5 rewrite mult_IZR; simpl. - rewrite IZR_Zpower; [|omega]. + rewrite IZR_Zpower; [|lia]. apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_assoc. @@ -4063,7 +4064,7 @@ destruct (Zle_or_lt Z0 (fexp1 (mag x) - fexp1 (mag (x / y)) apply (Zplus_le_reg_r _ _ (- mag y)); ring_simplify. rewrite (Zplus_comm (- _)). destruct (mag_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; - apply Hexp; try assumption; rewrite <- Hxy; omega. + apply Hexp; try assumption; rewrite <- Hxy; lia. Qed. Lemma round_round_div_aux2 : @@ -4139,7 +4140,7 @@ destruct (Zle_or_lt Z0 (fexp1 (mag x) - fexp1 (mag (x / y)) replace (_ - _ + 1)%Z with ((mag x + 1) - mag y)%Z by ring. apply Hexp. { now assert (fexp1 (mag x + 1) <= mag x)%Z; - [apply valid_exp|omega]. } + [apply valid_exp|lia]. } { assumption. } replace (_ + 1 - _)%Z with (mag x - mag y + 1)%Z by ring. now rewrite <- Hxy. @@ -4213,7 +4214,7 @@ destruct (Zle_or_lt Z0 (fexp1 (mag x) - fexp1 (mag (x / y)) apply (Zplus_le_reg_r _ _ (- mag y)); ring_simplify. rewrite (Zplus_comm (- _)). destruct (mag_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; - apply Hexp; try assumption; rewrite <- Hxy; omega. + apply Hexp; try assumption; rewrite <- Hxy; lia. + apply Rge_le; rewrite Fx at 1; apply Rle_ge. rewrite Fy at 1 2. apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); @@ -4225,7 +4226,7 @@ destruct (Zle_or_lt Z0 (fexp1 (mag x) - fexp1 (mag (x / y)) rewrite (Rmult_comm u1). unfold x', u1, round, F2R, ulp, scaled_mantissa, cexp; simpl. bpow_simplify. - rewrite <- (IZR_Zpower _ (_ - _)%Z); [|omega]. + rewrite <- (IZR_Zpower _ (_ - _)%Z); [|lia]. do 5 rewrite <- mult_IZR. do 2 rewrite <- plus_IZR. apply IZR_le. @@ -4233,7 +4234,7 @@ destruct (Zle_or_lt Z0 (fexp1 (mag x) - fexp1 (mag (x / y)) apply lt_IZR. rewrite plus_IZR. do 5 rewrite mult_IZR; simpl. - rewrite IZR_Zpower; [|omega]. + rewrite IZR_Zpower; [|lia]. apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite (Rmult_assoc _ (IZR mx)). @@ -4379,8 +4380,8 @@ intros Hprec. unfold Prec_gt_0 in prec_gt_0_. unfold FLX_exp. unfold round_round_div_hyp. -split; [now intro ex; omega|]. -split; [|split; [|split]]; intros ex ey; omega. +split; [now intro ex; lia|]. +split; [|split; [|split]]; intros ex ey; lia. Qed. Theorem round_round_div_FLX : @@ -4425,27 +4426,27 @@ unfold round_round_div_hyp. split; [intro ex|split; [|split; [|split]]; intros ex ey]. - generalize (Zmax_spec (ex - prec') emin'). generalize (Zmax_spec (ex - prec) emin). - omega. + lia. - generalize (Zmax_spec (ex - prec) emin). generalize (Zmax_spec (ey - prec) emin). generalize (Zmax_spec (ex - ey - prec) emin). generalize (Zmax_spec (ex - ey - prec') emin'). - omega. + lia. - generalize (Zmax_spec (ex - prec) emin). generalize (Zmax_spec (ey - prec) emin). generalize (Zmax_spec (ex - ey + 1 - prec) emin). generalize (Zmax_spec (ex - ey + 1 - prec') emin'). - omega. + lia. - generalize (Zmax_spec (ex - prec) emin). generalize (Zmax_spec (ey - prec) emin). generalize (Zmax_spec (ex - ey - prec) emin). generalize (Zmax_spec (ex - ey - prec') emin'). - omega. + lia. - generalize (Zmax_spec (ex - prec) emin). generalize (Zmax_spec (ey - prec) emin). generalize (Zmax_spec (ex - ey - prec) emin). generalize (Zmax_spec (ex - ey - prec') emin'). - omega. + lia. Qed. Theorem round_round_div_FLT : @@ -4493,27 +4494,27 @@ unfold round_round_div_hyp. split; [intro ex|split; [|split; [|split]]; intros ex ey]. - destruct (Z.ltb_spec (ex - prec') emin'); destruct (Z.ltb_spec (ex - prec) emin); - omega. + lia. - destruct (Z.ltb_spec (ex - prec) emin); destruct (Z.ltb_spec (ey - prec) emin); destruct (Z.ltb_spec (ex - ey - prec) emin); destruct (Z.ltb_spec (ex - ey - prec') emin'); - omega. + lia. - destruct (Z.ltb_spec (ex - prec) emin); destruct (Z.ltb_spec (ey - prec) emin); destruct (Z.ltb_spec (ex - ey + 1 - prec) emin); destruct (Z.ltb_spec (ex - ey + 1 - prec') emin'); - omega. + lia. - destruct (Z.ltb_spec (ex - prec) emin); destruct (Z.ltb_spec (ey - prec) emin); destruct (Z.ltb_spec (ex - ey - prec) emin); destruct (Z.ltb_spec (ex - ey - prec') emin'); - omega. + lia. - destruct (Z.ltb_spec (ex - prec) emin); destruct (Z.ltb_spec (ey - prec) emin); destruct (Z.ltb_spec (ex - ey - prec) emin); destruct (Z.ltb_spec (ex - ey - prec') emin'); - omega. + lia. Qed. Theorem round_round_div_FTZ : diff --git a/flocq/Prop/Mult_error.v b/flocq/Prop/Mult_error.v index 57a3856f..f4467025 100644 --- a/flocq/Prop/Mult_error.v +++ b/flocq/Prop/Mult_error.v @@ -18,6 +18,8 @@ COPYING file for more details. *) (** * Error of the multiplication is in the FLX/FLT format *) + +From Coq Require Import Lia. Require Import Core Operations Plus_error. Section Fprop_mult_error. @@ -71,7 +73,7 @@ unfold cexp, FLX_exp. rewrite mag_unique with (1 := Hex). rewrite mag_unique with (1 := Hey). rewrite mag_unique with (1 := Hexy). -cut (exy - 1 < ex + ey)%Z. omega. +cut (exy - 1 < ex + ey)%Z. lia. apply (lt_bpow beta). apply Rle_lt_trans with (1 := proj1 Hexy). rewrite Rabs_mult. @@ -89,7 +91,7 @@ rewrite mag_unique with (1 := Hey). rewrite mag_unique with (1 := Hexy). cut ((ex - 1) + (ey - 1) < exy)%Z. generalize (prec_gt_0 prec). -clear ; omega. +clear ; lia. apply (lt_bpow beta). apply Rle_lt_trans with (2 := proj2 Hexy). rewrite Rabs_mult. @@ -163,7 +165,7 @@ apply (generic_format_F2R' _ _ _ f). { now unfold F2R; simpl; rewrite bpow_plus, Rmult_assoc. } intro Nzmx; unfold mx, ex; rewrite <- Fx. unfold f, ex; simpl; unfold cexp; rewrite (mag_mult_bpow _ _ _ Nzx). -unfold FLX_exp; omega. +unfold FLX_exp; lia. Qed. End Fprop_mult_error. @@ -209,10 +211,10 @@ assumption. apply Rle_trans with (2:=Hxy). apply bpow_le. generalize (prec_gt_0 prec). -clear ; omega. +clear ; lia. rewrite <- (round_FLT_FLX beta emin) in H1. 2:apply Rle_trans with (2:=Hxy). -2:apply bpow_le ; generalize (prec_gt_0 prec) ; clear ; omega. +2:apply bpow_le ; generalize (prec_gt_0 prec) ; clear ; lia. unfold f; rewrite <- H1. apply generic_format_F2R. intros _. @@ -242,7 +244,7 @@ specialize (Ex Hx0). destruct (mag beta y) as (ey,Ey) ; simpl. specialize (Ey Hy0). assert (emin + 2 * prec -1 < ex + ey)%Z. -2: omega. +2: lia. apply (lt_bpow beta). apply Rle_lt_trans with (1:=Hxy). rewrite Rabs_mult, bpow_plus. @@ -262,7 +264,7 @@ intros Hy _. rewrite <- (Rmult_1_l (bpow _)) at 1. apply Rmult_le_compat_r. apply bpow_ge_0. -apply IZR_le; omega. +apply IZR_le; lia. intros H1 H2; contradict H2. replace ny with 0%Z. simpl; ring. @@ -296,7 +298,7 @@ destruct (mag beta x) as (ex,Hx). destruct (mag beta y) as (ey,Hy). simpl; apply Z.le_trans with ((ex-prec)+(ey-prec))%Z. 2: apply Zplus_le_compat; apply Z.le_max_l. -assert (e + 2*prec -1< ex+ey)%Z;[idtac|omega]. +assert (e + 2*prec -1< ex+ey)%Z;[idtac|lia]. apply lt_bpow with beta. apply Rle_lt_trans with (1:=H1). rewrite Rabs_mult, bpow_plus. @@ -327,9 +329,30 @@ apply (generic_format_F2R' _ _ _ f). { now unfold F2R; simpl; rewrite bpow_plus, Rmult_assoc. } intro Nzmx; unfold mx, ex; rewrite <- Fx. unfold f, ex; simpl; unfold cexp; rewrite (mag_mult_bpow _ _ _ Nzx). -unfold FLT_exp; rewrite Z.max_l; [|omega]; rewrite <- Z.add_max_distr_r. -set (n := (_ - _ + _)%Z); apply (Z.le_trans _ n); [unfold n; omega|]. +unfold FLT_exp; rewrite Z.max_l; [|lia]; rewrite <- Z.add_max_distr_r. +set (n := (_ - _ + _)%Z); apply (Z.le_trans _ n); [unfold n; lia|]. apply Z.le_max_l. Qed. +Lemma mult_bpow_pos_exact_FLT : + forall x e, + format x -> + (0 <= e)%Z -> + format (x * bpow e)%R. +Proof. +intros x e Fx He. +destruct (Req_dec x 0) as [Zx|Nzx]. +{ rewrite Zx, Rmult_0_l; apply generic_format_0. } +rewrite Fx. +set (mx := Ztrunc _); set (ex := cexp _). +pose (f := {| Fnum := mx; Fexp := ex + e |} : float beta). +apply (generic_format_F2R' _ _ _ f). +{ now unfold F2R; simpl; rewrite bpow_plus, Rmult_assoc. } +intro Nzmx; unfold mx, ex; rewrite <- Fx. +unfold f, ex; simpl; unfold cexp; rewrite (mag_mult_bpow _ _ _ Nzx). +unfold FLT_exp; rewrite <-Z.add_max_distr_r. +replace (_ - _ + e)%Z with (mag beta x + e - prec)%Z; [ |ring]. +apply Z.max_le_compat_l; lia. +Qed. + End Fprop_mult_error_FLT. diff --git a/flocq/Prop/Plus_error.v b/flocq/Prop/Plus_error.v index 42f80093..514d3aab 100644 --- a/flocq/Prop/Plus_error.v +++ b/flocq/Prop/Plus_error.v @@ -50,19 +50,19 @@ destruct (Zle_or_lt e' e) as [He|He]. exists m. unfold F2R at 2. simpl. rewrite Rmult_assoc, <- bpow_plus. -rewrite <- IZR_Zpower. 2: omega. +rewrite <- IZR_Zpower by lia. rewrite <- mult_IZR, Zrnd_IZR... unfold F2R. simpl. rewrite mult_IZR. rewrite Rmult_assoc. -rewrite IZR_Zpower. 2: omega. +rewrite IZR_Zpower by lia. rewrite <- bpow_plus. apply (f_equal (fun v => IZR m * bpow v)%R). ring. exists ((rnd (IZR m * bpow (e - e'))) * Zpower beta (e' - e))%Z. unfold F2R. simpl. rewrite mult_IZR. -rewrite IZR_Zpower. 2: omega. +rewrite IZR_Zpower by lia. rewrite 2!Rmult_assoc. rewrite <- 2!bpow_plus. apply (f_equal (fun v => _ * bpow v)%R). @@ -326,8 +326,7 @@ exists (Ztrunc (scaled_mantissa beta fexp x)*Zpower beta (cexp x -e))%Z. rewrite Fx at 1; unfold F2R; simpl. rewrite mult_IZR, Rmult_assoc. f_equal. -rewrite IZR_Zpower. -2: omega. +rewrite IZR_Zpower by lia. rewrite <- bpow_plus; f_equal; ring. Qed. @@ -351,7 +350,7 @@ case (Zle_or_lt (mag beta (x/IZR beta)) (mag beta y)); intros H1. pose (e:=cexp (x / IZR beta)). destruct (ex_shift x e) as (nx, Hnx); try exact Fx. apply monotone_exp. -rewrite <- (mag_minus1 x Zx); omega. +rewrite <- (mag_minus1 x Zx); lia. destruct (ex_shift y e) as (ny, Hny); try assumption. apply monotone_exp... destruct (round_repr_same_exp beta fexp rnd (nx+ny) e) as (n,Hn). @@ -406,11 +405,11 @@ apply V; left. apply lt_mag with beta. now apply Rabs_pos_lt. rewrite <- mag_minus1 in H1; try assumption. -rewrite 2!mag_abs; omega. +rewrite 2!mag_abs; lia. (* . *) destruct U as [U|U]. rewrite U; apply Z.le_trans with (mag beta x). -omega. +lia. rewrite <- mag_abs. apply mag_le. now apply Rabs_pos_lt. @@ -424,13 +423,13 @@ now apply Rabs_pos_lt. rewrite 2!mag_abs. assert (mag beta y < mag beta x - 1)%Z. now rewrite (mag_minus1 x Zx). -omega. +lia. apply cexp_round_ge... apply round_plus_neq_0... contradict H1; apply Zle_not_lt. rewrite <- (mag_minus1 x Zx). replace y with (-x)%R. -rewrite mag_opp; omega. +rewrite mag_opp; lia. lra. now exists n. Qed. @@ -520,7 +519,7 @@ rewrite <- mag_minus1; try assumption. unfold FLT_exp; apply bpow_le. apply Z.le_trans with (2:=Z.le_max_l _ _). destruct (mag beta x) as (n,Hn); simpl. -assert (e + prec < n)%Z; try omega. +assert (e + prec < n)%Z; try lia. apply lt_bpow with beta. apply Rle_lt_trans with (1:=He). now apply Hn. @@ -568,7 +567,7 @@ unfold cexp. rewrite <- mag_minus1 by easy. unfold FLX_exp; apply bpow_le. destruct (mag beta x) as (n,Hn); simpl. -assert (e + prec < n)%Z; try omega. +assert (e + prec < n)%Z; try lia. apply lt_bpow with beta. apply Rle_lt_trans with (1:=He). now apply Hn. diff --git a/flocq/Prop/Relative.v b/flocq/Prop/Relative.v index 5f87bd84..6b8e8f77 100644 --- a/flocq/Prop/Relative.v +++ b/flocq/Prop/Relative.v @@ -147,7 +147,7 @@ apply (lt_bpow beta). apply Rle_lt_trans with (2 := proj2 He). exact Hx. generalize (Hmin ex). -omega. +lia. apply Rmult_le_compat_l. apply bpow_ge_0. apply He. @@ -218,7 +218,7 @@ apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R. rewrite <- bpow_plus. apply bpow_le. generalize (Hmin ex). -omega. +lia. apply Rmult_le_compat_l. apply bpow_ge_0. generalize He. @@ -230,7 +230,7 @@ now apply round_le. apply generic_format_bpow. ring_simplify (ex - 1 + 1)%Z. generalize (Hmin ex). -omega. +lia. Qed. Theorem relative_error_round_F2R_emin : @@ -283,7 +283,7 @@ apply (lt_bpow beta). apply Rle_lt_trans with (2 := proj2 He). exact Hx. generalize (Hmin ex). -omega. +lia. apply Rmult_le_compat_l. apply bpow_ge_0. apply He. @@ -375,7 +375,7 @@ apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R. rewrite <- bpow_plus. apply bpow_le. generalize (Hmin ex). -omega. +lia. apply Rmult_le_compat_l. apply bpow_ge_0. generalize He. @@ -387,7 +387,7 @@ now apply round_le. apply generic_format_bpow. ring_simplify (ex - 1 + 1)%Z. generalize (Hmin ex). -omega. +lia. Qed. Theorem relative_error_N_round_F2R_emin : @@ -425,7 +425,7 @@ Lemma relative_error_FLX_aux : Proof. intros k. unfold FLX_exp. -omega. +lia. Qed. Variable rnd : R -> Z. @@ -505,7 +505,7 @@ Proof. unfold u_ro; apply (Rmult_lt_reg_l 2); [lra|]. rewrite <-Rmult_assoc, Rinv_r, Rmult_1_l, Rmult_1_r; [|lra]. apply (Rle_lt_trans _ (bpow 0)); - [apply bpow_le; omega|simpl; lra]. + [apply bpow_le; lia|simpl; lra]. Qed. Lemma u_rod1pu_ro_pos : (0 <= u_ro / (1 + u_ro))%R. @@ -659,7 +659,7 @@ Proof. intros k Hk. unfold FLT_exp. generalize (Zmax_spec (k - prec) emin). -omega. +lia. Qed. Variable rnd : R -> Z. @@ -843,7 +843,7 @@ destruct relative_error_N_ex with (FLT_exp emin prec) (emin+prec)%Z prec choice as (eps,(Heps1,Heps2)). now apply FLT_exp_valid. intros; unfold FLT_exp. -rewrite Zmax_left; omega. +lia. rewrite Rabs_right;[assumption|apply Rle_ge; now left]. exists eps; exists 0%R. split;[assumption|split]. @@ -869,14 +869,14 @@ rewrite ulp_neq_0. apply bpow_le. unfold FLT_exp, cexp. rewrite Zmax_right. -omega. +lia. destruct (mag beta x) as (e,He); simpl. assert (e-1 < emin+prec)%Z. apply (lt_bpow beta). apply Rle_lt_trans with (2:=Hx). rewrite <- (Rabs_pos_eq x) by now apply Rlt_le. now apply He, Rgt_not_eq. -omega. +lia. split ; ring. Qed. diff --git a/flocq/Prop/Round_odd.v b/flocq/Prop/Round_odd.v index df2952cc..a433c381 100644 --- a/flocq/Prop/Round_odd.v +++ b/flocq/Prop/Round_odd.v @@ -68,7 +68,7 @@ assert (H0:(Zfloor x <= Zfloor y)%Z) by now apply Zfloor_le. case (Zle_lt_or_eq _ _ H0); intros H1. apply Rle_trans with (1:=Zceil_ub _). rewrite Zceil_floor_neq. -apply IZR_le; omega. +apply IZR_le; lia. now apply sym_not_eq. contradict Hy2. rewrite <- H1, Hx2; discriminate. @@ -503,7 +503,7 @@ Proof. intros x Hx. apply generic_inclusion_mag with fexp; trivial; intros Hx2. generalize (fexpe_fexp (mag beta x)). -omega. +lia. Qed. @@ -525,7 +525,7 @@ rewrite Rmult_assoc, <- bpow_plus. rewrite <- Hg1; unfold F2R. apply f_equal, f_equal. ring. -omega. +lia. split; trivial. split. unfold canonical, cexp. @@ -536,7 +536,7 @@ rewrite Z.even_pow. rewrite Even_beta. apply Bool.orb_true_intro. now right. -omega. +lia. Qed. @@ -713,7 +713,7 @@ rewrite Zmult_1_r; apply Rinv_le. exact Rlt_0_2. apply IZR_le. specialize (radix_gt_1 beta). -omega. +lia. apply Rlt_le_trans with (bpow (fexp e)*1)%R. 2: right; ring. unfold Rdiv; apply Rmult_lt_compat_l. @@ -766,7 +766,7 @@ rewrite Zplus_comm; unfold Zminus; apply f_equal2. rewrite Fexp_Fplus. rewrite Z.min_l. now rewrite Fexp_d. -rewrite Hu'2; omega. +rewrite Hu'2; lia. Qed. Lemma m_eq_0: (0 = F2R d)%R -> exists f:float beta, @@ -797,7 +797,7 @@ Lemma fexp_m_eq_0: (0 = F2R d)%R -> Proof with auto with typeclass_instances. intros Y. assert ((fexp (mag beta (F2R u) - 1) <= fexp (mag beta (F2R u))))%Z. -2: omega. +2: lia. destruct (mag beta x) as (e,He). rewrite Rabs_right in He. 2: now left. @@ -812,8 +812,8 @@ ring_simplify (fexp e + 1 - 1)%Z. replace (fexp (fexp e)) with (fexp e). case exists_NE_; intros V. contradict V; rewrite Even_beta; discriminate. -rewrite (proj2 (V e)); omega. -apply sym_eq, valid_exp; omega. +rewrite (proj2 (V e)); lia. +apply sym_eq, valid_exp; lia. Qed. Lemma Fm: generic_format beta fexpe m. @@ -829,7 +829,7 @@ rewrite <- Fexp_d; trivial. rewrite Cd. unfold cexp. generalize (fexpe_fexp (mag beta (F2R d))). -omega. +lia. (* *) destruct m_eq_0 as (g,(Hg1,Hg2)); trivial. apply generic_format_F2R' with g. @@ -838,7 +838,7 @@ intros H; unfold cexp; rewrite Hg2. rewrite mag_m_0; try assumption. apply Z.le_trans with (1:=fexpe_fexp _). generalize (fexp_m_eq_0 Y). -omega. +lia. Qed. @@ -857,7 +857,7 @@ rewrite <- Fexp_d; trivial. rewrite Cd. unfold cexp. generalize (fexpe_fexp (mag beta (F2R d))). -omega. +lia. (* *) destruct m_eq_0 as (g,(Hg1,Hg2)); trivial. apply exists_even_fexp_lt. @@ -866,7 +866,7 @@ rewrite Hg2. rewrite mag_m_0; trivial. apply Z.le_lt_trans with (1:=fexpe_fexp _). generalize (fexp_m_eq_0 Y). -omega. +lia. Qed. @@ -952,7 +952,7 @@ eexists; split. apply sym_eq, Y. simpl; unfold cexp. apply Z.le_lt_trans with (1:=fexpe_fexp _). -omega. +lia. absurd (true=false). discriminate. rewrite <- Hk3, <- Hk'3. @@ -1105,14 +1105,14 @@ intros _; rewrite Zx, round_0... destruct (mag beta x) as (e,He); simpl; intros H. apply mag_unique; split. apply abs_round_ge_generic... -apply FLT_format_bpow... -auto with zarith. +apply generic_format_FLT_bpow... +now apply Z.lt_le_pred. now apply He. assert (V: (Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) <= bpow beta e)%R). apply abs_round_le_generic... -apply FLT_format_bpow... -auto with zarith. +apply generic_format_FLT_bpow... +now apply Zlt_le_weak. left; now apply He. case V; try easy; intros K. assert (H0:Rnd_odd_pt beta (FLT_exp emin prec) x (round beta (FLT_exp emin prec) Zrnd_odd x)). diff --git a/flocq/Prop/Sterbenz.v b/flocq/Prop/Sterbenz.v index 746b7026..9594ac5d 100644 --- a/flocq/Prop/Sterbenz.v +++ b/flocq/Prop/Sterbenz.v @@ -67,7 +67,7 @@ rewrite <- F2R_plus. apply generic_format_F2R. intros _. case_eq (Fplus fx fy). -intros mxy exy Pxy. +intros mxy exy Pxy; simpl. rewrite <- Pxy, F2R_plus, <- Hx, <- Hy. unfold cexp. replace exy with (fexp (Z.min ex ey)). diff --git a/flocq/Version.v b/flocq/Version.v index d0e36a57..aebb0d76 100644 --- a/flocq/Version.v +++ b/flocq/Version.v @@ -29,4 +29,4 @@ Definition Flocq_version := Eval vm_compute in parse t major (minor * 10 + N_of_ascii h - N_of_ascii "0"%char)%N | Empty_string => (major * 100 + minor)%N end in - parse "3.1.0"%string N0 N0. + parse "3.4.0"%string N0 N0. diff --git a/lib/Axioms.v b/lib/Axioms.v index fdc89920..d7b3d036 100644 --- a/lib/Axioms.v +++ b/lib/Axioms.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/lib/BoolEqual.v b/lib/BoolEqual.v index e8c1d831..6479c1ee 100644 --- a/lib/BoolEqual.v +++ b/lib/BoolEqual.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/lib/Camlcoq.ml b/lib/Camlcoq.ml index af65b28e..8ad1ed39 100644 --- a/lib/Camlcoq.ml +++ b/lib/Camlcoq.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/lib/Commandline.ml b/lib/Commandline.ml index 672ed834..2f0d7cc1 100644 --- a/lib/Commandline.ml +++ b/lib/Commandline.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/lib/Commandline.mli b/lib/Commandline.mli index 8bb6f18f..cb9a7513 100644 --- a/lib/Commandline.mli +++ b/lib/Commandline.mli @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/lib/Coqlib.v b/lib/Coqlib.v index 02c5d07f..045fb03a 100644 --- a/lib/Coqlib.v +++ b/lib/Coqlib.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -22,8 +23,7 @@ Require Export ZArith. Require Export Znumtheory. Require Export List. Require Export Bool. - -Global Set Asymmetric Patterns. +Require Export Lia. (** * Useful tactics *) @@ -45,11 +45,7 @@ Ltac decEq := cut (A <> B); [intro; congruence | try discriminate] end. -Ltac byContradiction := - cut False; [contradiction|idtac]. - -Ltac omegaContradiction := - cut False; [contradiction|omega]. +Ltac byContradiction := exfalso. Lemma modusponens: forall (P Q: Prop), P -> (P -> Q) -> Q. Proof. auto. Qed. @@ -119,7 +115,7 @@ Lemma Plt_ne: Proof. unfold Plt; intros. red; intro. subst y. eelim Pos.lt_irrefl; eauto. Qed. -Hint Resolve Plt_ne: coqlib. +Global Hint Resolve Plt_ne: coqlib. Lemma Plt_trans: forall (x y z: positive), Plt x y -> Plt y z -> Plt x z. @@ -130,14 +126,14 @@ Lemma Plt_succ: Proof. unfold Plt; intros. apply Pos.lt_succ_r. apply Pos.le_refl. Qed. -Hint Resolve Plt_succ: coqlib. +Global Hint Resolve Plt_succ: coqlib. Lemma Plt_trans_succ: forall (x y: positive), Plt x y -> Plt x (Pos.succ y). Proof. intros. apply Plt_trans with y. assumption. apply Plt_succ. Qed. -Hint Resolve Plt_succ: coqlib. +Global Hint Resolve Plt_succ: coqlib. Lemma Plt_succ_inv: forall (x y: positive), Plt x (Pos.succ y) -> Plt x y \/ x = y. @@ -178,10 +174,9 @@ Proof (Pos.lt_le_trans). Lemma Plt_strict: forall p, ~ Plt p p. Proof (Pos.lt_irrefl). -Hint Resolve Ple_refl Plt_Ple Ple_succ Plt_strict: coqlib. +Global Hint Resolve Ple_refl Plt_Ple Ple_succ Plt_strict: coqlib. -Ltac xomega := unfold Plt, Ple in *; zify; omega. -Ltac xomegaContradiction := exfalso; xomega. +Ltac extlia := unfold Plt, Ple in *; lia. (** Peano recursion over positive numbers. *) @@ -284,7 +279,7 @@ Lemma zlt_true: Proof. intros. case (zlt x y); intros. auto. - omegaContradiction. + extlia. Qed. Lemma zlt_false: @@ -292,7 +287,7 @@ Lemma zlt_false: x >= y -> (if zlt x y then a else b) = b. Proof. intros. case (zlt x y); intros. - omegaContradiction. + extlia. auto. Qed. @@ -304,7 +299,7 @@ Lemma zle_true: Proof. intros. case (zle x y); intros. auto. - omegaContradiction. + extlia. Qed. Lemma zle_false: @@ -312,7 +307,7 @@ Lemma zle_false: x > y -> (if zle x y then a else b) = b. Proof. intros. case (zle x y); intros. - omegaContradiction. + extlia. auto. Qed. @@ -323,54 +318,54 @@ Proof. reflexivity. Qed. Lemma two_power_nat_pos : forall n : nat, two_power_nat n > 0. Proof. - induction n. rewrite two_power_nat_O. omega. - rewrite two_power_nat_S. omega. + induction n. rewrite two_power_nat_O. lia. + rewrite two_power_nat_S. lia. Qed. Lemma two_power_nat_two_p: forall x, two_power_nat x = two_p (Z.of_nat x). Proof. induction x. auto. - rewrite two_power_nat_S. rewrite Nat2Z.inj_succ. rewrite two_p_S. omega. omega. + rewrite two_power_nat_S. rewrite Nat2Z.inj_succ. rewrite two_p_S. lia. lia. Qed. Lemma two_p_monotone: forall x y, 0 <= x <= y -> two_p x <= two_p y. Proof. intros. - replace (two_p x) with (two_p x * 1) by omega. - replace y with (x + (y - x)) by omega. - rewrite two_p_is_exp; try omega. + replace (two_p x) with (two_p x * 1) by lia. + replace y with (x + (y - x)) by lia. + rewrite two_p_is_exp; try lia. apply Zmult_le_compat_l. - assert (two_p (y - x) > 0). apply two_p_gt_ZERO. omega. omega. - assert (two_p x > 0). apply two_p_gt_ZERO. omega. omega. + assert (two_p (y - x) > 0). apply two_p_gt_ZERO. lia. lia. + assert (two_p x > 0). apply two_p_gt_ZERO. lia. lia. Qed. Lemma two_p_monotone_strict: forall x y, 0 <= x < y -> two_p x < two_p y. Proof. - intros. assert (two_p x <= two_p (y - 1)). apply two_p_monotone; omega. - assert (two_p (y - 1) > 0). apply two_p_gt_ZERO. omega. - replace y with (Z.succ (y - 1)) by omega. rewrite two_p_S. omega. omega. + intros. assert (two_p x <= two_p (y - 1)). apply two_p_monotone; lia. + assert (two_p (y - 1) > 0). apply two_p_gt_ZERO. lia. + replace y with (Z.succ (y - 1)) by lia. rewrite two_p_S. lia. lia. Qed. Lemma two_p_strict: forall x, x >= 0 -> x < two_p x. Proof. intros x0 GT. pattern x0. apply natlike_ind. - simpl. omega. - intros. rewrite two_p_S; auto. generalize (two_p_gt_ZERO x H). omega. - omega. + simpl. lia. + intros. rewrite two_p_S; auto. generalize (two_p_gt_ZERO x H). lia. + lia. Qed. Lemma two_p_strict_2: forall x, x >= 0 -> 2 * x - 1 < two_p x. Proof. - intros. assert (x = 0 \/ x - 1 >= 0) by omega. destruct H0. + intros. assert (x = 0 \/ x - 1 >= 0) by lia. destruct H0. subst. vm_compute. auto. replace (two_p x) with (2 * two_p (x - 1)). - generalize (two_p_strict _ H0). omega. - rewrite <- two_p_S. decEq. omega. omega. + generalize (two_p_strict _ H0). lia. + rewrite <- two_p_S. decEq. lia. lia. Qed. (** Properties of [Zmin] and [Zmax] *) @@ -401,12 +396,12 @@ Qed. Lemma Zmax_bound_l: forall x y z, x <= y -> x <= Z.max y z. Proof. - intros. generalize (Z.le_max_l y z). omega. + intros. generalize (Z.le_max_l y z). lia. Qed. Lemma Zmax_bound_r: forall x y z, x <= z -> x <= Z.max y z. Proof. - intros. generalize (Z.le_max_r y z). omega. + intros. generalize (Z.le_max_r y z). lia. Qed. (** Properties of Euclidean division and modulus. *) @@ -416,7 +411,7 @@ Lemma Zmod_unique: x = a * y + b -> 0 <= b < y -> x mod y = b. Proof. intros. subst x. rewrite Z.add_comm. - rewrite Z_mod_plus. apply Z.mod_small. auto. omega. + rewrite Z_mod_plus. apply Z.mod_small. auto. lia. Qed. Lemma Zdiv_unique: @@ -424,14 +419,14 @@ Lemma Zdiv_unique: x = a * y + b -> 0 <= b < y -> x / y = a. Proof. intros. subst x. rewrite Z.add_comm. - rewrite Z_div_plus. rewrite (Zdiv_small b y H0). omega. omega. + rewrite Z_div_plus. rewrite (Zdiv_small b y H0). lia. lia. Qed. Lemma Zdiv_Zdiv: forall a b c, b > 0 -> c > 0 -> (a / b) / c = a / (b * c). Proof. - intros. apply Z.div_div; omega. + intros. apply Z.div_div; lia. Qed. Lemma Zdiv_interval_1: @@ -445,14 +440,14 @@ Proof. set (q := a/b) in *. set (r := a mod b) in *. split. assert (lo < (q + 1)). - apply Zmult_lt_reg_r with b. omega. - apply Z.le_lt_trans with a. omega. + apply Zmult_lt_reg_r with b. lia. + apply Z.le_lt_trans with a. lia. replace ((q + 1) * b) with (b * q + b) by ring. - omega. - omega. - apply Zmult_lt_reg_r with b. omega. + lia. + lia. + apply Zmult_lt_reg_r with b. lia. replace (q * b) with (b * q) by ring. - omega. + lia. Qed. Lemma Zdiv_interval_2: @@ -462,13 +457,13 @@ Lemma Zdiv_interval_2: Proof. intros. assert (lo <= a / b < hi+1). - apply Zdiv_interval_1. omega. omega. auto. - assert (lo * b <= lo * 1) by (apply Z.mul_le_mono_nonpos_l; omega). + apply Zdiv_interval_1. lia. lia. auto. + assert (lo * b <= lo * 1) by (apply Z.mul_le_mono_nonpos_l; lia). replace (lo * 1) with lo in H3 by ring. - assert ((hi + 1) * 1 <= (hi + 1) * b) by (apply Z.mul_le_mono_nonneg_l; omega). + assert ((hi + 1) * 1 <= (hi + 1) * b) by (apply Z.mul_le_mono_nonneg_l; lia). replace ((hi + 1) * 1) with (hi + 1) in H4 by ring. - omega. - omega. + lia. + lia. Qed. Lemma Zmod_recombine: @@ -476,7 +471,7 @@ Lemma Zmod_recombine: a > 0 -> b > 0 -> x mod (a * b) = ((x/b) mod a) * b + (x mod b). Proof. - intros. rewrite (Z.mul_comm a b). rewrite Z.rem_mul_r by omega. ring. + intros. rewrite (Z.mul_comm a b). rewrite Z.rem_mul_r by lia. ring. Qed. (** Properties of divisibility. *) @@ -486,9 +481,9 @@ Lemma Zdivide_interval: 0 < c -> 0 <= a < b -> (c | a) -> (c | b) -> 0 <= a <= b - c. Proof. intros. destruct H1 as [x EQ1]. destruct H2 as [y EQ2]. subst. destruct H0. - split. omega. exploit Zmult_lt_reg_r; eauto. intros. + split. lia. exploit Zmult_lt_reg_r; eauto. intros. replace (y * c - c) with ((y - 1) * c) by ring. - apply Zmult_le_compat_r; omega. + apply Zmult_le_compat_r; lia. Qed. (** Conversion from [Z] to [nat]. *) @@ -503,8 +498,8 @@ Lemma Z_to_nat_max: forall z, Z.of_nat (Z.to_nat z) = Z.max z 0. Proof. intros. destruct (zle 0 z). -- rewrite Z2Nat.id by auto. xomega. -- rewrite Z_to_nat_neg by omega. xomega. +- rewrite Z2Nat.id by auto. extlia. +- rewrite Z_to_nat_neg by lia. extlia. Qed. (** Alignment: [align n amount] returns the smallest multiple of [amount] @@ -519,8 +514,8 @@ Proof. generalize (Z_div_mod_eq (x + y - 1) y H). intro. replace ((x + y - 1) / y * y) with ((x + y - 1) - (x + y - 1) mod y). - generalize (Z_mod_lt (x + y - 1) y H). omega. - rewrite Z.mul_comm. omega. + generalize (Z_mod_lt (x + y - 1) y H). lia. + rewrite Z.mul_comm. lia. Qed. Lemma align_divides: forall x y, y > 0 -> (y | align x y). @@ -528,6 +523,60 @@ Proof. intros. unfold align. apply Z.divide_factor_r. Qed. +Lemma align_lt: forall x y, y > 0 -> align x y < x + y. +Proof. + intros. unfold align. + generalize (Z_div_mod_eq (x + y - 1) y H); intro. + generalize (Z_mod_lt (x + y - 1) y H); intro. + lia. +Qed. + +Lemma align_same: + forall x y, y > 0 -> (y | x) -> align x y = x. +Proof. + unfold align; intros. destruct H0 as [k E]. + replace (x + y - 1) with (x + (y - 1)) by lia. + rewrite E, Z.div_add_l, Z.div_small by lia. + lia. +Qed. + +(** Floor: [floor n amount] returns the greatest multiple of [amount] + less than or equal to [n]. *) + +Definition floor (n: Z) (amount: Z) := (n / amount) * amount. + +Lemma floor_interval: + forall x y, y > 0 -> floor x y <= x < floor x y + y. +Proof. + unfold floor; intros. + generalize (Z_div_mod_eq x y H) (Z_mod_lt x y H). + set (q := x / y). set (r := x mod y). intros. lia. +Qed. + +Lemma floor_divides: + forall x y, y > 0 -> (y | floor x y). +Proof. + unfold floor; intros. exists (x / y); auto. +Qed. + +Lemma floor_same: + forall x y, y > 0 -> (y | x) -> floor x y = x. +Proof. + unfold floor; intros. rewrite (Zdivide_Zdiv_eq y x) at 2; auto; lia. +Qed. + +Lemma floor_align_interval: + forall x y, y > 0 -> + floor x y <= align x y <= floor x y + y. +Proof. + unfold floor, align; intros. + replace (x / y * y + y) with ((x + 1 * y) / y * y). + assert (A: forall a b, a <= b -> a / y * y <= b / y * y). + { intros. apply Z.mul_le_mono_nonneg_r. lia. apply Z.div_le_mono; lia. } + split; apply A; lia. + rewrite Z.div_add by lia. lia. +Qed. + (** * Definitions and theorems on the data types [option], [sum] and [list] *) Set Implicit Arguments. @@ -563,7 +612,7 @@ Definition sum_left_map (A B C: Type) (f: A -> B) (x: A + C) : B + C := (** Properties of [List.nth] (n-th element of a list). *) -Hint Resolve in_eq in_cons: coqlib. +Global Hint Resolve in_eq in_cons: coqlib. Lemma nth_error_in: forall (A: Type) (n: nat) (l: list A) (x: A), @@ -577,14 +626,14 @@ Proof. discriminate. apply in_cons. auto. Qed. -Hint Resolve nth_error_in: coqlib. +Global Hint Resolve nth_error_in: coqlib. Lemma nth_error_nil: forall (A: Type) (idx: nat), nth_error (@nil A) idx = None. Proof. induction idx; simpl; intros; reflexivity. Qed. -Hint Resolve nth_error_nil: coqlib. +Global Hint Resolve nth_error_nil: coqlib. (** Compute the length of a list, with result in [Z]. *) @@ -599,8 +648,8 @@ Remark list_length_z_aux_shift: list_length_z_aux l n = list_length_z_aux l m + (n - m). Proof. induction l; intros; simpl. - omega. - replace (n - m) with (Z.succ n - Z.succ m) by omega. auto. + lia. + replace (n - m) with (Z.succ n - Z.succ m) by lia. auto. Qed. Definition list_length_z (A: Type) (l: list A) : Z := @@ -611,15 +660,15 @@ Lemma list_length_z_cons: list_length_z (hd :: tl) = list_length_z tl + 1. Proof. intros. unfold list_length_z. simpl. - rewrite (list_length_z_aux_shift tl 1 0). omega. + rewrite (list_length_z_aux_shift tl 1 0). lia. Qed. Lemma list_length_z_pos: forall (A: Type) (l: list A), list_length_z l >= 0. Proof. - induction l; simpl. unfold list_length_z; simpl. omega. - rewrite list_length_z_cons. omega. + induction l; simpl. unfold list_length_z; simpl. lia. + rewrite list_length_z_cons. lia. Qed. Lemma list_length_z_map: @@ -663,8 +712,8 @@ Proof. induction l; simpl; intros. discriminate. rewrite list_length_z_cons. destruct (zeq n 0). - generalize (list_length_z_pos l); omega. - exploit IHl; eauto. omega. + generalize (list_length_z_pos l); lia. + exploit IHl; eauto. lia. Qed. (** Properties of [List.incl] (list inclusion). *) @@ -675,7 +724,7 @@ Lemma incl_cons_inv: Proof. unfold incl; intros. apply H. apply in_cons. auto. Qed. -Hint Resolve incl_cons_inv: coqlib. +Global Hint Resolve incl_cons_inv: coqlib. Lemma incl_app_inv_l: forall (A: Type) (l1 l2 m: list A), @@ -691,7 +740,7 @@ Proof. unfold incl; intros. apply H. apply in_or_app. right; assumption. Qed. -Hint Resolve incl_tl incl_refl incl_app_inv_l incl_app_inv_r: coqlib. +Global Hint Resolve incl_tl incl_refl incl_app_inv_l incl_app_inv_r: coqlib. Lemma incl_same_head: forall (A: Type) (x: A) (l1 l2: list A), @@ -776,6 +825,32 @@ Proof. exists (a0 :: l1); exists l2; intuition. simpl; congruence. Qed. +(** Properties of [List.app] (concatenation) *) + +Lemma list_append_injective_l: + forall (A: Type) (l1 l2 l1' l2': list A), + l1 ++ l2 = l1' ++ l2' -> List.length l1 = List.length l1' -> l1 = l1' /\ l2 = l2'. +Proof. + intros until l2'. revert l1 l1'. induction l1 as [ | a l1]; destruct l1' as [ | a' l1']; simpl; intros. +- auto. +- discriminate. +- discriminate. +- destruct (IHl1 l1'). congruence. congruence. split; congruence. +Qed. + +Lemma list_append_injective_r: + forall (A: Type) (l1 l2 l1' l2': list A), + l1 ++ l2 = l1' ++ l2' -> List.length l2 = List.length l2' -> l1 = l1' /\ l2 = l2'. +Proof. + intros. + assert (X: rev l2 = rev l2' /\ rev l1 = rev l1'). + { apply list_append_injective_l. + rewrite <- ! rev_app_distr. congruence. + rewrite ! rev_length; auto. } + rewrite <- (rev_involutive l1), <- (rev_involutive l1'), <- (rev_involutive l2), <- (rev_involutive l2'). + intuition congruence. +Qed. + (** Folding a function over a list *) Section LIST_FOLD. @@ -1015,6 +1090,14 @@ Proof. generalize list_norepet_app; firstorder. Qed. +Lemma list_norepet_rev: + forall (A: Type) (l: list A), list_norepet l -> list_norepet (List.rev l). +Proof. + induction 1; simpl. +- constructor. +- apply list_norepet_append_commut. simpl. constructor; auto. rewrite <- List.in_rev; auto. +Qed. + (** [is_tail l1 l2] holds iff [l2] is of the form [l ++ l1] for some [l]. *) Inductive is_tail (A: Type): list A -> list A -> Prop := @@ -1038,7 +1121,7 @@ Proof. constructor. constructor. constructor. auto. Qed. -Hint Resolve is_tail_refl is_tail_cons is_tail_in is_tail_cons_left: coqlib. +Global Hint Resolve is_tail_refl is_tail_cons is_tail_in is_tail_cons_left: coqlib. Lemma is_tail_incl: forall (A: Type) (l1 l2: list A), is_tail l1 l2 -> incl l1 l2. @@ -1149,26 +1232,6 @@ Proof. destruct l; simpl; auto. Qed. -(** A list of [n] elements, all equal to [x]. *) - -Fixpoint list_repeat {A: Type} (n: nat) (x: A) {struct n} := - match n with - | O => nil - | S m => x :: list_repeat m x - end. - -Lemma length_list_repeat: - forall (A: Type) n (x: A), length (list_repeat n x) = n. -Proof. - induction n; simpl; intros. auto. decEq; auto. -Qed. - -Lemma in_list_repeat: - forall (A: Type) n (x: A) y, In y (list_repeat n x) -> y = x. -Proof. - induction n; simpl; intros. elim H. destruct H; auto. -Qed. - (** * Definitions and theorems over boolean types *) Definition proj_sumbool {P Q: Prop} (a: {P} + {Q}) : bool := diff --git a/lib/Decidableplus.v b/lib/Decidableplus.v index 66dffb3a..69ba4723 100644 --- a/lib/Decidableplus.v +++ b/lib/Decidableplus.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -126,14 +127,14 @@ Program Instance Decidable_ge_Z : forall (x y: Z), Decidable (x >= y) := { Decidable_witness := Z.geb x y }. Next Obligation. - rewrite Z.geb_le. intuition omega. + rewrite Z.geb_le. intuition lia. Qed. Program Instance Decidable_gt_Z : forall (x y: Z), Decidable (x > y) := { Decidable_witness := Z.gtb x y }. Next Obligation. - rewrite Z.gtb_lt. intuition omega. + rewrite Z.gtb_lt. intuition lia. Qed. Program Instance Decidable_divides : forall (x y: Z), Decidable (x | y) := { @@ -146,7 +147,7 @@ Next Obligation. destruct (Z.eq_dec x 0). subst x. rewrite Z.mul_0_r in EQ. subst y. reflexivity. assert (k = y / x). - { apply Zdiv_unique_full with 0. red; omega. rewrite EQ; ring. } + { apply Zdiv_unique_full with 0. red; lia. rewrite EQ; ring. } congruence. Qed. diff --git a/lib/FSetAVLplus.v b/lib/FSetAVLplus.v index f16805c6..936814c1 100644 --- a/lib/FSetAVLplus.v +++ b/lib/FSetAVLplus.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/lib/Floats.v b/lib/Floats.v index b7769420..43caebb0 100644 --- a/lib/Floats.v +++ b/lib/Floats.v @@ -7,10 +7,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -25,6 +26,7 @@ Import ListNotations. Close Scope R_scope. Open Scope Z_scope. +Set Asymmetric Patterns. Definition float := binary64. (**r the type of IEE754 double-precision FP numbers *) Definition float32 := binary32. (**r the type of IEE754 single-precision FP numbers *) @@ -108,7 +110,7 @@ Proof. { apply Digits.Zdigits_le_Zpower. rewrite <- H. rewrite Z.abs_eq; tauto. } destruct (zeq p' 0). - rewrite e. simpl; auto. -- rewrite Z2Pos.id by omega. omega. +- rewrite Z2Pos.id by lia. lia. Qed. (** Transform a Nan payload to a quiet Nan payload. *) @@ -117,7 +119,7 @@ Definition quiet_nan_64_payload (p: positive) := Z.to_pos (P_mod_two_p (Pos.lor p ((iter_nat xO 51 1%positive))) 52%nat). Lemma quiet_nan_64_proof: forall p, nan_pl 53 (quiet_nan_64_payload p) = true. -Proof. intros; apply normalized_nan; auto; omega. Qed. +Proof. intros; apply normalized_nan; auto; lia. Qed. Definition quiet_nan_64 (sp: bool * positive) : {x :float | is_nan _ _ x = true} := let (s, p) := sp in @@ -129,7 +131,7 @@ Definition quiet_nan_32_payload (p: positive) := Z.to_pos (P_mod_two_p (Pos.lor p ((iter_nat xO 22 1%positive))) 23%nat). Lemma quiet_nan_32_proof: forall p, nan_pl 24 (quiet_nan_32_payload p) = true. -Proof. intros; apply normalized_nan; auto; omega. Qed. +Proof. intros; apply normalized_nan; auto; lia. Qed. Definition quiet_nan_32 (sp: bool * positive) : {x :float32 | is_nan _ _ x = true} := let (s, p) := sp in @@ -163,7 +165,7 @@ Proof. rewrite Z.ltb_lt in *. unfold Pos.shiftl_nat, nat_rect, Digits.digits2_pos. fold (Digits.digits2_pos p). - zify; omega. + zify; lia. Qed. Definition expand_nan s p H : {x | is_nan _ _ x = true} := @@ -336,7 +338,7 @@ Ltac smart_omega := compute_this Int64.modulus; compute_this Int64.half_modulus; compute_this Int64.max_unsigned; compute_this (Z.pow_pos 2 1024); compute_this (Z.pow_pos 2 53); compute_this (Z.pow_pos 2 52); compute_this (Z.pow_pos 2 32); - zify; omega. + zify; lia. (** Commutativity properties of addition and multiplication. *) @@ -432,7 +434,7 @@ Proof. intros; unfold of_bits, to_bits, bits_of_b64, b64_of_bits. rewrite Int64.unsigned_repr, binary_float_of_bits_of_binary_float; [reflexivity|]. generalize (bits_of_binary_float_range 52 11 __ __ f). - change (2^(52+11+1)) with (Int64.max_unsigned + 1). omega. + change (2^(52+11+1)) with (Int64.max_unsigned + 1). lia. Qed. Theorem to_of_bits: @@ -476,7 +478,7 @@ Proof. rewrite BofZ_plus by auto. f_equal. unfold Int.ltu in H. destruct zlt in H; try discriminate. - unfold y, Int.sub. rewrite Int.signed_repr. omega. + unfold y, Int.sub. rewrite Int.signed_repr. lia. compute_this (Int.unsigned ox8000_0000); smart_omega. Qed. @@ -498,8 +500,8 @@ Proof. change (Int.and ox7FFF_FFFF ox8000_0000) with Int.zero. rewrite ! Int.and_zero; auto. } assert (RNG: 0 <= Int.unsigned lo < two_p 31). - { unfold lo. change ox7FFF_FFFF with (Int.repr (two_p 31 - 1)). rewrite <- Int.zero_ext_and by omega. - apply Int.zero_ext_range. compute_this Int.zwordsize. omega. } + { unfold lo. change ox7FFF_FFFF with (Int.repr (two_p 31 - 1)). rewrite <- Int.zero_ext_and by lia. + apply Int.zero_ext_range. compute_this Int.zwordsize. lia. } assert (B: forall i, 0 <= i < Int.zwordsize -> Int.testbit ox8000_0000 i = if zeq i 31 then true else false). { intros; unfold Int.testbit. change (Int.unsigned ox8000_0000) with (2^31). destruct (zeq i 31). subst i; auto. apply Z.pow2_bits_false; auto. } @@ -512,12 +514,12 @@ Proof. assert (SU: - Int.signed hi = Int.unsigned hi). { destruct EITHER as [EQ|EQ]; rewrite EQ; reflexivity. } unfold Z.sub; rewrite SU, <- E. - unfold Int.add; rewrite Int.unsigned_repr, Int.signed_eq_unsigned. omega. - - assert (Int.max_signed = two_p 31 - 1) by reflexivity. omega. + unfold Int.add; rewrite Int.unsigned_repr, Int.signed_eq_unsigned. lia. + - assert (Int.max_signed = two_p 31 - 1) by reflexivity. lia. - assert (Int.unsigned hi = 0 \/ Int.unsigned hi = two_p 31) by (destruct EITHER as [EQ|EQ]; rewrite EQ; [left|right]; reflexivity). assert (Int.max_unsigned = two_p 31 + two_p 31 - 1) by reflexivity. - omega. + lia. Qed. Theorem to_intu_to_int_1: @@ -540,14 +542,14 @@ Proof. { rewrite ZofB_correct in C. destruct (is_finite _ _ x) eqn:FINx; congruence. } destruct (zeq p 0). subst p; smart_omega. - destruct (ZofB_range_pos 53 1024 __ __ x p C) as [P Q]. omega. + destruct (ZofB_range_pos 53 1024 __ __ x p C) as [P Q]. lia. assert (CMP: Bcompare _ _ x y = Some Lt). { unfold cmp, cmp_of_comparison, compare in H. destruct (Bcompare _ _ x y) as [[]|]; auto; discriminate. } rewrite Bcompare_correct in CMP by auto. inv CMP. apply Rcompare_Lt_inv in H1. rewrite EQy in H1. assert (p < Int.unsigned ox8000_0000). { apply lt_IZR. apply Rle_lt_trans with (1 := P) (2 := H1). } - change Int.max_signed with (Int.unsigned ox8000_0000 - 1). omega. + change Int.max_signed with (Int.unsigned ox8000_0000 - 1). lia. Qed. Theorem to_intu_to_int_2: @@ -579,7 +581,7 @@ Proof. compute_this (Int.unsigned ox8000_0000). smart_omega. apply Rge_le; auto. } - unfold to_int; rewrite EQ. simpl. unfold Int.sub. rewrite Int.unsigned_repr by omega. auto. + unfold to_int; rewrite EQ. simpl. unfold Int.sub. rewrite Int.unsigned_repr by lia. auto. Qed. (** Conversions from ints to floats can be defined as bitwise manipulations @@ -598,8 +600,8 @@ Proof. - f_equal. rewrite Int64.ofwords_add'. reflexivity. - apply split_join_bits. generalize (Int.unsigned_range x). - compute_this Int.modulus; compute_this (2^52); omega. - compute_this (2^11); omega. + compute_this Int.modulus; compute_this (2^52); lia. + compute_this (2^11); lia. Qed. Lemma from_words_value: @@ -637,7 +639,7 @@ Theorem of_intu_from_words: Proof. intros. pose proof (Int.unsigned_range x). rewrite ! from_words_eq. unfold sub. rewrite BofZ_minus. - unfold of_intu. apply (f_equal (BofZ 53 1024 __ __)). rewrite Int.unsigned_zero. omega. + unfold of_intu. apply (f_equal (BofZ 53 1024 __ __)). rewrite Int.unsigned_zero. lia. apply integer_representable_n; auto; smart_omega. apply integer_representable_n; auto; rewrite Int.unsigned_zero; smart_omega. Qed. @@ -664,7 +666,7 @@ Proof. rewrite ! from_words_eq. rewrite ox8000_0000_signed_unsigned. change (Int.unsigned ox8000_0000) with Int.half_modulus. unfold sub. rewrite BofZ_minus. - unfold of_int. apply f_equal. omega. + unfold of_int. apply f_equal. lia. apply integer_representable_n; auto; smart_omega. apply integer_representable_n; auto; smart_omega. Qed. @@ -680,8 +682,8 @@ Proof. - f_equal. rewrite Int64.ofwords_add'. reflexivity. - apply split_join_bits. generalize (Int.unsigned_range x). - compute_this Int.modulus; compute_this (2^52); omega. - compute_this (2^11); omega. + compute_this Int.modulus; compute_this (2^52); lia. + compute_this (2^11); lia. Qed. Lemma from_words_value': @@ -711,11 +713,11 @@ Proof. destruct (BofZ_representable 53 1024 __ __ (2^84 + Int.unsigned x * 2^32)) as (D & E & F). replace (2^84 + Int.unsigned x * 2^32) with ((2^52 + Int.unsigned x) * 2^32) by ring. - apply integer_representable_n2p; auto. smart_omega. omega. omega. + apply integer_representable_n2p; auto. smart_omega. lia. lia. apply B2R_Bsign_inj; auto. - rewrite A, D. rewrite <- IZR_Zpower by omega. rewrite <- plus_IZR. auto. + rewrite A, D. rewrite <- IZR_Zpower by lia. rewrite <- plus_IZR. auto. rewrite C, F. symmetry. apply Zlt_bool_false. - compute_this (2^84); compute_this (2^32); omega. + compute_this (2^84); compute_this (2^32); lia. Qed. Theorem of_longu_from_words: @@ -742,12 +744,12 @@ Proof. rewrite <- (Int64.ofwords_recompose l) at 1. rewrite Int64.ofwords_add'. fold xh; fold xl. compute_this (two_p 32); compute_this p20; ring. apply integer_representable_n2p; auto. - compute_this p20; smart_omega. omega. omega. + compute_this p20; smart_omega. lia. lia. apply integer_representable_n; auto; smart_omega. replace (2^84 + xh * 2^32) with ((2^52 + xh) * 2^32) by ring. - apply integer_representable_n2p; auto. smart_omega. omega. omega. + apply integer_representable_n2p; auto. smart_omega. lia. lia. change (2^84 + p20 * 2^32) with ((2^52 + 1048576) * 2^32). - apply integer_representable_n2p; auto. omega. omega. + apply integer_representable_n2p; auto. lia. lia. Qed. Theorem of_long_from_words: @@ -776,15 +778,15 @@ Proof. rewrite <- (Int64.ofwords_recompose l) at 1. rewrite Int64.ofwords_add''. fold xh; fold xl. compute_this (two_p 32); ring. apply integer_representable_n2p; auto. - compute_this (2^20); smart_omega. omega. omega. + compute_this (2^20); smart_omega. lia. lia. apply integer_representable_n; auto; smart_omega. replace (2^84 + (xh + Int.half_modulus) * 2^32) with ((2^52 + xh + Int.half_modulus) * 2^32) by (compute_this Int.half_modulus; ring). - apply integer_representable_n2p; auto. smart_omega. omega. omega. + apply integer_representable_n2p; auto. smart_omega. lia. lia. change (2^84 + p * 2^32) with ((2^52 + p) * 2^32). apply integer_representable_n2p; auto. - compute_this p; smart_omega. omega. + compute_this p; smart_omega. lia. Qed. (** Conversions from 64-bit integers can be expressed in terms of @@ -806,7 +808,7 @@ Proof. assert (DECOMP: x = yh * 2^32 + yl). { unfold x. rewrite <- (Int64.ofwords_recompose l). apply Int64.ofwords_add'. } rewrite BofZ_mult. rewrite BofZ_plus. rewrite DECOMP; auto. - apply integer_representable_n2p; auto. smart_omega. omega. omega. + apply integer_representable_n2p; auto. smart_omega. lia. lia. apply integer_representable_n; auto; smart_omega. apply integer_representable_n; auto; smart_omega. apply integer_representable_n; auto; smart_omega. @@ -829,7 +831,7 @@ Proof. assert (DECOMP: x = yh * 2^32 + yl). { unfold x. rewrite <- (Int64.ofwords_recompose l), Int64.ofwords_add''. auto. } rewrite BofZ_mult. rewrite BofZ_plus. rewrite DECOMP; auto. - apply integer_representable_n2p; auto. smart_omega. omega. omega. + apply integer_representable_n2p; auto. smart_omega. lia. lia. apply integer_representable_n; auto; smart_omega. apply integer_representable_n; auto; smart_omega. apply integer_representable_n; auto. compute; intuition congruence. @@ -871,53 +873,53 @@ Proof. { intros; unfold n; autorewrite with ints; auto. rewrite Int64.unsigned_one. rewrite Int64.bits_one. compute_this Int64.zwordsize. destruct (zeq i 0); simpl proj_sumbool. - rewrite zlt_true by omega. rewrite andb_true_r. subst i; auto. + rewrite zlt_true by lia. rewrite andb_true_r. subst i; auto. rewrite andb_false_r, orb_false_r. - destruct (zeq i 63). subst i. apply zlt_false; omega. - apply zlt_true; omega. } + destruct (zeq i 63). subst i. apply zlt_false; lia. + apply zlt_true; lia. } assert (NB2: forall i, 0 <= i -> Z.testbit (Int64.signed n * 2^1) i = if zeq i 0 then false else if zeq i 1 then Int64.testbit x 1 || Int64.testbit x 0 else Int64.testbit x i). - { intros. rewrite Z.mul_pow2_bits by omega. destruct (zeq i 0). - apply Z.testbit_neg_r; omega. - rewrite Int64.bits_signed by omega. compute_this Int64.zwordsize. + { intros. rewrite Z.mul_pow2_bits by lia. destruct (zeq i 0). + apply Z.testbit_neg_r; lia. + rewrite Int64.bits_signed by lia. compute_this Int64.zwordsize. destruct (zlt (i-1) 64). - rewrite NB by omega. destruct (zeq i 1). + rewrite NB by lia. destruct (zeq i 1). subst. rewrite dec_eq_true by auto. auto. - rewrite dec_eq_false by omega. destruct (zeq (i - 1) 63). - symmetry. apply Int64.bits_above. compute_this Int64.zwordsize; omega. - f_equal; omega. - rewrite NB by omega. rewrite dec_eq_false by omega. rewrite dec_eq_true by auto. - rewrite dec_eq_false by omega. symmetry. apply Int64.bits_above. compute_this Int64.zwordsize; omega. + rewrite dec_eq_false by lia. destruct (zeq (i - 1) 63). + symmetry. apply Int64.bits_above. compute_this Int64.zwordsize; lia. + f_equal; lia. + rewrite NB by lia. rewrite dec_eq_false by lia. rewrite dec_eq_true by auto. + rewrite dec_eq_false by lia. symmetry. apply Int64.bits_above. compute_this Int64.zwordsize; lia. } assert (EQ: Int64.signed n * 2 = int_round_odd (Int64.unsigned x) 1). { - symmetry. apply (int_round_odd_bits 53 1024). omega. - intros. rewrite NB2 by omega. replace i with 0 by omega. auto. - rewrite NB2 by omega. rewrite dec_eq_false by omega. rewrite dec_eq_true. + symmetry. apply int_round_odd_bits. lia. + intros. rewrite NB2 by lia. replace i with 0 by lia. auto. + rewrite NB2 by lia. rewrite dec_eq_false by lia. rewrite dec_eq_true. rewrite orb_comm. unfold Int64.testbit. change (2^1) with 2. destruct (Z.testbit (Int64.unsigned x) 0) eqn:B0; - [rewrite Z.testbit_true in B0 by omega|rewrite Z.testbit_false in B0 by omega]; + [rewrite Z.testbit_true in B0 by lia|rewrite Z.testbit_false in B0 by lia]; change (2^0) with 1 in B0; rewrite Zdiv_1_r in B0; rewrite B0; auto. - intros. rewrite NB2 by omega. rewrite ! dec_eq_false by omega. auto. + intros. rewrite NB2 by lia. rewrite ! dec_eq_false by lia. auto. } unfold mul, of_long, of_longu. rewrite BofZ_mult_2p. - change (2^1) with 2. rewrite EQ. apply BofZ_round_odd with (p := 1). -+ omega. ++ lia. + apply Z.le_trans with Int64.modulus; trivial. smart_omega. -+ omega. -+ apply Z.le_trans with (2^63). compute; intuition congruence. xomega. ++ lia. ++ apply Z.le_trans with (2^63). compute; intuition congruence. extlia. - apply Z.le_trans with Int64.modulus; trivial. pose proof (Int64.signed_range n). compute_this Int64.min_signed; compute_this Int64.max_signed; - compute_this Int64.modulus; xomega. + compute_this Int64.modulus; extlia. - assert (2^63 <= int_round_odd (Int64.unsigned x) 1). - { change (2^63) with (int_round_odd (2^63) 1). apply (int_round_odd_le 0 0); omega. } - rewrite <- EQ in H1. compute_this (2^63). compute_this (2^53). xomega. -- omega. + { change (2^63) with (int_round_odd (2^63) 1). apply int_round_odd_le; lia. } + rewrite <- EQ in H1. compute_this (2^63). compute_this (2^53). extlia. +- lia. Qed. (** Conversions to/from 32-bit integers can be implemented by going through 64-bit integers. *) @@ -931,8 +933,8 @@ Proof. intros. exploit ZofB_range_inversion; eauto. intros (A & B & C). unfold ZofB_range; rewrite C. replace (min2 <=? n) with true. replace (n <=? max2) with true. auto. - symmetry; apply Z.leb_le; omega. - symmetry; apply Z.leb_le; omega. + symmetry; apply Z.leb_le; lia. + symmetry; apply Z.leb_le; lia. Qed. Theorem to_int_to_long: @@ -954,7 +956,7 @@ Proof. exploit ZofB_range_inversion; eauto. intros (A & B & C). replace (ZofB_range 53 1024 f 0 Int64.max_unsigned) with (Some z). simpl. rewrite Int.unsigned_repr; auto. - symmetry; eapply ZofB_range_widen; eauto. omega. compute; congruence. + symmetry; eapply ZofB_range_widen; eauto. lia. compute; congruence. Qed. Theorem to_intu_to_long: @@ -1183,7 +1185,7 @@ Theorem cmp_double: forall f1 f2 c, cmp c f1 f2 = Float.cmp c (to_double f1) (to_double f2). Proof. unfold cmp, Float.cmp; intros. f_equal. symmetry. apply Bcompare_Bconv_widen. - red; omega. omega. omega. + red; lia. lia. lia. Qed. (** Properties of conversions to/from in-memory representation. @@ -1195,7 +1197,7 @@ Proof. intros; unfold of_bits, to_bits, bits_of_b32, b32_of_bits. rewrite Int.unsigned_repr, binary_float_of_bits_of_binary_float; [reflexivity|]. generalize (bits_of_binary_float_range 23 8 __ __ f). - change (2^(23+8+1)) with (Int.max_unsigned + 1). omega. + change (2^(23+8+1)) with (Int.max_unsigned + 1). lia. Qed. Theorem to_of_bits: @@ -1235,7 +1237,7 @@ Proof. unfold to_int in H. destruct (ZofB_range _ _ f Int.min_signed Int.max_signed) as [n'|] eqn:E; inv H. unfold Float.to_int, to_double, Float.of_single. - erewrite ZofB_range_Bconv; eauto. auto. omega. omega. omega. omega. + erewrite ZofB_range_Bconv; eauto. auto. lia. lia. lia. lia. Qed. Theorem to_intu_double: @@ -1245,7 +1247,7 @@ Proof. unfold to_intu in H. destruct (ZofB_range _ _ f 0 Int.max_unsigned) as [n'|] eqn:E; inv H. unfold Float.to_intu, to_double, Float.of_single. - erewrite ZofB_range_Bconv; eauto. auto. omega. omega. omega. omega. + erewrite ZofB_range_Bconv; eauto. auto. lia. lia. lia. lia. Qed. Theorem to_long_double: @@ -1255,7 +1257,7 @@ Proof. unfold to_long in H. destruct (ZofB_range _ _ f Int64.min_signed Int64.max_signed) as [n'|] eqn:E; inv H. unfold Float.to_long, to_double, Float.of_single. - erewrite ZofB_range_Bconv; eauto. auto. omega. omega. omega. omega. + erewrite ZofB_range_Bconv; eauto. auto. lia. lia. lia. lia. Qed. Theorem to_longu_double: @@ -1265,7 +1267,7 @@ Proof. unfold to_longu in H. destruct (ZofB_range _ _ f 0 Int64.max_unsigned) as [n'|] eqn:E; inv H. unfold Float.to_longu, to_double, Float.of_single. - erewrite ZofB_range_Bconv; eauto. auto. omega. omega. omega. omega. + erewrite ZofB_range_Bconv; eauto. auto. lia. lia. lia. lia. Qed. (** Conversions from 64-bit integers to single-precision floats can be expressed @@ -1280,37 +1282,37 @@ Proof. intros. assert (POS: 0 < 2^p) by (apply (Zpower_gt_0 radix2); auto). assert (A: Z.land n (2^p-1) = n mod 2^p). - { rewrite <- Z.land_ones by auto. f_equal. rewrite Z.ones_equiv. omega. } + { rewrite <- Z.land_ones by auto. f_equal. rewrite Z.ones_equiv. lia. } rewrite A. assert (B: 0 <= n mod 2^p < 2^p). - { apply Z_mod_lt. omega. } + { apply Z_mod_lt. lia. } set (m := n mod 2^p + (2^p-1)) in *. assert (C: m / 2^p = if zeq (n mod 2^p) 0 then 0 else 1). { unfold m. destruct (zeq (n mod 2^p) 0). - rewrite e. apply Z.div_small. omega. - eapply Coqlib.Zdiv_unique with (n mod 2^p - 1). ring. omega. } + rewrite e. apply Z.div_small. lia. + eapply Coqlib.Zdiv_unique with (n mod 2^p - 1). ring. lia. } assert (D: Z.testbit m p = if zeq (n mod 2^p) 0 then false else true). { destruct (zeq (n mod 2^p) 0). apply Z.testbit_false; auto. rewrite C; auto. apply Z.testbit_true; auto. rewrite C; auto. } assert (E: forall i, p < i -> Z.testbit m i = false). - { intros. apply Z.testbit_false. omega. + { intros. apply Z.testbit_false. lia. replace (m / 2^i) with 0. auto. symmetry. apply Z.div_small. - unfold m. split. omega. apply Z.lt_le_trans with (2 * 2^p). omega. - change 2 with (2^1) at 1. rewrite <- (Zpower_plus radix2) by omega. - apply Zpower_le. omega. } + unfold m. split. lia. apply Z.lt_le_trans with (2 * 2^p). lia. + change 2 with (2^1) at 1. rewrite <- (Zpower_plus radix2) by lia. + apply Zpower_le. lia. } assert (F: forall i, 0 <= i -> Z.testbit (-2^p) i = if zlt i p then false else true). { intros. rewrite Z.bits_opp by auto. rewrite <- Z.ones_equiv. destruct (zlt i p). - rewrite Z.ones_spec_low by omega. auto. - rewrite Z.ones_spec_high by omega. auto. } + rewrite Z.ones_spec_low by lia. auto. + rewrite Z.ones_spec_high by lia. auto. } apply int_round_odd_bits; auto. - - intros. rewrite Z.land_spec, F, zlt_true by omega. apply andb_false_r. - - rewrite Z.land_spec, Z.lor_spec, D, F, zlt_false, andb_true_r by omega. + - intros. rewrite Z.land_spec, F, zlt_true by lia. apply andb_false_r. + - rewrite Z.land_spec, Z.lor_spec, D, F, zlt_false, andb_true_r by lia. destruct (Z.eqb (n mod 2^p) 0) eqn:Z. rewrite Z.eqb_eq in Z. rewrite Z, zeq_true. apply orb_false_r. rewrite Z.eqb_neq in Z. rewrite zeq_false by auto. apply orb_true_r. - - intros. rewrite Z.land_spec, Z.lor_spec, E, F, zlt_false, andb_true_r by omega. + - intros. rewrite Z.land_spec, Z.lor_spec, E, F, zlt_false, andb_true_r by lia. apply orb_false_r. Qed. @@ -1319,22 +1321,22 @@ Lemma of_long_round_odd: 2^36 <= Z.abs n < 2^64 -> BofZ 24 128 __ __ n = Bconv _ _ 24 128 __ __ conv_nan mode_NE (BofZ 53 1024 __ __ (Z.land (Z.lor n ((Z.land n 2047) + 2047)) (-2048))). Proof. - intros. rewrite <- (int_round_odd_plus 11) by omega. + intros. rewrite <- (int_round_odd_plus 11) by lia. assert (-2^64 <= int_round_odd n 11). - { change (-2^64) with (int_round_odd (-2^64) 11). apply (int_round_odd_le 0 0); xomega. } + { change (-2^64) with (int_round_odd (-2^64) 11). apply int_round_odd_le; extlia. } assert (int_round_odd n 11 <= 2^64). - { change (2^64) with (int_round_odd (2^64) 11). apply (int_round_odd_le 0 0); xomega. } + { change (2^64) with (int_round_odd (2^64) 11). apply int_round_odd_le; extlia. } rewrite Bconv_BofZ. apply BofZ_round_odd with (p := 11). - omega. - apply Z.le_trans with (2^64). omega. compute; intuition congruence. - omega. + lia. + apply Z.le_trans with (2^64). lia. compute; intuition congruence. + lia. exact (proj1 H). - unfold int_round_odd. apply integer_representable_n2p_wide. auto. omega. + unfold int_round_odd. apply integer_representable_n2p_wide. auto. lia. unfold int_round_odd in H0, H1. split; (apply Zmult_le_reg_r with (2^11); [compute; auto | assumption]). - omega. - omega. + lia. + lia. Qed. Theorem of_longu_double_1: @@ -1343,7 +1345,7 @@ Theorem of_longu_double_1: of_longu n = of_double (Float.of_longu n). Proof. intros. symmetry; apply Bconv_BofZ. apply integer_representable_n; auto. - pose proof (Int64.unsigned_range n); omega. + pose proof (Int64.unsigned_range n); lia. Qed. Theorem of_longu_double_2: @@ -1361,14 +1363,14 @@ Proof. unfold of_double, Float.to_single. instantiate (1 := Float.to_single_nan). f_equal. unfold Float.of_longu. f_equal. set (n' := Z.land (Z.lor (Int64.unsigned n) (Z.land (Int64.unsigned n) 2047 + 2047)) (-2048)). - assert (int_round_odd (Int64.unsigned n) 11 = n') by (apply int_round_odd_plus; omega). + assert (int_round_odd (Int64.unsigned n) 11 = n') by (apply int_round_odd_plus; lia). assert (0 <= n'). - { rewrite <- H1. change 0 with (int_round_odd 0 11). apply (int_round_odd_le 0 0); omega. } + { rewrite <- H1. change 0 with (int_round_odd 0 11). apply int_round_odd_le; lia. } assert (n' < Int64.modulus). { apply Z.le_lt_trans with (int_round_odd (Int64.modulus - 1) 11). - rewrite <- H1. apply (int_round_odd_le 0 0); omega. + rewrite <- H1. apply int_round_odd_le; lia. compute; auto. } - rewrite <- (Int64.unsigned_repr n') by (unfold Int64.max_unsigned; omega). + rewrite <- (Int64.unsigned_repr n') by (unfold Int64.max_unsigned; lia). f_equal. Int64.bit_solve. rewrite Int64.testbit_repr by auto. unfold n'. rewrite Z.land_spec, Z.lor_spec. f_equal. f_equal. unfold Int64.testbit. rewrite Int64.add_unsigned. @@ -1377,11 +1379,11 @@ Proof. Int64.unsigned (Int64.repr 2047))) i). rewrite Int64.testbit_repr by auto. f_equal. f_equal. unfold Int64.and. symmetry. apply Int64.unsigned_repr. change 2047 with (Z.ones 11). - rewrite Z.land_ones by omega. + rewrite Z.land_ones by lia. exploit (Z_mod_lt (Int64.unsigned n) (2^11)). compute; auto. - assert (2^11 < Int64.max_unsigned) by (compute; auto). omega. + assert (2^11 < Int64.max_unsigned) by (compute; auto). lia. apply Int64.same_bits_eqm; auto. exists (-1); auto. - split. xomega. change (2^64) with Int64.modulus. xomega. + split. extlia. change (2^64) with Int64.modulus. extlia. Qed. Theorem of_long_double_1: @@ -1389,7 +1391,7 @@ Theorem of_long_double_1: Z.abs (Int64.signed n) <= 2^53 -> of_long n = of_double (Float.of_long n). Proof. - intros. symmetry; apply Bconv_BofZ. apply integer_representable_n; auto. xomega. + intros. symmetry; apply Bconv_BofZ. apply integer_representable_n; auto. extlia. Qed. Theorem of_long_double_2: @@ -1407,34 +1409,34 @@ Proof. unfold of_double, Float.to_single. instantiate (1 := Float.to_single_nan). f_equal. unfold Float.of_long. f_equal. set (n' := Z.land (Z.lor (Int64.signed n) (Z.land (Int64.signed n) 2047 + 2047)) (-2048)). - assert (int_round_odd (Int64.signed n) 11 = n') by (apply int_round_odd_plus; omega). + assert (int_round_odd (Int64.signed n) 11 = n') by (apply int_round_odd_plus; lia). assert (Int64.min_signed <= n'). - { rewrite <- H1. change Int64.min_signed with (int_round_odd Int64.min_signed 11). apply (int_round_odd_le 0 0); omega. } + { rewrite <- H1. change Int64.min_signed with (int_round_odd Int64.min_signed 11). apply int_round_odd_le; lia. } assert (n' <= Int64.max_signed). { apply Z.le_trans with (int_round_odd Int64.max_signed 11). - rewrite <- H1. apply (int_round_odd_le 0 0); omega. + rewrite <- H1. apply int_round_odd_le; lia. compute; intuition congruence. } - rewrite <- (Int64.signed_repr n') by omega. + rewrite <- (Int64.signed_repr n') by lia. f_equal. Int64.bit_solve. rewrite Int64.testbit_repr by auto. unfold n'. rewrite Z.land_spec, Z.lor_spec. f_equal. f_equal. - rewrite Int64.bits_signed by omega. rewrite zlt_true by omega. auto. + rewrite Int64.bits_signed by lia. rewrite zlt_true by lia. auto. unfold Int64.testbit. rewrite Int64.add_unsigned. fold (Int64.testbit (Int64.repr (Int64.unsigned (Int64.and n (Int64.repr 2047)) + Int64.unsigned (Int64.repr 2047))) i). rewrite Int64.testbit_repr by auto. f_equal. f_equal. unfold Int64.and. change (Int64.unsigned (Int64.repr 2047)) with 2047. - change 2047 with (Z.ones 11). rewrite ! Z.land_ones by omega. + change 2047 with (Z.ones 11). rewrite ! Z.land_ones by lia. rewrite Int64.unsigned_repr. apply eqmod_mod_eq. - apply Z.lt_gt. apply (Zpower_gt_0 radix2); omega. + apply Z.lt_gt. apply (Zpower_gt_0 radix2); lia. apply eqmod_divides with (2^64). apply Int64.eqm_signed_unsigned. exists (2^(64-11)); auto. exploit (Z_mod_lt (Int64.unsigned n) (2^11)). compute; auto. - assert (2^11 < Int64.max_unsigned) by (compute; auto). omega. + assert (2^11 < Int64.max_unsigned) by (compute; auto). lia. apply Int64.same_bits_eqm; auto. exists (-1); auto. split. auto. assert (-2^64 < Int64.min_signed) by (compute; auto). assert (Int64.max_signed < 2^64) by (compute; auto). - xomega. + extlia. Qed. End Float32. diff --git a/lib/Heaps.v b/lib/Heaps.v index 85343998..def9da97 100644 --- a/lib/Heaps.v +++ b/lib/Heaps.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/lib/IEEE754_extra.v b/lib/IEEE754_extra.v index 18313ec1..b0d1944e 100644 --- a/lib/IEEE754_extra.v +++ b/lib/IEEE754_extra.v @@ -7,10 +7,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -119,7 +120,7 @@ Definition integer_representable (n: Z): Prop := Let int_upper_bound_eq: 2^emax - 2^(emax - prec) = (2^prec - 1) * 2^(emax - prec). Proof. red in prec_gt_0_. - ring_simplify. rewrite <- (Zpower_plus radix2) by omega. f_equal. f_equal. omega. + ring_simplify. rewrite <- (Zpower_plus radix2) by lia. f_equal. f_equal. lia. Qed. Lemma integer_representable_n2p: @@ -130,14 +131,14 @@ Proof. intros; split. - red in prec_gt_0_. replace (Z.abs (n * 2^p)) with (Z.abs n * 2^p). rewrite int_upper_bound_eq. - apply Zmult_le_compat. zify; omega. apply (Zpower_le radix2); omega. - zify; omega. apply (Zpower_ge_0 radix2). + apply Zmult_le_compat. zify; lia. apply (Zpower_le radix2); lia. + zify; lia. apply (Zpower_ge_0 radix2). rewrite Z.abs_mul. f_equal. rewrite Z.abs_eq. auto. apply (Zpower_ge_0 radix2). - apply generic_format_FLT. exists (Float radix2 n p). unfold F2R; simpl. rewrite <- IZR_Zpower by auto. apply mult_IZR. - simpl; zify; omega. - unfold emin, Fexp; red in prec_gt_0_; omega. + simpl; zify; lia. + unfold emin, Fexp; red in prec_gt_0_; lia. Qed. Lemma integer_representable_2p: @@ -149,19 +150,19 @@ Proof. - red in prec_gt_0_. rewrite Z.abs_eq by (apply (Zpower_ge_0 radix2)). apply Z.le_trans with (2^(emax-1)). - apply (Zpower_le radix2); omega. + apply (Zpower_le radix2); lia. assert (2^emax = 2^(emax-1)*2). - { change 2 with (2^1) at 3. rewrite <- (Zpower_plus radix2) by omega. - f_equal. omega. } + { change 2 with (2^1) at 3. rewrite <- (Zpower_plus radix2) by lia. + f_equal. lia. } assert (2^(emax - prec) <= 2^(emax - 1)). - { apply (Zpower_le radix2). omega. } - omega. + { apply (Zpower_le radix2). lia. } + lia. - red in prec_gt_0_. apply generic_format_FLT. exists (Float radix2 1 p). unfold F2R; simpl. - rewrite Rmult_1_l. rewrite <- IZR_Zpower. auto. omega. - simpl Z.abs. change 1 with (2^0). apply (Zpower_lt radix2). omega. auto. - unfold emin, Fexp; omega. + rewrite Rmult_1_l. rewrite <- IZR_Zpower. auto. lia. + simpl Z.abs. change 1 with (2^0). apply (Zpower_lt radix2). lia. auto. + unfold emin, Fexp; lia. Qed. Lemma integer_representable_opp: @@ -178,12 +179,12 @@ Lemma integer_representable_n2p_wide: Proof. intros. red in prec_gt_0_. destruct (Z.eq_dec n (2^prec)); [idtac | destruct (Z.eq_dec n (-2^prec))]. -- rewrite e. rewrite <- (Zpower_plus radix2) by omega. - apply integer_representable_2p. omega. +- rewrite e. rewrite <- (Zpower_plus radix2) by lia. + apply integer_representable_2p. lia. - rewrite e. rewrite <- Zopp_mult_distr_l. apply integer_representable_opp. - rewrite <- (Zpower_plus radix2) by omega. - apply integer_representable_2p. omega. -- apply integer_representable_n2p; omega. + rewrite <- (Zpower_plus radix2) by lia. + apply integer_representable_2p. lia. +- apply integer_representable_n2p; lia. Qed. Lemma integer_representable_n: @@ -191,7 +192,7 @@ Lemma integer_representable_n: Proof. red in prec_gt_0_. intros. replace n with (n * 2^0) by (change (2^0) with 1; ring). - apply integer_representable_n2p_wide. auto. omega. omega. + apply integer_representable_n2p_wide. auto. lia. lia. Qed. Lemma round_int_no_overflow: @@ -205,14 +206,14 @@ Proof. apply round_le_generic. apply fexp_correct; auto. apply valid_rnd_N. apply generic_format_FLT. exists (Float radix2 (2^prec-1) (emax-prec)). rewrite int_upper_bound_eq. unfold F2R; simpl. - rewrite <- IZR_Zpower by omega. rewrite <- mult_IZR. auto. - assert (0 < 2^prec) by (apply (Zpower_gt_0 radix2); omega). - unfold Fnum; simpl; zify; omega. - unfold emin, Fexp; omega. + rewrite <- IZR_Zpower by lia. rewrite <- mult_IZR. auto. + assert (0 < 2^prec) by (apply (Zpower_gt_0 radix2); lia). + unfold Fnum; simpl; zify; lia. + unfold emin, Fexp; lia. rewrite <- abs_IZR. apply IZR_le. auto. - rewrite <- IZR_Zpower by omega. apply IZR_lt. simpl. - assert (0 < 2^(emax-prec)) by (apply (Zpower_gt_0 radix2); omega). - omega. + rewrite <- IZR_Zpower by lia. apply IZR_lt. simpl. + assert (0 < 2^(emax-prec)) by (apply (Zpower_gt_0 radix2); lia). + lia. apply fexp_correct. auto. Qed. @@ -299,8 +300,8 @@ Proof. { apply round_le_generic. apply fexp_correct. auto. apply valid_rnd_N. apply (integer_representable_opp 1). apply (integer_representable_2p 0). - red in prec_gt_0_; omega. - apply IZR_le; omega. + red in prec_gt_0_; lia. + apply IZR_le; lia. } lra. Qed. @@ -335,7 +336,7 @@ Proof. rewrite R, W, C, F. rewrite Rcompare_IZR. unfold Z.ltb at 3. generalize (Zcompare_spec (p + q) 0); intros SPEC; inversion SPEC; auto. - assert (EITHER: 0 <= p \/ 0 <= q) by omega. + assert (EITHER: 0 <= p \/ 0 <= q) by lia. destruct EITHER; [apply andb_false_intro1 | apply andb_false_intro2]; apply Zlt_bool_false; auto. - intros P (U & V). @@ -343,8 +344,8 @@ Proof. rewrite P, U, C. f_equal. rewrite C, F in V. generalize (Zlt_bool_spec p 0) (Zlt_bool_spec q 0). rewrite <- V. intros SPEC1 SPEC2; inversion SPEC1; inversion SPEC2; try congruence; symmetry. - apply Zlt_bool_true; omega. - apply Zlt_bool_false; omega. + apply Zlt_bool_true; lia. + apply Zlt_bool_false; lia. Qed. Theorem BofZ_minus: @@ -365,7 +366,7 @@ Proof. rewrite R, W, C, F. rewrite Rcompare_IZR. unfold Z.ltb at 3. generalize (Zcompare_spec (p - q) 0); intros SPEC; inversion SPEC; auto. - assert (EITHER: 0 <= p \/ q < 0) by omega. + assert (EITHER: 0 <= p \/ q < 0) by lia. destruct EITHER; [apply andb_false_intro1 | apply andb_false_intro2]. rewrite Zlt_bool_false; auto. rewrite Zlt_bool_true; auto. @@ -375,8 +376,8 @@ Proof. generalize (Zlt_bool_spec p 0) (Zlt_bool_spec q 0). rewrite V. intros SPEC1 SPEC2; inversion SPEC1; inversion SPEC2; symmetry. rewrite <- H3 in H1; discriminate. - apply Zlt_bool_true; omega. - apply Zlt_bool_false; omega. + apply Zlt_bool_true; lia. + apply Zlt_bool_false; lia. rewrite <- H3 in H1; discriminate. Qed. @@ -389,10 +390,10 @@ Proof. intros. assert (SIGN: xorb (p <? 0) (q <? 0) = (p * q <? 0)). { - rewrite (Zlt_bool_false q) by omega. + rewrite (Zlt_bool_false q) by lia. generalize (Zlt_bool_spec p 0); intros SPEC; inversion SPEC; simpl; symmetry. - apply Zlt_bool_true. rewrite Z.mul_comm. apply Z.mul_pos_neg; omega. - apply Zlt_bool_false. apply Zsame_sign_imp; omega. + apply Zlt_bool_true. rewrite Z.mul_comm. apply Z.mul_pos_neg; lia. + apply Zlt_bool_false. apply Zsame_sign_imp; lia. } destruct (BofZ_representable p) as (A & B & C); auto. destruct (BofZ_representable q) as (D & E & F); auto. @@ -420,10 +421,10 @@ Proof. destruct (Z.eq_dec x 0). - subst x. apply BofZ_mult. apply integer_representable_n. - generalize (Zpower_ge_0 radix2 prec). simpl; omega. + generalize (Zpower_ge_0 radix2 prec). simpl; lia. apply integer_representable_2p. auto. apply (Zpower_gt_0 radix2). - omega. + lia. - assert (IZR x <> 0%R) by (apply (IZR_neq _ _ n)). destruct (BofZ_finite x H) as (A & B & C). destruct (BofZ_representable (2^p)) as (D & E & F). @@ -432,16 +433,16 @@ Proof. cexp radix2 fexp (IZR x) + p). { unfold cexp, fexp. rewrite mult_IZR. - change (2^p) with (radix2^p). rewrite IZR_Zpower by omega. + change (2^p) with (radix2^p). rewrite IZR_Zpower by lia. rewrite mag_mult_bpow by auto. assert (prec + 1 <= mag radix2 (IZR x)). { rewrite <- (mag_abs radix2 (IZR x)). rewrite <- (mag_bpow radix2 prec). apply mag_le. - apply bpow_gt_0. rewrite <- IZR_Zpower by (red in prec_gt_0_;omega). + apply bpow_gt_0. rewrite <- IZR_Zpower by (red in prec_gt_0_;lia). rewrite <- abs_IZR. apply IZR_le; auto. } unfold FLT_exp. - unfold emin; red in prec_gt_0_; zify; omega. + unfold emin; red in prec_gt_0_; zify; lia. } assert (forall m, round radix2 fexp m (IZR x) * IZR (2^p) = round radix2 fexp m (IZR (x * 2^p)))%R. @@ -451,11 +452,11 @@ Proof. set (a := IZR x); set (b := bpow radix2 (- cexp radix2 fexp a)). replace (a * IZR (2^p) * (b * bpow radix2 (-p)))%R with (a * b)%R. unfold F2R; simpl. rewrite Rmult_assoc. f_equal. - rewrite bpow_plus. f_equal. apply (IZR_Zpower radix2). omega. + rewrite bpow_plus. f_equal. apply (IZR_Zpower radix2). lia. transitivity ((a * b) * (IZR (2^p) * bpow radix2 (-p)))%R. rewrite (IZR_Zpower radix2). rewrite <- bpow_plus. - replace (p + -p) with 0 by omega. change (bpow radix2 0) with 1%R. ring. - omega. + replace (p + -p) with 0 by lia. change (bpow radix2 0) with 1%R. ring. + lia. ring. } assert (forall m x, @@ -468,11 +469,11 @@ Proof. } assert (xorb (x <? 0) (2^p <? 0) = (x * 2^p <? 0)). { - assert (0 < 2^p) by (apply (Zpower_gt_0 radix2); omega). - rewrite (Zlt_bool_false (2^p)) by omega. rewrite xorb_false_r. + assert (0 < 2^p) by (apply (Zpower_gt_0 radix2); lia). + rewrite (Zlt_bool_false (2^p)) by lia. rewrite xorb_false_r. symmetry. generalize (Zlt_bool_spec x 0); intros SPEC; inversion SPEC. apply Zlt_bool_true. apply Z.mul_neg_pos; auto. - apply Zlt_bool_false. apply Z.mul_nonneg_nonneg; omega. + apply Zlt_bool_false. apply Z.mul_nonneg_nonneg; lia. } generalize (Bmult_correct _ _ _ Hmax nan mode_NE (BofZ x) (BofZ (2^p))) (BofZ_correct (x * 2^p)). @@ -496,10 +497,10 @@ Lemma round_odd_flt: round radix2 fexp (Znearest choice) x. Proof. intros. apply round_N_odd. auto. apply fexp_correct; auto. - apply exists_NE_FLT. right; omega. - apply FLT_exp_valid. red; omega. - apply exists_NE_FLT. right; omega. - unfold fexp, FLT_exp; intros. zify; omega. + apply exists_NE_FLT. right; lia. + apply FLT_exp_valid. red; lia. + apply exists_NE_FLT. right; lia. + unfold fexp, FLT_exp; intros. zify; lia. Qed. Corollary round_odd_fix: @@ -522,8 +523,8 @@ Proof. cexp radix2 (FIX_exp p) x). { unfold cexp, FLT_exp, FIX_exp. - replace (mag radix2 x - prec') with p by (unfold prec'; omega). - apply Z.max_l. unfold emin', emin. red in prec_gt_0_; omega. + replace (mag radix2 x - prec') with p by (unfold prec'; lia). + apply Z.max_l. unfold emin', emin. red in prec_gt_0_; lia. } assert (RND: round radix2 (FIX_exp p) Zrnd_odd x = round radix2 (FLT_exp emin' prec') Zrnd_odd x). @@ -532,9 +533,9 @@ Proof. } rewrite RND. apply round_odd_flt. auto. - unfold prec'. red in prec_gt_0_; omega. - unfold prec'. omega. - unfold emin'. omega. + unfold prec'. red in prec_gt_0_; lia. + unfold prec'. lia. + unfold emin'. lia. Qed. Definition int_round_odd (x: Z) (p: Z) := @@ -545,23 +546,23 @@ Lemma Zrnd_odd_int: Zrnd_odd (IZR n * bpow radix2 (-p)) * 2^p = int_round_odd n p. Proof. - intros. - assert (0 < 2^p) by (apply (Zpower_gt_0 radix2); omega). - assert (n = (n / 2^p) * 2^p + n mod 2^p) by (rewrite Z.mul_comm; apply Z.div_mod; omega). - assert (0 <= n mod 2^p < 2^p) by (apply Z_mod_lt; omega). + clear. intros. + assert (0 < 2^p) by (apply (Zpower_gt_0 radix2); lia). + assert (n = (n / 2^p) * 2^p + n mod 2^p) by (rewrite Z.mul_comm; apply Z.div_mod; lia). + assert (0 <= n mod 2^p < 2^p) by (apply Z_mod_lt; lia). unfold int_round_odd. set (q := n / 2^p) in *; set (r := n mod 2^p) in *. f_equal. pose proof (bpow_gt_0 radix2 (-p)). assert (bpow radix2 p * bpow radix2 (-p) = 1)%R. - { rewrite <- bpow_plus. replace (p + -p) with 0 by omega. auto. } + { rewrite <- bpow_plus. replace (p + -p) with 0 by lia. auto. } assert (IZR n * bpow radix2 (-p) = IZR q + IZR r * bpow radix2 (-p))%R. { rewrite H1. rewrite plus_IZR, mult_IZR. change (IZR (2^p)) with (IZR (radix2^p)). - rewrite IZR_Zpower by omega. ring_simplify. + rewrite IZR_Zpower by lia. ring_simplify. rewrite Rmult_assoc. rewrite H4. ring. } assert (0 <= IZR r < bpow radix2 p)%R. - { split. apply IZR_le; omega. - rewrite <- IZR_Zpower by omega. apply IZR_lt; tauto. } + { split. apply IZR_le; lia. + rewrite <- IZR_Zpower by lia. apply IZR_lt; tauto. } assert (0 <= IZR r * bpow radix2 (-p) < 1)%R. { generalize (bpow_gt_0 radix2 (-p)). intros. split. apply Rmult_le_pos; lra. @@ -586,7 +587,7 @@ Lemma int_round_odd_le: forall p x y, 0 <= p -> x <= y -> int_round_odd x p <= int_round_odd y p. Proof. - intros. + clear. intros. assert (Zrnd_odd (IZR x * bpow radix2 (-p)) <= Zrnd_odd (IZR y * bpow radix2 (-p))). { apply Zrnd_le. apply valid_rnd_odd. apply Rmult_le_compat_r. apply bpow_ge_0. apply IZR_le; auto. } @@ -598,7 +599,7 @@ Lemma int_round_odd_exact: forall p x, 0 <= p -> (2^p | x) -> int_round_odd x p = x. Proof. - intros. unfold int_round_odd. apply Znumtheory.Zdivide_mod in H0. + clear. intros. unfold int_round_odd. apply Znumtheory.Zdivide_mod in H0. rewrite H0. simpl. rewrite Z.mul_comm. symmetry. apply Z_div_exact_2. apply Z.lt_gt. apply (Zpower_gt_0 radix2). auto. auto. Qed. @@ -615,15 +616,15 @@ Proof. assert (DIV: (2^p | 2^emax - 2^(emax - prec))). { rewrite int_upper_bound_eq. apply Z.divide_mul_r. exists (2^(emax - prec - p)). red in prec_gt_0_. - rewrite <- (Zpower_plus radix2) by omega. f_equal; omega. } + rewrite <- (Zpower_plus radix2) by lia. f_equal; lia. } assert (YRANGE: Z.abs (int_round_odd x p) <= 2^emax - 2^(emax-prec)). { apply Z.abs_le. split. replace (-(2^emax - 2^(emax-prec))) with (int_round_odd (-(2^emax - 2^(emax-prec))) p). - apply int_round_odd_le; zify; omega. - apply int_round_odd_exact. omega. apply Z.divide_opp_r. auto. + apply int_round_odd_le; zify; lia. + apply int_round_odd_exact. lia. apply Z.divide_opp_r. auto. replace (2^emax - 2^(emax-prec)) with (int_round_odd (2^emax - 2^(emax-prec)) p). - apply int_round_odd_le; zify; omega. - apply int_round_odd_exact. omega. auto. } + apply int_round_odd_le; zify; lia. + apply int_round_odd_exact. lia. auto. } destruct (BofZ_finite x XRANGE) as (X1 & X2 & X3). destruct (BofZ_finite (int_round_odd x p) YRANGE) as (Y1 & Y2 & Y3). apply BofZ_finite_equal; auto. @@ -631,12 +632,12 @@ Proof. assert (IZR (int_round_odd x p) = round radix2 (FIX_exp p) Zrnd_odd (IZR x)). { unfold round, scaled_mantissa, cexp, FIX_exp. - rewrite <- Zrnd_odd_int by omega. - unfold F2R; simpl. rewrite mult_IZR. f_equal. apply (IZR_Zpower radix2). omega. + rewrite <- Zrnd_odd_int by lia. + unfold F2R; simpl. rewrite mult_IZR. f_equal. apply (IZR_Zpower radix2). lia. } - rewrite H. symmetry. apply round_odd_fix. auto. omega. + rewrite H. symmetry. apply round_odd_fix. auto. lia. rewrite <- IZR_Zpower. rewrite <- abs_IZR. apply IZR_le; auto. - red in prec_gt_0_; omega. + red in prec_gt_0_; lia. Qed. Lemma int_round_odd_shifts: @@ -644,7 +645,7 @@ Lemma int_round_odd_shifts: int_round_odd x p = Z.shiftl (if Z.eqb (x mod 2^p) 0 then Z.shiftr x p else Z.lor (Z.shiftr x p) 1) p. Proof. - intros. + clear. intros. unfold int_round_odd. rewrite Z.shiftl_mul_pow2 by auto. f_equal. rewrite Z.shiftr_div_pow2 by auto. destruct (x mod 2^p =? 0) eqn:E. auto. @@ -662,22 +663,22 @@ Lemma int_round_odd_bits: (forall i, p < i -> Z.testbit y i = Z.testbit x i) -> int_round_odd x p = y. Proof. - intros until p; intros PPOS BELOW AT ABOVE. + clear. intros until p; intros PPOS BELOW AT ABOVE. rewrite int_round_odd_shifts by auto. apply Z.bits_inj'. intros. generalize (Zcompare_spec n p); intros SPEC; inversion SPEC. - rewrite BELOW by auto. apply Z.shiftl_spec_low; auto. -- subst n. rewrite AT. rewrite Z.shiftl_spec_high by omega. - replace (p - p) with 0 by omega. +- subst n. rewrite AT. rewrite Z.shiftl_spec_high by lia. + replace (p - p) with 0 by lia. destruct (x mod 2^p =? 0). - + rewrite Z.shiftr_spec by omega. f_equal; omega. + + rewrite Z.shiftr_spec by lia. f_equal; lia. + rewrite Z.lor_spec. apply orb_true_r. -- rewrite ABOVE by auto. rewrite Z.shiftl_spec_high by omega. +- rewrite ABOVE by auto. rewrite Z.shiftl_spec_high by lia. destruct (x mod 2^p =? 0). - rewrite Z.shiftr_spec by omega. f_equal; omega. - rewrite Z.lor_spec, Z.shiftr_spec by omega. - change 1 with (Z.ones 1). rewrite Z.ones_spec_high by omega. rewrite orb_false_r. - f_equal; omega. + rewrite Z.shiftr_spec by lia. f_equal; lia. + rewrite Z.lor_spec, Z.shiftr_spec by lia. + change 1 with (Z.ones 1). rewrite Z.ones_spec_high by lia. rewrite orb_false_r. + f_equal; lia. Qed. (** ** Conversion from a FP number to an integer *) @@ -709,7 +710,7 @@ Proof. } rewrite EQ. f_equal. generalize (Zpower_pos_gt_0 2 p (eq_refl _)); intros. - rewrite Ztrunc_floor. symmetry. apply Zfloor_div. omega. + rewrite Ztrunc_floor. symmetry. apply Zfloor_div. lia. apply Rmult_le_pos. apply IZR_le. compute; congruence. apply Rlt_le. apply Rinv_0_lt_compat. apply IZR_lt. auto. Qed. @@ -727,7 +728,7 @@ Proof. assert (-x < 0)%R. { apply Rlt_le_trans with (IZR (Zfloor (-x)) + 1)%R. apply Zfloor_ub. rewrite <- plus_IZR. - apply IZR_le. omega. } + apply IZR_le. lia. } lra. Qed. @@ -741,7 +742,7 @@ Proof. - rewrite Ztrunc_ceil in H by (apply Rlt_le; auto). split. + apply (Ropp_lt_cancel (-(1))). rewrite Ropp_involutive. replace 1%R with (IZR (Zfloor (-x)) + 1)%R. apply Zfloor_ub. - unfold Zceil in H. replace (Zfloor (-x)) with 0 by omega. simpl. apply Rplus_0_l. + unfold Zceil in H. replace (Zfloor (-x)) with 0 by lia. simpl. apply Rplus_0_l. + apply Rlt_le_trans with 0%R; auto. apply Rle_0_1. Qed. @@ -758,10 +759,10 @@ Proof. intros. rewrite ZofB_correct in H. destruct (is_finite prec emax f) eqn:FIN; inversion H. set (x := B2R prec emax f) in *. set (y := (-x)%R). assert (A: (IZR (Ztrunc y) <= y < IZR (Ztrunc y + 1)%Z)%R). - { apply Ztrunc_range_pos. unfold y. rewrite Ztrunc_opp. omega. } + { apply Ztrunc_range_pos. unfold y. rewrite Ztrunc_opp. lia. } destruct A as [B C]. unfold y in B, C. rewrite Ztrunc_opp in B, C. - replace (- Ztrunc x + 1) with (- (Ztrunc x - 1)) in C by omega. + replace (- Ztrunc x + 1) with (- (Ztrunc x - 1)) in C by lia. rewrite opp_IZR in B, C. lra. Qed. @@ -777,7 +778,7 @@ Theorem ZofB_range_nonneg: Proof. intros. destruct (Z.eq_dec n 0). - subst n. apply ZofB_range_zero. auto. -- destruct (ZofB_range_pos f n) as (A & B). auto. omega. +- destruct (ZofB_range_pos f n) as (A & B). auto. lia. split; auto. apply Rlt_le_trans with 0%R. simpl; lra. apply Rle_trans with (IZR n); auto. apply IZR_le; auto. Qed. @@ -796,7 +797,7 @@ Qed. Remark Zfloor_minus: forall x n, Zfloor (x - IZR n) = Zfloor x - n. Proof. - intros. apply Zfloor_imp. replace (Zfloor x - n + 1) with ((Zfloor x + 1) - n) by omega. + intros. apply Zfloor_imp. replace (Zfloor x - n + 1) with ((Zfloor x + 1) - n) by lia. rewrite ! minus_IZR. unfold Rminus. split. apply Rplus_le_compat_r. apply Zfloor_lb. apply Rplus_lt_compat_r. rewrite plus_IZR. apply Zfloor_ub. @@ -809,11 +810,11 @@ Theorem ZofB_minus: Proof. intros. assert (Q: -2^prec <= q <= 2^prec). - { split; auto. generalize (Zpower_ge_0 radix2 prec); simpl; omega. } - assert (RANGE: (-1 < B2R _ _ f < IZR (p + 1)%Z)%R) by (apply ZofB_range_nonneg; auto; omega). + { split; auto. generalize (Zpower_ge_0 radix2 prec); simpl; lia. } + assert (RANGE: (-1 < B2R _ _ f < IZR (p + 1)%Z)%R) by (apply ZofB_range_nonneg; auto; lia). rewrite ZofB_correct in H. destruct (is_finite prec emax f) eqn:FIN; try discriminate. assert (PQ2: (IZR (p + 1) <= IZR q * 2)%R). - { rewrite <- mult_IZR. apply IZR_le. omega. } + { rewrite <- mult_IZR. apply IZR_le. lia. } assert (EXACT: round radix2 fexp (round_mode m) (B2R _ _ f - IZR q)%R = (B2R _ _ f - IZR q)%R). { apply round_generic. apply valid_rnd_round_mode. apply sterbenz_aux. now apply FLT_exp_valid. apply FLT_exp_monotone. apply generic_format_B2R. @@ -828,7 +829,7 @@ Proof. - rewrite A. fold emin; fold fexp. rewrite EXACT. apply Rle_lt_trans with (bpow radix2 prec). apply Rle_trans with (IZR q). apply Rabs_le. lra. - rewrite <- IZR_Zpower. apply IZR_le; auto. red in prec_gt_0_; omega. + rewrite <- IZR_Zpower. apply IZR_le; auto. red in prec_gt_0_; lia. apply bpow_lt. auto. Qed. @@ -874,8 +875,8 @@ Proof. intros. destruct (ZofB_range_inversion _ _ _ _ H) as (A & B & C). set (f' := Bminus prec emax prec_gt_0_ Hmax minus_nan m f (BofZ q)). assert (D: ZofB f' = Some (p - q)). - { apply ZofB_minus. auto. omega. auto. auto. } - unfold ZofB_range. rewrite D. rewrite Zle_bool_true by omega. rewrite Zle_bool_true by omega. auto. + { apply ZofB_minus. auto. lia. auto. auto. } + unfold ZofB_range. rewrite D. rewrite Zle_bool_true by lia. rewrite Zle_bool_true by lia. auto. Qed. (** ** Algebraic identities *) @@ -961,7 +962,7 @@ Theorem Bmult2_Bplus: Proof. intros until f; intros NAN. destruct (BofZ_representable 2) as (A & B & C). - apply (integer_representable_2p 1). red in prec_gt_0_; omega. + apply (integer_representable_2p 1). red in prec_gt_0_; lia. pose proof (Bmult_correct _ _ _ Hmax mult_nan mode f (BofZ 2%Z)). fold emin in H. rewrite A, B, C in H. rewrite xorb_false_r in H. destruct (is_finite _ _ f) eqn:FIN. @@ -979,7 +980,7 @@ Proof. replace 0%R with (@F2R radix2 {| Fnum := 0%Z; Fexp := e |}). rewrite Rcompare_F2R. destruct s; auto. unfold F2R. simpl. ring. - apply IZR_lt. omega. + apply IZR_lt. lia. destruct (Bmult prec emax prec_gt_0_ Hmax mult_nan mode f (BofZ 2)); reflexivity || discriminate. + destruct H0 as (P & Q). apply B2FF_inj. rewrite P, H. auto. - destruct f as [sf|sf|sf pf Hf|sf mf ef Hf]; try discriminate. @@ -1000,11 +1001,11 @@ Proof. assert (REC: forall n, Z.pos (nat_rect _ xH (fun _ => xO) n) = 2 ^ (Z.of_nat n)). { induction n. reflexivity. simpl nat_rect. transitivity (2 * Z.pos (nat_rect _ xH (fun _ => xO) n)). reflexivity. - rewrite Nat2Z.inj_succ. rewrite IHn. unfold Z.succ. rewrite Zpower_plus by omega. + rewrite Nat2Z.inj_succ. rewrite IHn. unfold Z.succ. rewrite Zpower_plus by lia. change (2 ^ 1) with 2. ring. } red in prec_gt_0_. - unfold Bexact_inverse_mantissa. rewrite iter_nat_of_Z by omega. rewrite REC. - rewrite Zabs2Nat.id_abs. rewrite Z.abs_eq by omega. auto. + unfold Bexact_inverse_mantissa. rewrite iter_nat_of_Z by lia. rewrite REC. + rewrite Zabs2Nat.id_abs. rewrite Z.abs_eq by lia. auto. Qed. Remark Bexact_inverse_mantissa_digits2_pos: @@ -1013,11 +1014,11 @@ Proof. assert (DIGITS: forall n, digits2_pos (nat_rect _ xH (fun _ => xO) n) = Pos.of_nat (n+1)). { induction n; simpl. auto. rewrite IHn. destruct n; auto. } red in prec_gt_0_. - unfold Bexact_inverse_mantissa. rewrite iter_nat_of_Z by omega. rewrite DIGITS. - rewrite Zabs2Nat.abs_nat_nonneg, Z2Nat.inj_sub by omega. + unfold Bexact_inverse_mantissa. rewrite iter_nat_of_Z by lia. rewrite DIGITS. + rewrite Zabs2Nat.abs_nat_nonneg, Z2Nat.inj_sub by lia. destruct prec; try discriminate. rewrite Nat.sub_add. simpl. rewrite Pos2Nat.id. auto. - simpl. zify; omega. + simpl. zify; lia. Qed. Remark bounded_Bexact_inverse: @@ -1028,8 +1029,8 @@ Proof. rewrite <- Zeq_is_eq_bool. rewrite <- Zle_is_le_bool. rewrite Bexact_inverse_mantissa_digits2_pos. split. -- intros; split. unfold FLT_exp. unfold emin in H. zify; omega. omega. -- intros [A B]. unfold FLT_exp in A. unfold emin. zify; omega. +- intros; split. unfold FLT_exp. unfold emin in H. zify; lia. lia. +- intros [A B]. unfold FLT_exp in A. unfold emin. zify; lia. Qed. Program Definition Bexact_inverse (f: binary_float) : option binary_float := @@ -1045,7 +1046,7 @@ Program Definition Bexact_inverse (f: binary_float) : option binary_float := end. Next Obligation. rewrite <- bounded_Bexact_inverse in B. rewrite <- bounded_Bexact_inverse. - unfold emin in *. omega. + unfold emin in *. lia. Qed. Lemma Bexact_inverse_correct: @@ -1067,9 +1068,9 @@ Proof with (try discriminate). rewrite <- ! cond_Ropp_mult_l. red in prec_gt_0_. replace (IZR (2 ^ (prec - 1))) with (bpow radix2 (prec - 1)) - by (symmetry; apply (IZR_Zpower radix2); omega). + by (symmetry; apply (IZR_Zpower radix2); lia). rewrite <- ! bpow_plus. - replace (prec - 1 + e') with (- (prec - 1 + e)) by (unfold e'; omega). + replace (prec - 1 + e') with (- (prec - 1 + e)) by (unfold e'; lia). rewrite bpow_opp. unfold cond_Ropp; destruct s; auto. rewrite Ropp_inv_permute. auto. apply Rgt_not_eq. apply bpow_gt_0. split. simpl. apply F2R_neq_0. destruct s; simpl in H; discriminate. @@ -1163,9 +1164,9 @@ Proof. assert (C: 0 <= Z.log2_up base) by apply Z.log2_up_nonneg. destruct (Z.log2_spec base) as [D E]; auto. destruct (Z.log2_up_spec base) as [F G]. apply radix_gt_1. - assert (K: 0 <= 2 ^ Z.log2 base) by (apply Z.pow_nonneg; omega). - rewrite ! (Z.mul_comm n). rewrite ! Z.pow_mul_r by omega. - split; apply Z.pow_le_mono_l; omega. + assert (K: 0 <= 2 ^ Z.log2 base) by (apply Z.pow_nonneg; lia). + rewrite ! (Z.mul_comm n). rewrite ! Z.pow_mul_r by lia. + split; apply Z.pow_le_mono_l; lia. Qed. Lemma bpow_log_pos: @@ -1174,8 +1175,8 @@ Lemma bpow_log_pos: (bpow radix2 (n * Z.log2 base)%Z <= bpow base n)%R. Proof. intros. rewrite <- ! IZR_Zpower. apply IZR_le; apply Zpower_log; auto. - omega. - rewrite Z.mul_comm; apply Zmult_gt_0_le_0_compat. omega. apply Z.log2_nonneg. + lia. + rewrite Z.mul_comm; apply Zmult_gt_0_le_0_compat. lia. apply Z.log2_nonneg. Qed. Lemma bpow_log_neg: @@ -1183,10 +1184,10 @@ Lemma bpow_log_neg: n < 0 -> (bpow base n <= bpow radix2 (n * Z.log2 base)%Z)%R. Proof. - intros. set (m := -n). replace n with (-m) by (unfold m; omega). + intros. set (m := -n). replace n with (-m) by (unfold m; lia). rewrite ! Z.mul_opp_l, ! bpow_opp. apply Rinv_le. apply bpow_gt_0. - apply bpow_log_pos. unfold m; omega. + apply bpow_log_pos. unfold m; lia. Qed. (** Overflow and underflow conditions. *) @@ -1203,12 +1204,12 @@ Proof. rewrite <- (Rmult_1_l (bpow radix2 emax)). apply Rmult_le_compat. apply Rle_0_1. apply bpow_ge_0. - apply IZR_le. zify; omega. + apply IZR_le. zify; lia. eapply Rle_trans. eapply bpow_le. eassumption. apply bpow_log_pos; auto. apply generic_format_FLT. exists (Float radix2 1 emax). unfold F2R; simpl. ring. simpl. apply (Zpower_gt_1 radix2); auto. - simpl. unfold emin; red in prec_gt_0_; omega. + simpl. unfold emin; red in prec_gt_0_; lia. Qed. Lemma round_NE_underflows: @@ -1221,10 +1222,10 @@ Proof. assert (A: round radix2 fexp (round_mode mode_NE) eps = 0%R). { unfold round. simpl. assert (E: cexp radix2 fexp eps = emin). - { unfold cexp, eps. rewrite mag_bpow. unfold fexp, FLT_exp. zify; red in prec_gt_0_; omega. } + { unfold cexp, eps. rewrite mag_bpow. unfold fexp, FLT_exp. zify; red in prec_gt_0_; lia. } unfold scaled_mantissa; rewrite E. assert (P: (eps * bpow radix2 (-emin) = / 2)%R). - { unfold eps. rewrite <- bpow_plus. replace (emin - 1 + -emin) with (-1) by omega. auto. } + { unfold eps. rewrite <- bpow_plus. replace (emin - 1 + -emin) with (-1) by lia. auto. } rewrite P. unfold Znearest. assert (F: Zfloor (/ 2)%R = 0). { apply Zfloor_imp. simpl. lra. } @@ -1244,18 +1245,18 @@ Lemma round_integer_underflow: round radix2 fexp (round_mode mode_NE) (IZR (Zpos m) * bpow base e) = 0%R. Proof. intros. apply round_NE_underflows. split. -- apply Rmult_le_pos. apply IZR_le. zify; omega. apply bpow_ge_0. +- apply Rmult_le_pos. apply IZR_le. zify; lia. apply bpow_ge_0. - apply Rle_trans with (bpow radix2 (Z.log2_up (Z.pos m) + e * Z.log2 base)). + rewrite bpow_plus. apply Rmult_le_compat. - apply IZR_le; zify; omega. + apply IZR_le; zify; lia. apply bpow_ge_0. rewrite <- IZR_Zpower. apply IZR_le. destruct (Z.eq_dec (Z.pos m) 1). - rewrite e0. simpl. omega. - apply Z.log2_up_spec. zify; omega. + rewrite e0. simpl. lia. + apply Z.log2_up_spec. zify; lia. apply Z.log2_up_nonneg. apply bpow_log_neg. auto. -+ apply bpow_le. omega. ++ apply bpow_le. lia. Qed. (** Correctness of Bparse *) @@ -1281,20 +1282,20 @@ Proof. - (* e = Zpos e *) destruct (Z.ltb_spec (Z.pos e * Z.log2 (Z.pos b)) emax). + (* no overflow *) - rewrite pos_pow_spec. rewrite <- IZR_Zpower by (zify; omega). rewrite <- mult_IZR. + rewrite pos_pow_spec. rewrite <- IZR_Zpower by (zify; lia). rewrite <- mult_IZR. replace false with (Z.pos m * Z.pos b ^ Z.pos e <? 0). exact (BofZ_correct (Z.pos m * Z.pos b ^ Z.pos e)). - rewrite Z.ltb_ge. rewrite Z.mul_comm. apply Zmult_gt_0_le_0_compat. zify; omega. apply (Zpower_ge_0 base). + rewrite Z.ltb_ge. rewrite Z.mul_comm. apply Zmult_gt_0_le_0_compat. zify; lia. apply (Zpower_ge_0 base). + (* overflow *) rewrite Rlt_bool_false. auto. eapply Rle_trans; [idtac|apply Rle_abs]. - apply (round_integer_overflow base). zify; omega. auto. + apply (round_integer_overflow base). zify; lia. auto. - (* e = Zneg e *) destruct (Z.ltb_spec (Z.neg e * Z.log2 (Z.pos b) + Z.log2_up (Z.pos m)) emin). + (* undeflow *) rewrite round_integer_underflow; auto. rewrite Rlt_bool_true. auto. replace (Rabs 0)%R with 0%R. apply bpow_gt_0. apply (abs_IZR 0). - zify; omega. + zify; lia. + (* no underflow *) generalize (Bdiv_correct_aux prec emax prec_gt_0_ Hmax mode_NE false m 0 false (pos_pow b e) 0). set (f := let '(mz, ez, lz) := Fdiv_core_binary prec emax (Z.pos m) 0 (Z.pos (pos_pow b e)) 0 @@ -1384,13 +1385,13 @@ Proof. apply Rlt_le_trans with (bpow radix2 emax1). rewrite F2R_cond_Zopp. rewrite abs_cond_Ropp. rewrite <- F2R_Zabs. simpl Z.abs. eapply bounded_lt_emax; eauto. - apply bpow_le. omega. + apply bpow_le. lia. } assert (EQ: round radix2 fexp2 (round_mode m) (B2R prec1 emax1 f) = B2R prec1 emax1 f). { apply round_generic. apply valid_rnd_round_mode. eapply generic_inclusion_le. 5: apply generic_format_B2R. apply fexp_correct; auto. apply fexp_correct; auto. - instantiate (1 := emax2). intros. unfold fexp2, FLT_exp. unfold emin2. zify; omega. + instantiate (1 := emax2). intros. unfold fexp2, FLT_exp. unfold emin2. zify; lia. apply Rlt_le; auto. } rewrite EQ. rewrite Rlt_bool_true by auto. auto. @@ -1444,7 +1445,7 @@ Proof. intros. destruct (ZofB_range_inversion _ _ _ _ _ _ H3) as (A & B & C). unfold ZofB_range. erewrite ZofB_Bconv by eauto. - rewrite ! Zle_bool_true by omega. auto. + rewrite ! Zle_bool_true by lia. auto. Qed. (** Change of format (to higher precision) and comparison. *) diff --git a/lib/Integers.v b/lib/Integers.v index 8990c78d..68bff3a0 100644 --- a/lib/Integers.v +++ b/lib/Integers.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -72,7 +73,7 @@ Definition min_signed : Z := - half_modulus. Remark wordsize_pos: zwordsize > 0. Proof. - unfold zwordsize, wordsize. generalize WS.wordsize_not_zero. omega. + unfold zwordsize, wordsize. generalize WS.wordsize_not_zero. lia. Qed. Remark modulus_power: modulus = two_p zwordsize. @@ -83,15 +84,15 @@ Qed. Remark modulus_gt_one: modulus > 1. Proof. rewrite modulus_power. apply Z.lt_gt. apply (two_p_monotone_strict 0). - generalize wordsize_pos; omega. + generalize wordsize_pos; lia. Qed. Remark modulus_pos: modulus > 0. Proof. - generalize modulus_gt_one; omega. + generalize modulus_gt_one; lia. Qed. -Hint Resolve modulus_pos: ints. +Global Hint Resolve modulus_pos: ints. (** * Representation of machine integers *) @@ -321,16 +322,16 @@ Proof. unfold half_modulus. rewrite modulus_power. set (ws1 := zwordsize - 1). replace (zwordsize) with (Z.succ ws1). - rewrite two_p_S. rewrite Z.mul_comm. apply Z_div_mult. omega. - unfold ws1. generalize wordsize_pos; omega. - unfold ws1. omega. + rewrite two_p_S. rewrite Z.mul_comm. apply Z_div_mult. lia. + unfold ws1. generalize wordsize_pos; lia. + unfold ws1. lia. Qed. Remark half_modulus_modulus: modulus = 2 * half_modulus. Proof. rewrite half_modulus_power. rewrite modulus_power. - rewrite <- two_p_S. apply f_equal. omega. - generalize wordsize_pos; omega. + rewrite <- two_p_S. apply f_equal. lia. + generalize wordsize_pos; lia. Qed. (** Relative positions, from greatest to smallest: @@ -346,38 +347,38 @@ Qed. Remark half_modulus_pos: half_modulus > 0. Proof. - rewrite half_modulus_power. apply two_p_gt_ZERO. generalize wordsize_pos; omega. + rewrite half_modulus_power. apply two_p_gt_ZERO. generalize wordsize_pos; lia. Qed. Remark min_signed_neg: min_signed < 0. Proof. - unfold min_signed. generalize half_modulus_pos. omega. + unfold min_signed. generalize half_modulus_pos. lia. Qed. Remark max_signed_pos: max_signed >= 0. Proof. - unfold max_signed. generalize half_modulus_pos. omega. + unfold max_signed. generalize half_modulus_pos. lia. Qed. Remark wordsize_max_unsigned: zwordsize <= max_unsigned. Proof. assert (zwordsize < modulus). rewrite modulus_power. apply two_p_strict. - generalize wordsize_pos. omega. - unfold max_unsigned. omega. + generalize wordsize_pos. lia. + unfold max_unsigned. lia. Qed. Remark two_wordsize_max_unsigned: 2 * zwordsize - 1 <= max_unsigned. Proof. assert (2 * zwordsize - 1 < modulus). - rewrite modulus_power. apply two_p_strict_2. generalize wordsize_pos; omega. - unfold max_unsigned; omega. + rewrite modulus_power. apply two_p_strict_2. generalize wordsize_pos; lia. + unfold max_unsigned; lia. Qed. Remark max_signed_unsigned: max_signed < max_unsigned. Proof. unfold max_signed, max_unsigned. rewrite half_modulus_modulus. - generalize half_modulus_pos. omega. + generalize half_modulus_pos. lia. Qed. Lemma unsigned_repr_eq: @@ -400,45 +401,45 @@ Definition eqm := eqmod modulus. Lemma eqm_refl: forall x, eqm x x. Proof (eqmod_refl modulus). -Hint Resolve eqm_refl: ints. +Global Hint Resolve eqm_refl: ints. Lemma eqm_refl2: forall x y, x = y -> eqm x y. Proof (eqmod_refl2 modulus). -Hint Resolve eqm_refl2: ints. +Global Hint Resolve eqm_refl2: ints. Lemma eqm_sym: forall x y, eqm x y -> eqm y x. Proof (eqmod_sym modulus). -Hint Resolve eqm_sym: ints. +Global Hint Resolve eqm_sym: ints. Lemma eqm_trans: forall x y z, eqm x y -> eqm y z -> eqm x z. Proof (eqmod_trans modulus). -Hint Resolve eqm_trans: ints. +Global Hint Resolve eqm_trans: ints. Lemma eqm_small_eq: forall x y, eqm x y -> 0 <= x < modulus -> 0 <= y < modulus -> x = y. Proof (eqmod_small_eq modulus). -Hint Resolve eqm_small_eq: ints. +Global Hint Resolve eqm_small_eq: ints. Lemma eqm_add: forall a b c d, eqm a b -> eqm c d -> eqm (a + c) (b + d). Proof (eqmod_add modulus). -Hint Resolve eqm_add: ints. +Global Hint Resolve eqm_add: ints. Lemma eqm_neg: forall x y, eqm x y -> eqm (-x) (-y). Proof (eqmod_neg modulus). -Hint Resolve eqm_neg: ints. +Global Hint Resolve eqm_neg: ints. Lemma eqm_sub: forall a b c d, eqm a b -> eqm c d -> eqm (a - c) (b - d). Proof (eqmod_sub modulus). -Hint Resolve eqm_sub: ints. +Global Hint Resolve eqm_sub: ints. Lemma eqm_mult: forall a b c d, eqm a c -> eqm b d -> eqm (a * b) (c * d). Proof (eqmod_mult modulus). -Hint Resolve eqm_mult: ints. +Global Hint Resolve eqm_mult: ints. Lemma eqm_same_bits: forall x y, @@ -466,7 +467,7 @@ Lemma eqm_unsigned_repr: Proof. unfold eqm; intros. rewrite unsigned_repr_eq. apply eqmod_mod. auto with ints. Qed. -Hint Resolve eqm_unsigned_repr: ints. +Global Hint Resolve eqm_unsigned_repr: ints. Lemma eqm_unsigned_repr_l: forall a b, eqm a b -> eqm (unsigned (repr a)) b. @@ -474,7 +475,7 @@ Proof. intros. apply eqm_trans with a. apply eqm_sym. apply eqm_unsigned_repr. auto. Qed. -Hint Resolve eqm_unsigned_repr_l: ints. +Global Hint Resolve eqm_unsigned_repr_l: ints. Lemma eqm_unsigned_repr_r: forall a b, eqm a b -> eqm a (unsigned (repr b)). @@ -482,7 +483,7 @@ Proof. intros. apply eqm_trans with b. auto. apply eqm_unsigned_repr. Qed. -Hint Resolve eqm_unsigned_repr_r: ints. +Global Hint Resolve eqm_unsigned_repr_r: ints. Lemma eqm_signed_unsigned: forall x, eqm (signed x) (unsigned x). @@ -495,17 +496,17 @@ Qed. Theorem unsigned_range: forall i, 0 <= unsigned i < modulus. Proof. - destruct i. simpl. omega. + destruct i. simpl. lia. Qed. -Hint Resolve unsigned_range: ints. +Global Hint Resolve unsigned_range: ints. Theorem unsigned_range_2: forall i, 0 <= unsigned i <= max_unsigned. Proof. intro; unfold max_unsigned. - generalize (unsigned_range i). omega. + generalize (unsigned_range i). lia. Qed. -Hint Resolve unsigned_range_2: ints. +Global Hint Resolve unsigned_range_2: ints. Theorem signed_range: forall i, min_signed <= signed i <= max_signed. @@ -513,18 +514,18 @@ Proof. intros. unfold signed. generalize (unsigned_range i). set (n := unsigned i). intros. case (zlt n half_modulus); intro. - unfold max_signed. generalize min_signed_neg. omega. + unfold max_signed. generalize min_signed_neg. lia. unfold min_signed, max_signed. - rewrite half_modulus_modulus in *. omega. + rewrite half_modulus_modulus in *. lia. Qed. Theorem repr_unsigned: forall i, repr (unsigned i) = i. Proof. destruct i; simpl. unfold repr. apply mkint_eq. - rewrite Z_mod_modulus_eq. apply Z.mod_small; omega. + rewrite Z_mod_modulus_eq. apply Z.mod_small; lia. Qed. -Hint Resolve repr_unsigned: ints. +Global Hint Resolve repr_unsigned: ints. Lemma repr_signed: forall i, repr (signed i) = i. @@ -532,7 +533,7 @@ Proof. intros. transitivity (repr (unsigned i)). apply eqm_samerepr. apply eqm_signed_unsigned. auto with ints. Qed. -Hint Resolve repr_signed: ints. +Global Hint Resolve repr_signed: ints. Opaque repr. @@ -545,34 +546,34 @@ Theorem unsigned_repr: forall z, 0 <= z <= max_unsigned -> unsigned (repr z) = z. Proof. intros. rewrite unsigned_repr_eq. - apply Z.mod_small. unfold max_unsigned in H. omega. + apply Z.mod_small. unfold max_unsigned in H. lia. Qed. -Hint Resolve unsigned_repr: ints. +Global Hint Resolve unsigned_repr: ints. Theorem signed_repr: forall z, min_signed <= z <= max_signed -> signed (repr z) = z. Proof. intros. unfold signed. destruct (zle 0 z). replace (unsigned (repr z)) with z. - rewrite zlt_true. auto. unfold max_signed in H. omega. - symmetry. apply unsigned_repr. generalize max_signed_unsigned. omega. + rewrite zlt_true. auto. unfold max_signed in H. lia. + symmetry. apply unsigned_repr. generalize max_signed_unsigned. lia. pose (z' := z + modulus). replace (repr z) with (repr z'). replace (unsigned (repr z')) with z'. - rewrite zlt_false. unfold z'. omega. + rewrite zlt_false. unfold z'. lia. unfold z'. unfold min_signed in H. - rewrite half_modulus_modulus. omega. + rewrite half_modulus_modulus. lia. symmetry. apply unsigned_repr. unfold z', max_unsigned. unfold min_signed, max_signed in H. - rewrite half_modulus_modulus. omega. - apply eqm_samerepr. unfold z'; red. exists 1. omega. + rewrite half_modulus_modulus. lia. + apply eqm_samerepr. unfold z'; red. exists 1. lia. Qed. Theorem signed_eq_unsigned: forall x, unsigned x <= max_signed -> signed x = unsigned x. Proof. intros. unfold signed. destruct (zlt (unsigned x) half_modulus). - auto. unfold max_signed in H. omegaContradiction. + auto. unfold max_signed in H. extlia. Qed. Theorem signed_positive: @@ -580,7 +581,7 @@ Theorem signed_positive: Proof. intros. unfold signed, max_signed. generalize (unsigned_range x) half_modulus_modulus half_modulus_pos; intros. - destruct (zlt (unsigned x) half_modulus); omega. + destruct (zlt (unsigned x) half_modulus); lia. Qed. (** ** Properties of zero, one, minus one *) @@ -592,11 +593,11 @@ Qed. Theorem unsigned_one: unsigned one = 1. Proof. - unfold one; rewrite unsigned_repr_eq. apply Z.mod_small. split. omega. + unfold one; rewrite unsigned_repr_eq. apply Z.mod_small. split. lia. unfold modulus. replace wordsize with (S(Init.Nat.pred wordsize)). rewrite two_power_nat_S. generalize (two_power_nat_pos (Init.Nat.pred wordsize)). - omega. - generalize wordsize_pos. unfold zwordsize. omega. + lia. + generalize wordsize_pos. unfold zwordsize. lia. Qed. Theorem unsigned_mone: unsigned mone = modulus - 1. @@ -604,25 +605,25 @@ Proof. unfold mone; rewrite unsigned_repr_eq. replace (-1) with ((modulus - 1) + (-1) * modulus). rewrite Z_mod_plus_full. apply Z.mod_small. - generalize modulus_pos. omega. omega. + generalize modulus_pos. lia. lia. Qed. Theorem signed_zero: signed zero = 0. Proof. - unfold signed. rewrite unsigned_zero. apply zlt_true. generalize half_modulus_pos; omega. + unfold signed. rewrite unsigned_zero. apply zlt_true. generalize half_modulus_pos; lia. Qed. Theorem signed_one: zwordsize > 1 -> signed one = 1. Proof. intros. unfold signed. rewrite unsigned_one. apply zlt_true. - change 1 with (two_p 0). rewrite half_modulus_power. apply two_p_monotone_strict. omega. + change 1 with (two_p 0). rewrite half_modulus_power. apply two_p_monotone_strict. lia. Qed. Theorem signed_mone: signed mone = -1. Proof. unfold signed. rewrite unsigned_mone. - rewrite zlt_false. omega. - rewrite half_modulus_modulus. generalize half_modulus_pos. omega. + rewrite zlt_false. lia. + rewrite half_modulus_modulus. generalize half_modulus_pos. lia. Qed. Theorem one_not_zero: one <> zero. @@ -636,7 +637,7 @@ Theorem unsigned_repr_wordsize: unsigned iwordsize = zwordsize. Proof. unfold iwordsize; rewrite unsigned_repr_eq. apply Z.mod_small. - generalize wordsize_pos wordsize_max_unsigned; unfold max_unsigned; omega. + generalize wordsize_pos wordsize_max_unsigned; unfold max_unsigned; lia. Qed. (** ** Properties of equality *) @@ -695,7 +696,7 @@ Proof. Qed. Theorem add_commut: forall x y, add x y = add y x. -Proof. intros; unfold add. decEq. omega. Qed. +Proof. intros; unfold add. decEq. lia. Qed. Theorem add_zero: forall x, add x zero = x. Proof. @@ -729,7 +730,7 @@ Theorem add_neg_zero: forall x, add x (neg x) = zero. Proof. intros; unfold add, neg, zero. apply eqm_samerepr. replace 0 with (unsigned x + (- (unsigned x))). - auto with ints. omega. + auto with ints. lia. Qed. Theorem unsigned_add_carry: @@ -741,8 +742,8 @@ Proof. rewrite unsigned_repr_eq. generalize (unsigned_range x) (unsigned_range y). intros. destruct (zlt (unsigned x + unsigned y) modulus). - rewrite unsigned_zero. apply Zmod_unique with 0. omega. omega. - rewrite unsigned_one. apply Zmod_unique with 1. omega. omega. + rewrite unsigned_zero. apply Zmod_unique with 0. lia. lia. + rewrite unsigned_one. apply Zmod_unique with 1. lia. lia. Qed. Corollary unsigned_add_either: @@ -753,8 +754,8 @@ Proof. intros. rewrite unsigned_add_carry. unfold add_carry. rewrite unsigned_zero. rewrite Z.add_0_r. destruct (zlt (unsigned x + unsigned y) modulus). - rewrite unsigned_zero. left; omega. - rewrite unsigned_one. right; omega. + rewrite unsigned_zero. left; lia. + rewrite unsigned_one. right; lia. Qed. (** ** Properties of negation *) @@ -773,7 +774,7 @@ Theorem neg_involutive: forall x, neg (neg x) = x. Proof. intros; unfold neg. apply eqm_repr_eq. eapply eqm_trans. apply eqm_neg. - apply eqm_unsigned_repr_l. apply eqm_refl. apply eqm_refl2. omega. + apply eqm_unsigned_repr_l. apply eqm_refl. apply eqm_refl2. lia. Qed. Theorem neg_add_distr: forall x y, neg(add x y) = add (neg x) (neg y). @@ -783,7 +784,7 @@ Proof. auto with ints. replace (- (unsigned x + unsigned y)) with ((- unsigned x) + (- unsigned y)). - auto with ints. omega. + auto with ints. lia. Qed. (** ** Properties of subtraction *) @@ -791,7 +792,7 @@ Qed. Theorem sub_zero_l: forall x, sub x zero = x. Proof. intros; unfold sub. rewrite unsigned_zero. - replace (unsigned x - 0) with (unsigned x) by omega. apply repr_unsigned. + replace (unsigned x - 0) with (unsigned x) by lia. apply repr_unsigned. Qed. Theorem sub_zero_r: forall x, sub zero x = neg x. @@ -807,7 +808,7 @@ Qed. Theorem sub_idem: forall x, sub x x = zero. Proof. - intros; unfold sub. unfold zero. decEq. omega. + intros; unfold sub. unfold zero. decEq. lia. Qed. Theorem sub_add_l: forall x y z, sub (add x y) z = add (sub x z) y. @@ -850,8 +851,8 @@ Proof. rewrite unsigned_repr_eq. generalize (unsigned_range x) (unsigned_range y). intros. destruct (zlt (unsigned x - unsigned y) 0). - rewrite unsigned_one. apply Zmod_unique with (-1). omega. omega. - rewrite unsigned_zero. apply Zmod_unique with 0. omega. omega. + rewrite unsigned_one. apply Zmod_unique with (-1). lia. lia. + rewrite unsigned_zero. apply Zmod_unique with 0. lia. lia. Qed. (** ** Properties of multiplication *) @@ -878,9 +879,9 @@ Theorem mul_mone: forall x, mul x mone = neg x. Proof. intros; unfold mul, neg. rewrite unsigned_mone. apply eqm_samerepr. - replace (-unsigned x) with (0 - unsigned x) by omega. + replace (-unsigned x) with (0 - unsigned x) by lia. replace (unsigned x * (modulus - 1)) with (unsigned x * modulus - unsigned x) by ring. - apply eqm_sub. exists (unsigned x). omega. apply eqm_refl. + apply eqm_sub. exists (unsigned x). lia. apply eqm_refl. Qed. Theorem mul_assoc: forall x y z, mul (mul x y) z = mul x (mul y z). @@ -955,7 +956,7 @@ Proof. generalize (unsigned_range y); intro. assert (unsigned y <> 0). red; intro. elim H. rewrite <- (repr_unsigned y). unfold zero. congruence. - unfold y'. omega. + unfold y'. lia. auto with ints. Qed. @@ -1025,7 +1026,7 @@ Proof. assert (Z.quot x' one = x'). symmetry. apply Zquot_unique_full with 0. red. change (Z.abs one) with 1. - destruct (zle 0 x'). left. omega. right. omega. + destruct (zle 0 x'). left. lia. right. lia. unfold one; ring. congruence. Qed. @@ -1053,12 +1054,12 @@ Proof. assert (unsigned d <> 0). { red; intros. elim H. rewrite <- (repr_unsigned d). rewrite H0; auto. } assert (0 < D). - { unfold D. generalize (unsigned_range d); intros. omega. } + { unfold D. generalize (unsigned_range d); intros. lia. } assert (0 <= Q <= max_unsigned). { unfold Q. apply Zdiv_interval_2. rewrite <- E1; apply unsigned_range_2. - omega. unfold max_unsigned; generalize modulus_pos; omega. omega. } - omega. + lia. unfold max_unsigned; generalize modulus_pos; lia. lia. } + lia. Qed. Lemma unsigned_signed: @@ -1067,8 +1068,8 @@ Proof. intros. unfold lt. rewrite signed_zero. unfold signed. generalize (unsigned_range n). rewrite half_modulus_modulus. intros. destruct (zlt (unsigned n) half_modulus). -- rewrite zlt_false by omega. auto. -- rewrite zlt_true by omega. ring. +- rewrite zlt_false by lia. auto. +- rewrite zlt_true by lia. ring. Qed. Theorem divmods2_divs_mods: @@ -1096,24 +1097,24 @@ Proof. - (* D = 1 *) rewrite e. rewrite Z.quot_1_r; auto. - (* D = -1 *) - rewrite e. change (-1) with (Z.opp 1). rewrite Z.quot_opp_r by omega. + rewrite e. change (-1) with (Z.opp 1). rewrite Z.quot_opp_r by lia. rewrite Z.quot_1_r. assert (N <> min_signed). { red; intros; destruct H0. + elim H0. rewrite <- (repr_signed n). rewrite <- H2. rewrite H4. auto. + elim H0. rewrite <- (repr_signed d). unfold D in e; rewrite e; auto. } - unfold min_signed, max_signed in *. omega. + unfold min_signed, max_signed in *. lia. - (* |D| > 1 *) assert (Z.abs (Z.quot N D) < half_modulus). - { rewrite <- Z.quot_abs by omega. apply Zquot_lt_upper_bound. - xomega. xomega. + { rewrite <- Z.quot_abs by lia. apply Zquot_lt_upper_bound. + extlia. extlia. apply Z.le_lt_trans with (half_modulus * 1). - rewrite Z.mul_1_r. unfold min_signed, max_signed in H3; xomega. - apply Zmult_lt_compat_l. generalize half_modulus_pos; omega. xomega. } + rewrite Z.mul_1_r. unfold min_signed, max_signed in H3; extlia. + apply Zmult_lt_compat_l. generalize half_modulus_pos; lia. extlia. } rewrite Z.abs_lt in H4. - unfold min_signed, max_signed; omega. + unfold min_signed, max_signed; lia. } - unfold proj_sumbool; rewrite ! zle_true by omega; simpl. + unfold proj_sumbool; rewrite ! zle_true by lia; simpl. unfold Q, R; rewrite H2; auto. Qed. @@ -1164,7 +1165,7 @@ Qed. Lemma bits_mone: forall i, 0 <= i < zwordsize -> testbit mone i = true. Proof. - intros. unfold mone. rewrite testbit_repr; auto. apply Ztestbit_m1. omega. + intros. unfold mone. rewrite testbit_repr; auto. apply Ztestbit_m1. lia. Qed. Hint Rewrite bits_zero bits_mone : ints. @@ -1181,7 +1182,7 @@ Proof. unfold zwordsize, ws1, wordsize. destruct WS.wordsize as [] eqn:E. elim WS.wordsize_not_zero; auto. - rewrite Nat2Z.inj_succ. simpl. omega. + rewrite Nat2Z.inj_succ. simpl. lia. assert (half_modulus = two_power_nat ws1). rewrite two_power_nat_two_p. rewrite <- H. apply half_modulus_power. rewrite H; rewrite H0. @@ -1195,11 +1196,11 @@ Lemma bits_signed: Proof. intros. destruct (zlt i zwordsize). - - apply same_bits_eqm. apply eqm_signed_unsigned. omega. + - apply same_bits_eqm. apply eqm_signed_unsigned. lia. - unfold signed. rewrite sign_bit_of_unsigned. destruct (zlt (unsigned x) half_modulus). + apply Ztestbit_above with wordsize. apply unsigned_range. auto. + apply Ztestbit_above_neg with wordsize. - fold modulus. generalize (unsigned_range x). omega. auto. + fold modulus. generalize (unsigned_range x). lia. auto. Qed. Lemma bits_le: @@ -1207,9 +1208,9 @@ Lemma bits_le: (forall i, 0 <= i < zwordsize -> testbit x i = true -> testbit y i = true) -> unsigned x <= unsigned y. Proof. - intros. apply Ztestbit_le. generalize (unsigned_range y); omega. + intros. apply Ztestbit_le. generalize (unsigned_range y); lia. intros. fold (testbit y i). destruct (zlt i zwordsize). - apply H. omega. auto. + apply H. lia. auto. fold (testbit x i) in H1. rewrite bits_above in H1; auto. congruence. Qed. @@ -1477,10 +1478,10 @@ Lemma unsigned_not: forall x, unsigned (not x) = max_unsigned - unsigned x. Proof. intros. transitivity (unsigned (repr(-unsigned x - 1))). - f_equal. bit_solve. rewrite testbit_repr; auto. symmetry. apply Z_one_complement. omega. + f_equal. bit_solve. rewrite testbit_repr; auto. symmetry. apply Z_one_complement. lia. rewrite unsigned_repr_eq. apply Zmod_unique with (-1). - unfold max_unsigned. omega. - generalize (unsigned_range x). unfold max_unsigned. omega. + unfold max_unsigned. lia. + generalize (unsigned_range x). unfold max_unsigned. lia. Qed. Theorem not_neg: @@ -1490,9 +1491,9 @@ Proof. rewrite <- (repr_unsigned x) at 1. unfold add. rewrite !testbit_repr; auto. transitivity (Z.testbit (-unsigned x - 1) i). - symmetry. apply Z_one_complement. omega. + symmetry. apply Z_one_complement. lia. apply same_bits_eqm; auto. - replace (-unsigned x - 1) with (-unsigned x + (-1)) by omega. + replace (-unsigned x - 1) with (-unsigned x + (-1)) by lia. apply eqm_add. unfold neg. apply eqm_unsigned_repr. rewrite unsigned_mone. exists (-1). ring. @@ -1534,9 +1535,9 @@ Proof. replace (unsigned (xor b one)) with (1 - unsigned b). destruct (zlt (unsigned x - unsigned y - unsigned b)). rewrite zlt_true. rewrite xor_zero_l; auto. - unfold max_unsigned; omega. + unfold max_unsigned; lia. rewrite zlt_false. rewrite xor_idem; auto. - unfold max_unsigned; omega. + unfold max_unsigned; lia. destruct H; subst b. rewrite xor_zero_l. rewrite unsigned_one, unsigned_zero; auto. rewrite xor_idem. rewrite unsigned_one, unsigned_zero; auto. @@ -1555,16 +1556,16 @@ Proof. rewrite (Zdecomp x) in *. rewrite (Zdecomp y) in *. transitivity (Z.testbit (Zshiftin (Z.odd x || Z.odd y) (Z.div2 x + Z.div2 y)) i). - f_equal. rewrite !Zshiftin_spec. - exploit (EXCL 0). omega. rewrite !Ztestbit_shiftin_base. intros. + exploit (EXCL 0). lia. rewrite !Ztestbit_shiftin_base. intros. Opaque Z.mul. destruct (Z.odd x); destruct (Z.odd y); simpl in *; discriminate || ring. - rewrite !Ztestbit_shiftin; auto. destruct (zeq i 0). + auto. - + apply IND. omega. intros. - exploit (EXCL (Z.succ j)). omega. + + apply IND. lia. intros. + exploit (EXCL (Z.succ j)). lia. rewrite !Ztestbit_shiftin_succ. auto. - omega. omega. + lia. lia. Qed. Theorem add_is_or: @@ -1573,10 +1574,10 @@ Theorem add_is_or: add x y = or x y. Proof. bit_solve. unfold add. rewrite testbit_repr; auto. - apply Z_add_is_or. omega. + apply Z_add_is_or. lia. intros. assert (testbit (and x y) j = testbit zero j) by congruence. - autorewrite with ints in H2. assumption. omega. + autorewrite with ints in H2. assumption. lia. Qed. Theorem xor_is_or: @@ -1622,7 +1623,7 @@ Proof. intros. unfold shl. rewrite testbit_repr; auto. destruct (zlt i (unsigned y)). apply Z.shiftl_spec_low. auto. - apply Z.shiftl_spec_high. omega. omega. + apply Z.shiftl_spec_high. lia. lia. Qed. Lemma bits_shru: @@ -1636,7 +1637,7 @@ Proof. destruct (zlt (i + unsigned y) zwordsize). auto. apply bits_above; auto. - omega. + lia. Qed. Lemma bits_shr: @@ -1647,15 +1648,15 @@ Lemma bits_shr: Proof. intros. unfold shr. rewrite testbit_repr; auto. rewrite Z.shiftr_spec. apply bits_signed. - generalize (unsigned_range y); omega. - omega. + generalize (unsigned_range y); lia. + lia. Qed. Hint Rewrite bits_shl bits_shru bits_shr: ints. Theorem shl_zero: forall x, shl x zero = x. Proof. - bit_solve. rewrite unsigned_zero. rewrite zlt_false. f_equal; omega. omega. + bit_solve. rewrite unsigned_zero. rewrite zlt_false. f_equal; lia. lia. Qed. Lemma bitwise_binop_shl: @@ -1667,7 +1668,7 @@ Proof. intros. apply same_bits_eq; intros. rewrite H; auto. rewrite !bits_shl; auto. destruct (zlt i (unsigned n)); auto. - rewrite H; auto. generalize (unsigned_range n); omega. + rewrite H; auto. generalize (unsigned_range n); lia. Qed. Theorem and_shl: @@ -1695,7 +1696,7 @@ Lemma ltu_inv: forall x y, ltu x y = true -> 0 <= unsigned x < unsigned y. Proof. unfold ltu; intros. destruct (zlt (unsigned x) (unsigned y)). - split; auto. generalize (unsigned_range x); omega. + split; auto. generalize (unsigned_range x); lia. discriminate. Qed. @@ -1716,15 +1717,15 @@ Proof. generalize (ltu_iwordsize_inv _ H) (ltu_iwordsize_inv _ H0); intros. assert (unsigned (add y z) = unsigned y + unsigned z). unfold add. apply unsigned_repr. - generalize two_wordsize_max_unsigned; omega. + generalize two_wordsize_max_unsigned; lia. apply same_bits_eq; intros. rewrite bits_shl; auto. destruct (zlt i (unsigned z)). - - rewrite bits_shl; auto. rewrite zlt_true. auto. omega. + - rewrite bits_shl; auto. rewrite zlt_true. auto. lia. - rewrite bits_shl. destruct (zlt (i - unsigned z) (unsigned y)). - + rewrite bits_shl; auto. rewrite zlt_true. auto. omega. - + rewrite bits_shl; auto. rewrite zlt_false. f_equal. omega. omega. - + omega. + + rewrite bits_shl; auto. rewrite zlt_true. auto. lia. + + rewrite bits_shl; auto. rewrite zlt_false. f_equal. lia. lia. + + lia. Qed. Theorem sub_ltu: @@ -1734,12 +1735,12 @@ Theorem sub_ltu: Proof. intros. generalize (ltu_inv x y H). intros . - split. omega. omega. + split. lia. lia. Qed. Theorem shru_zero: forall x, shru x zero = x. Proof. - bit_solve. rewrite unsigned_zero. rewrite zlt_true. f_equal; omega. omega. + bit_solve. rewrite unsigned_zero. rewrite zlt_true. f_equal; lia. lia. Qed. Lemma bitwise_binop_shru: @@ -1751,7 +1752,7 @@ Proof. intros. apply same_bits_eq; intros. rewrite H; auto. rewrite !bits_shru; auto. destruct (zlt (i + unsigned n) zwordsize); auto. - rewrite H; auto. generalize (unsigned_range n); omega. + rewrite H; auto. generalize (unsigned_range n); lia. Qed. Theorem and_shru: @@ -1786,20 +1787,20 @@ Proof. generalize (ltu_iwordsize_inv _ H) (ltu_iwordsize_inv _ H0); intros. assert (unsigned (add y z) = unsigned y + unsigned z). unfold add. apply unsigned_repr. - generalize two_wordsize_max_unsigned; omega. + generalize two_wordsize_max_unsigned; lia. apply same_bits_eq; intros. rewrite bits_shru; auto. destruct (zlt (i + unsigned z) zwordsize). - rewrite bits_shru. destruct (zlt (i + unsigned z + unsigned y) zwordsize). - + rewrite bits_shru; auto. rewrite zlt_true. f_equal. omega. omega. - + rewrite bits_shru; auto. rewrite zlt_false. auto. omega. - + omega. - - rewrite bits_shru; auto. rewrite zlt_false. auto. omega. + + rewrite bits_shru; auto. rewrite zlt_true. f_equal. lia. lia. + + rewrite bits_shru; auto. rewrite zlt_false. auto. lia. + + lia. + - rewrite bits_shru; auto. rewrite zlt_false. auto. lia. Qed. Theorem shr_zero: forall x, shr x zero = x. Proof. - bit_solve. rewrite unsigned_zero. rewrite zlt_true. f_equal; omega. omega. + bit_solve. rewrite unsigned_zero. rewrite zlt_true. f_equal; lia. lia. Qed. Lemma bitwise_binop_shr: @@ -1811,8 +1812,8 @@ Proof. rewrite H; auto. rewrite !bits_shr; auto. rewrite H; auto. destruct (zlt (i + unsigned n) zwordsize). - generalize (unsigned_range n); omega. - omega. + generalize (unsigned_range n); lia. + lia. Qed. Theorem and_shr: @@ -1847,15 +1848,15 @@ Proof. generalize (ltu_iwordsize_inv _ H) (ltu_iwordsize_inv _ H0); intros. assert (unsigned (add y z) = unsigned y + unsigned z). unfold add. apply unsigned_repr. - generalize two_wordsize_max_unsigned; omega. + generalize two_wordsize_max_unsigned; lia. apply same_bits_eq; intros. rewrite !bits_shr; auto. f_equal. destruct (zlt (i + unsigned z) zwordsize). - rewrite H4. replace (i + (unsigned y + unsigned z)) with (i + unsigned z + unsigned y) by omega. auto. + rewrite H4. replace (i + (unsigned y + unsigned z)) with (i + unsigned z + unsigned y) by lia. auto. rewrite (zlt_false _ (i + unsigned (add y z))). - destruct (zlt (zwordsize - 1 + unsigned y) zwordsize); omega. - omega. - destruct (zlt (i + unsigned z) zwordsize); omega. + destruct (zlt (zwordsize - 1 + unsigned y) zwordsize); lia. + lia. + destruct (zlt (i + unsigned z) zwordsize); lia. Qed. Theorem and_shr_shru: @@ -1865,7 +1866,7 @@ Proof. intros. apply same_bits_eq; intros. rewrite bits_and; auto. rewrite bits_shr; auto. rewrite !bits_shru; auto. destruct (zlt (i + unsigned z) zwordsize). - - rewrite bits_and; auto. generalize (unsigned_range z); omega. + - rewrite bits_and; auto. generalize (unsigned_range z); lia. - apply andb_false_r. Qed. @@ -1891,17 +1892,17 @@ Proof. rewrite sign_bit_of_unsigned. unfold lt. rewrite signed_zero. unfold signed. destruct (zlt (unsigned x) half_modulus). - rewrite zlt_false. auto. generalize (unsigned_range x); omega. + rewrite zlt_false. auto. generalize (unsigned_range x); lia. rewrite zlt_true. unfold one; rewrite testbit_repr; auto. - generalize (unsigned_range x); omega. - omega. + generalize (unsigned_range x); lia. + lia. rewrite zlt_false. unfold testbit. rewrite Ztestbit_eq. rewrite zeq_false. destruct (lt x zero). rewrite unsigned_one. simpl Z.div2. rewrite Z.testbit_0_l; auto. rewrite unsigned_zero. simpl Z.div2. rewrite Z.testbit_0_l; auto. - auto. omega. omega. - generalize wordsize_max_unsigned; omega. + auto. lia. lia. + generalize wordsize_max_unsigned; lia. Qed. Theorem shr_lt_zero: @@ -1912,13 +1913,13 @@ Proof. rewrite bits_shr; auto. rewrite unsigned_repr. transitivity (testbit x (zwordsize - 1)). - f_equal. destruct (zlt (i + (zwordsize - 1)) zwordsize); omega. + f_equal. destruct (zlt (i + (zwordsize - 1)) zwordsize); lia. rewrite sign_bit_of_unsigned. unfold lt. rewrite signed_zero. unfold signed. destruct (zlt (unsigned x) half_modulus). - rewrite zlt_false. rewrite bits_zero; auto. generalize (unsigned_range x); omega. - rewrite zlt_true. rewrite bits_mone; auto. generalize (unsigned_range x); omega. - generalize wordsize_max_unsigned; omega. + rewrite zlt_false. rewrite bits_zero; auto. generalize (unsigned_range x); lia. + rewrite zlt_true. rewrite bits_mone; auto. generalize (unsigned_range x); lia. + generalize wordsize_max_unsigned; lia. Qed. (** ** Properties of rotations *) @@ -1935,20 +1936,20 @@ Proof. exploit (Z_mod_lt (unsigned y) zwordsize). apply wordsize_pos. fold j. intros RANGE. rewrite testbit_repr; auto. - rewrite Z.lor_spec. rewrite Z.shiftr_spec. 2: omega. + rewrite Z.lor_spec. rewrite Z.shiftr_spec. 2: lia. destruct (zlt i j). - rewrite Z.shiftl_spec_low; auto. simpl. unfold testbit. f_equal. symmetry. apply Zmod_unique with (-k - 1). rewrite EQ. ring. - omega. + lia. - rewrite Z.shiftl_spec_high. fold (testbit x (i + (zwordsize - j))). rewrite bits_above. rewrite orb_false_r. fold (testbit x (i - j)). f_equal. symmetry. apply Zmod_unique with (-k). rewrite EQ. ring. - omega. omega. omega. omega. + lia. lia. lia. lia. Qed. Lemma bits_ror: @@ -1963,20 +1964,20 @@ Proof. exploit (Z_mod_lt (unsigned y) zwordsize). apply wordsize_pos. fold j. intros RANGE. rewrite testbit_repr; auto. - rewrite Z.lor_spec. rewrite Z.shiftr_spec. 2: omega. + rewrite Z.lor_spec. rewrite Z.shiftr_spec. 2: lia. destruct (zlt (i + j) zwordsize). - rewrite Z.shiftl_spec_low; auto. rewrite orb_false_r. unfold testbit. f_equal. symmetry. apply Zmod_unique with k. rewrite EQ. ring. - omega. omega. + lia. lia. - rewrite Z.shiftl_spec_high. fold (testbit x (i + j)). rewrite bits_above. simpl. unfold testbit. f_equal. symmetry. apply Zmod_unique with (k + 1). rewrite EQ. ring. - omega. omega. omega. omega. + lia. lia. lia. lia. Qed. Hint Rewrite bits_rol bits_ror: ints. @@ -1993,8 +1994,8 @@ Proof. - rewrite andb_false_r; auto. - generalize (unsigned_range n); intros. rewrite bits_mone. rewrite andb_true_r. f_equal. - symmetry. apply Z.mod_small. omega. - omega. + symmetry. apply Z.mod_small. lia. + lia. Qed. Theorem shru_rolm: @@ -2009,9 +2010,9 @@ Proof. - generalize (unsigned_range n); intros. rewrite bits_mone. rewrite andb_true_r. f_equal. unfold sub. rewrite unsigned_repr. rewrite unsigned_repr_wordsize. - symmetry. apply Zmod_unique with (-1). ring. omega. - rewrite unsigned_repr_wordsize. generalize wordsize_max_unsigned. omega. - omega. + symmetry. apply Zmod_unique with (-1). ring. lia. + rewrite unsigned_repr_wordsize. generalize wordsize_max_unsigned. lia. + lia. - rewrite andb_false_r; auto. Qed. @@ -2065,11 +2066,11 @@ Proof. apply eqmod_sub. apply eqmod_sym. apply eqmod_mod. apply wordsize_pos. apply eqmod_refl. - replace (i - M - N) with (i - (M + N)) by omega. + replace (i - M - N) with (i - (M + N)) by lia. apply eqmod_sub. apply eqmod_refl. apply eqmod_trans with (Z.modulo (unsigned n + unsigned m) zwordsize). - replace (M + N) with (N + M) by omega. apply eqmod_mod. apply wordsize_pos. + replace (M + N) with (N + M) by lia. apply eqmod_mod. apply wordsize_pos. unfold modu, add. fold M; fold N. rewrite unsigned_repr_wordsize. assert (forall a, eqmod zwordsize a (unsigned (repr a))). intros. eapply eqmod_divides. apply eqm_unsigned_repr. assumption. @@ -2116,7 +2117,7 @@ Proof. unfold sub. rewrite unsigned_repr. rewrite unsigned_repr_wordsize. apply eqmod_mod_eq. apply wordsize_pos. exists 1. ring. rewrite unsigned_repr_wordsize. - generalize wordsize_pos; generalize wordsize_max_unsigned; omega. + generalize wordsize_pos; generalize wordsize_max_unsigned; lia. Qed. Theorem ror_rol_neg: @@ -2124,9 +2125,9 @@ Theorem ror_rol_neg: Proof. intros. apply same_bits_eq; intros. rewrite bits_ror by auto. rewrite bits_rol by auto. - f_equal. apply eqmod_mod_eq. omega. + f_equal. apply eqmod_mod_eq. lia. apply eqmod_trans with (i - (- unsigned y)). - apply eqmod_refl2; omega. + apply eqmod_refl2; lia. apply eqmod_sub. apply eqmod_refl. apply eqmod_divides with modulus. apply eqm_unsigned_repr. auto. @@ -2149,8 +2150,8 @@ Proof. assert (unsigned (add y z) = zwordsize). rewrite H1. apply unsigned_repr_wordsize. unfold add in H5. rewrite unsigned_repr in H5. - omega. - generalize two_wordsize_max_unsigned; omega. + lia. + generalize two_wordsize_max_unsigned; lia. - apply eqm_unsigned_repr_r. apply eqm_refl2. f_equal. apply Z.mod_small; auto. Qed. @@ -2166,10 +2167,10 @@ Proof. destruct (Z_is_power2 (unsigned n)) as [i|] eqn:E; inv H. assert (0 <= i < zwordsize). { apply Z_is_power2_range with (unsigned n). - generalize wordsize_pos; omega. + generalize wordsize_pos; lia. rewrite <- modulus_power. apply unsigned_range. auto. } - rewrite unsigned_repr; auto. generalize wordsize_max_unsigned; omega. + rewrite unsigned_repr; auto. generalize wordsize_max_unsigned; lia. Qed. Lemma is_power2_rng: @@ -2203,10 +2204,10 @@ Remark two_p_range: 0 <= two_p n <= max_unsigned. Proof. intros. split. - assert (two_p n > 0). apply two_p_gt_ZERO. omega. omega. + assert (two_p n > 0). apply two_p_gt_ZERO. lia. lia. generalize (two_p_monotone_strict _ _ H). unfold zwordsize; rewrite <- two_power_nat_two_p. - unfold max_unsigned, modulus. omega. + unfold max_unsigned, modulus. lia. Qed. Lemma is_power2_two_p: @@ -2214,7 +2215,7 @@ Lemma is_power2_two_p: is_power2 (repr (two_p n)) = Some (repr n). Proof. intros. unfold is_power2. rewrite unsigned_repr. - rewrite Z_is_power2_complete by omega; auto. + rewrite Z_is_power2_complete by lia; auto. apply two_p_range. auto. Qed. @@ -2228,7 +2229,7 @@ Lemma shl_mul_two_p: Proof. intros. unfold shl, mul. apply eqm_samerepr. rewrite Zshiftl_mul_two_p. auto with ints. - generalize (unsigned_range y); omega. + generalize (unsigned_range y); lia. Qed. Theorem shl_mul: @@ -2264,19 +2265,19 @@ Proof. rewrite shl_mul_two_p. unfold mul. apply eqm_unsigned_repr_l. apply eqm_mult; auto with ints. apply eqm_unsigned_repr_l. apply eqm_refl2. rewrite unsigned_repr. auto. - generalize wordsize_max_unsigned; omega. + generalize wordsize_max_unsigned; lia. - bit_solve. rewrite unsigned_repr. destruct (zlt i n). + auto. + replace (testbit y i) with false. apply andb_false_r. symmetry. unfold testbit. - assert (EQ: Z.of_nat (Z.to_nat n) = n) by (apply Z2Nat.id; omega). + assert (EQ: Z.of_nat (Z.to_nat n) = n) by (apply Z2Nat.id; lia). apply Ztestbit_above with (Z.to_nat n). rewrite <- EQ in H0. rewrite <- two_power_nat_two_p in H0. - generalize (unsigned_range y); omega. + generalize (unsigned_range y); lia. rewrite EQ; auto. - + generalize wordsize_max_unsigned; omega. + + generalize wordsize_max_unsigned; lia. Qed. (** Unsigned right shifts and unsigned divisions by powers of 2. *) @@ -2287,7 +2288,7 @@ Lemma shru_div_two_p: Proof. intros. unfold shru. rewrite Zshiftr_div_two_p. auto. - generalize (unsigned_range y); omega. + generalize (unsigned_range y); lia. Qed. Theorem divu_pow2: @@ -2307,7 +2308,7 @@ Lemma shr_div_two_p: Proof. intros. unfold shr. rewrite Zshiftr_div_two_p. auto. - generalize (unsigned_range y); omega. + generalize (unsigned_range y); lia. Qed. Theorem divs_pow2: @@ -2360,24 +2361,24 @@ Proof. set (uy := unsigned y). assert (0 <= uy < zwordsize - 1). generalize (ltu_inv _ _ H). rewrite unsigned_repr. auto. - generalize wordsize_pos wordsize_max_unsigned; omega. + generalize wordsize_pos wordsize_max_unsigned; lia. rewrite shr_div_two_p. unfold shrx. unfold divs. assert (shl one y = repr (two_p uy)). transitivity (mul one (repr (two_p uy))). symmetry. apply mul_pow2. replace y with (repr uy). - apply is_power2_two_p. omega. apply repr_unsigned. + apply is_power2_two_p. lia. apply repr_unsigned. rewrite mul_commut. apply mul_one. - assert (two_p uy > 0). apply two_p_gt_ZERO. omega. + assert (two_p uy > 0). apply two_p_gt_ZERO. lia. assert (two_p uy < half_modulus). rewrite half_modulus_power. apply two_p_monotone_strict. auto. assert (two_p uy < modulus). - rewrite modulus_power. apply two_p_monotone_strict. omega. + rewrite modulus_power. apply two_p_monotone_strict. lia. assert (unsigned (shl one y) = two_p uy). - rewrite H1. apply unsigned_repr. unfold max_unsigned. omega. + rewrite H1. apply unsigned_repr. unfold max_unsigned. lia. assert (signed (shl one y) = two_p uy). rewrite H1. apply signed_repr. - unfold max_signed. generalize min_signed_neg. omega. + unfold max_signed. generalize min_signed_neg. lia. rewrite H6. rewrite Zquot_Zdiv; auto. unfold lt. rewrite signed_zero. @@ -2386,10 +2387,10 @@ Proof. assert (signed (sub (shl one y) one) = two_p uy - 1). unfold sub. rewrite H5. rewrite unsigned_one. apply signed_repr. - generalize min_signed_neg. unfold max_signed. omega. - rewrite H7. rewrite signed_repr. f_equal. f_equal. omega. + generalize min_signed_neg. unfold max_signed. lia. + rewrite H7. rewrite signed_repr. f_equal. f_equal. lia. generalize (signed_range x). intros. - assert (two_p uy - 1 <= max_signed). unfold max_signed. omega. omega. + assert (two_p uy - 1 <= max_signed). unfold max_signed. lia. lia. Qed. Theorem shrx_shr_2: @@ -2404,19 +2405,19 @@ Proof. generalize (unsigned_range y); fold uy; intros. assert (0 <= uy < zwordsize - 1). generalize (ltu_inv _ _ H). rewrite unsigned_repr. auto. - generalize wordsize_pos wordsize_max_unsigned; omega. + generalize wordsize_pos wordsize_max_unsigned; lia. assert (two_p uy < modulus). - rewrite modulus_power. apply two_p_monotone_strict. omega. + rewrite modulus_power. apply two_p_monotone_strict. lia. f_equal. rewrite shl_mul_two_p. fold uy. rewrite mul_commut. rewrite mul_one. unfold sub. rewrite unsigned_one. rewrite unsigned_repr. rewrite unsigned_repr_wordsize. fold uy. apply same_bits_eq; intros. rewrite bits_shru by auto. - rewrite testbit_repr by auto. rewrite Ztestbit_two_p_m1 by omega. - rewrite unsigned_repr by (generalize wordsize_max_unsigned; omega). + rewrite testbit_repr by auto. rewrite Ztestbit_two_p_m1 by lia. + rewrite unsigned_repr by (generalize wordsize_max_unsigned; lia). destruct (zlt i uy). - rewrite zlt_true by omega. rewrite bits_mone by omega. auto. - rewrite zlt_false by omega. auto. - assert (two_p uy > 0) by (apply two_p_gt_ZERO; omega). unfold max_unsigned; omega. + rewrite zlt_true by lia. rewrite bits_mone by lia. auto. + rewrite zlt_false by lia. auto. + assert (two_p uy > 0) by (apply two_p_gt_ZERO; lia). unfold max_unsigned; lia. - replace (shru zero (sub iwordsize y)) with zero. rewrite add_zero; auto. bit_solve. destruct (zlt (i + unsigned (sub iwordsize y)) zwordsize); auto. @@ -2434,23 +2435,23 @@ Proof. set (uy := unsigned y). assert (0 <= uy < zwordsize - 1). generalize (ltu_inv _ _ H). rewrite unsigned_repr. auto. - generalize wordsize_pos wordsize_max_unsigned; omega. + generalize wordsize_pos wordsize_max_unsigned; lia. assert (shl one y = repr (two_p uy)). rewrite shl_mul_two_p. rewrite mul_commut. apply mul_one. assert (and x (sub (shl one y) one) = modu x (repr (two_p uy))). symmetry. rewrite H1. apply modu_and with (logn := y). rewrite is_power2_two_p. unfold uy. rewrite repr_unsigned. auto. - omega. + lia. rewrite H2. rewrite H1. repeat rewrite shr_div_two_p. fold sx. fold uy. - assert (two_p uy > 0). apply two_p_gt_ZERO. omega. + assert (two_p uy > 0). apply two_p_gt_ZERO. lia. assert (two_p uy < modulus). - rewrite modulus_power. apply two_p_monotone_strict. omega. + rewrite modulus_power. apply two_p_monotone_strict. lia. assert (two_p uy < half_modulus). rewrite half_modulus_power. apply two_p_monotone_strict. auto. assert (two_p uy < modulus). - rewrite modulus_power. apply two_p_monotone_strict. omega. + rewrite modulus_power. apply two_p_monotone_strict. lia. assert (sub (repr (two_p uy)) one = repr (two_p uy - 1)). unfold sub. apply eqm_samerepr. apply eqm_sub. apply eqm_sym; apply eqm_unsigned_repr. rewrite unsigned_one. apply eqm_refl. @@ -2463,17 +2464,17 @@ Proof. fold eqm. unfold sx. apply eqm_sym. apply eqm_signed_unsigned. unfold modulus. rewrite two_power_nat_two_p. exists (two_p (zwordsize - uy)). rewrite <- two_p_is_exp. - f_equal. fold zwordsize; omega. omega. omega. + f_equal. fold zwordsize; lia. lia. lia. rewrite H8. rewrite Zdiv_shift; auto. unfold add. apply eqm_samerepr. apply eqm_add. apply eqm_unsigned_repr. destruct (zeq (sx mod two_p uy) 0); simpl. rewrite unsigned_zero. apply eqm_refl. rewrite unsigned_one. apply eqm_refl. - generalize (Z_mod_lt (unsigned x) (two_p uy) H3). unfold max_unsigned. omega. - unfold max_unsigned; omega. - generalize (signed_range x). fold sx. intros. split. omega. unfold max_signed. omega. - generalize min_signed_neg. unfold max_signed. omega. + generalize (Z_mod_lt (unsigned x) (two_p uy) H3). unfold max_unsigned. lia. + unfold max_unsigned; lia. + generalize (signed_range x). fold sx. intros. split. lia. unfold max_signed. lia. + generalize min_signed_neg. unfold max_signed. lia. Qed. (** Connections between [shr] and [shru]. *) @@ -2492,14 +2493,14 @@ Lemma and_positive: forall x y, signed y >= 0 -> signed (and x y) >= 0. Proof. intros. - assert (unsigned y < half_modulus). rewrite signed_positive in H. unfold max_signed in H; omega. + assert (unsigned y < half_modulus). rewrite signed_positive in H. unfold max_signed in H; lia. generalize (sign_bit_of_unsigned y). rewrite zlt_true; auto. intros A. generalize (sign_bit_of_unsigned (and x y)). rewrite bits_and. rewrite A. rewrite andb_false_r. unfold signed. destruct (zlt (unsigned (and x y)) half_modulus). - intros. generalize (unsigned_range (and x y)); omega. + intros. generalize (unsigned_range (and x y)); lia. congruence. - generalize wordsize_pos; omega. + generalize wordsize_pos; lia. Qed. Theorem shr_and_is_shru_and: @@ -2526,7 +2527,7 @@ Lemma bits_sign_ext: testbit (sign_ext n x) i = testbit x (if zlt i n then i else n - 1). Proof. intros. unfold sign_ext. - rewrite testbit_repr; auto. apply Zsign_ext_spec. omega. + rewrite testbit_repr; auto. apply Zsign_ext_spec. lia. Qed. Hint Rewrite bits_zero_ext bits_sign_ext: ints. @@ -2535,13 +2536,13 @@ Theorem zero_ext_above: forall n x, n >= zwordsize -> zero_ext n x = x. Proof. intros. apply same_bits_eq; intros. - rewrite bits_zero_ext. apply zlt_true. omega. omega. + rewrite bits_zero_ext. apply zlt_true. lia. lia. Qed. Theorem zero_ext_below: forall n x, n <= 0 -> zero_ext n x = zero. Proof. - intros. bit_solve. destruct (zlt i n); auto. apply bits_below; omega. omega. + intros. bit_solve. destruct (zlt i n); auto. apply bits_below; lia. lia. Qed. Theorem sign_ext_above: @@ -2549,13 +2550,13 @@ Theorem sign_ext_above: Proof. intros. apply same_bits_eq; intros. unfold sign_ext; rewrite testbit_repr; auto. - rewrite Zsign_ext_spec. rewrite zlt_true. auto. omega. omega. + rewrite Zsign_ext_spec. rewrite zlt_true. auto. lia. lia. Qed. Theorem sign_ext_below: forall n x, n <= 0 -> sign_ext n x = zero. Proof. - intros. bit_solve. apply bits_below. destruct (zlt i n); omega. + intros. bit_solve. apply bits_below. destruct (zlt i n); lia. Qed. Theorem zero_ext_and: @@ -2577,8 +2578,8 @@ Proof. fold (testbit (zero_ext n x) i). destruct (zlt i zwordsize). rewrite bits_zero_ext; auto. - rewrite bits_above. rewrite zlt_false; auto. omega. omega. - omega. + rewrite bits_above. rewrite zlt_false; auto. lia. lia. + lia. Qed. Theorem zero_ext_widen: @@ -2586,7 +2587,7 @@ Theorem zero_ext_widen: zero_ext n' (zero_ext n x) = zero_ext n x. Proof. bit_solve. destruct (zlt i n). - apply zlt_true. omega. + apply zlt_true. lia. destruct (zlt i n'); auto. tauto. tauto. Qed. @@ -2599,9 +2600,9 @@ Proof. bit_solve. destruct (zlt i n'). auto. rewrite (zlt_false _ i n). - destruct (zlt (n' - 1) n); f_equal; omega. - omega. - destruct (zlt i n'); omega. + destruct (zlt (n' - 1) n); f_equal; lia. + lia. + destruct (zlt i n'); lia. apply sign_ext_above; auto. Qed. @@ -2613,8 +2614,8 @@ Proof. bit_solve. destruct (zlt i n'). auto. - rewrite !zlt_false. auto. omega. omega. omega. - destruct (zlt i n'); omega. + rewrite !zlt_false. auto. lia. lia. lia. + destruct (zlt i n'); lia. apply sign_ext_above; auto. Qed. @@ -2623,9 +2624,9 @@ Theorem zero_ext_narrow: zero_ext n (zero_ext n' x) = zero_ext n x. Proof. bit_solve. destruct (zlt i n). - apply zlt_true. omega. + apply zlt_true. lia. auto. - omega. omega. omega. + lia. lia. lia. Qed. Theorem sign_ext_narrow: @@ -2633,9 +2634,9 @@ Theorem sign_ext_narrow: sign_ext n (sign_ext n' x) = sign_ext n x. Proof. intros. destruct (zlt n zwordsize). - bit_solve. destruct (zlt i n); f_equal; apply zlt_true; omega. - destruct (zlt i n); omega. - rewrite (sign_ext_above n'). auto. omega. + bit_solve. destruct (zlt i n); f_equal; apply zlt_true; lia. + destruct (zlt i n); lia. + rewrite (sign_ext_above n'). auto. lia. Qed. Theorem zero_sign_ext_narrow: @@ -2645,21 +2646,21 @@ Proof. intros. destruct (zlt n' zwordsize). bit_solve. destruct (zlt i n); auto. - rewrite zlt_true; auto. omega. - omega. omega. + rewrite zlt_true; auto. lia. + lia. lia. rewrite sign_ext_above; auto. Qed. Theorem zero_ext_idem: forall n x, 0 <= n -> zero_ext n (zero_ext n x) = zero_ext n x. Proof. - intros. apply zero_ext_widen. omega. + intros. apply zero_ext_widen. lia. Qed. Theorem sign_ext_idem: forall n x, 0 < n -> sign_ext n (sign_ext n x) = sign_ext n x. Proof. - intros. apply sign_ext_widen. omega. + intros. apply sign_ext_widen. lia. Qed. Theorem sign_ext_zero_ext: @@ -2669,15 +2670,15 @@ Proof. bit_solve. destruct (zlt i n). rewrite zlt_true; auto. - rewrite zlt_true; auto. omega. - destruct (zlt i n); omega. + rewrite zlt_true; auto. lia. + destruct (zlt i n); lia. rewrite zero_ext_above; auto. Qed. Theorem zero_ext_sign_ext: forall n x, 0 < n -> zero_ext n (sign_ext n x) = zero_ext n x. Proof. - intros. apply zero_sign_ext_narrow. omega. + intros. apply zero_sign_ext_narrow. lia. Qed. Theorem sign_ext_equal_if_zero_equal: @@ -2700,21 +2701,21 @@ Proof. apply same_bits_eq; intros. rewrite bits_shru by auto. fold Z. destruct (zlt Z Y). - assert (A: unsigned (sub y z) = Y - Z). - { apply unsigned_repr. generalize wordsize_max_unsigned; omega. } - symmetry; rewrite bits_shl, A by omega. + { apply unsigned_repr. generalize wordsize_max_unsigned; lia. } + symmetry; rewrite bits_shl, A by lia. destruct (zlt (i + Z) zwordsize). -+ rewrite bits_shl by omega. fold Y. - destruct (zlt i (Y - Z)); [rewrite zlt_true by omega|rewrite zlt_false by omega]; auto. - rewrite bits_zero_ext by omega. rewrite zlt_true by omega. f_equal; omega. -+ rewrite bits_zero_ext by omega. rewrite ! zlt_false by omega. auto. ++ rewrite bits_shl by lia. fold Y. + destruct (zlt i (Y - Z)); [rewrite zlt_true by lia|rewrite zlt_false by lia]; auto. + rewrite bits_zero_ext by lia. rewrite zlt_true by lia. f_equal; lia. ++ rewrite bits_zero_ext by lia. rewrite ! zlt_false by lia. auto. - assert (A: unsigned (sub z y) = Z - Y). - { apply unsigned_repr. generalize wordsize_max_unsigned; omega. } - rewrite bits_zero_ext, bits_shru, A by omega. - destruct (zlt (i + Z) zwordsize); [rewrite zlt_true by omega|rewrite zlt_false by omega]; auto. - rewrite bits_shl by omega. fold Y. + { apply unsigned_repr. generalize wordsize_max_unsigned; lia. } + rewrite bits_zero_ext, bits_shru, A by lia. + destruct (zlt (i + Z) zwordsize); [rewrite zlt_true by lia|rewrite zlt_false by lia]; auto. + rewrite bits_shl by lia. fold Y. destruct (zlt (i + Z) Y). -+ rewrite zlt_false by omega. auto. -+ rewrite zlt_true by omega. f_equal; omega. ++ rewrite zlt_false by lia. auto. ++ rewrite zlt_true by lia. f_equal; lia. Qed. Corollary zero_ext_shru_shl: @@ -2725,11 +2726,11 @@ Corollary zero_ext_shru_shl: Proof. intros. assert (A: unsigned y = zwordsize - n). - { unfold y. apply unsigned_repr. generalize wordsize_max_unsigned. omega. } + { unfold y. apply unsigned_repr. generalize wordsize_max_unsigned. lia. } assert (B: ltu y iwordsize = true). - { unfold ltu; rewrite A, unsigned_repr_wordsize. apply zlt_true; omega. } - rewrite shru_shl by auto. unfold ltu; rewrite zlt_false by omega. - rewrite sub_idem, shru_zero. f_equal. rewrite A; omega. + { unfold ltu; rewrite A, unsigned_repr_wordsize. apply zlt_true; lia. } + rewrite shru_shl by auto. unfold ltu; rewrite zlt_false by lia. + rewrite sub_idem, shru_zero. f_equal. rewrite A; lia. Qed. Theorem shr_shl: @@ -2741,41 +2742,41 @@ Proof. intros. apply ltu_iwordsize_inv in H; apply ltu_iwordsize_inv in H0. unfold ltu. set (Y := unsigned y) in *; set (Z := unsigned z) in *. apply same_bits_eq; intros. rewrite bits_shr by auto. fold Z. - rewrite bits_shl by (destruct (zlt (i + Z) zwordsize); omega). fold Y. + rewrite bits_shl by (destruct (zlt (i + Z) zwordsize); lia). fold Y. destruct (zlt Z Y). - assert (A: unsigned (sub y z) = Y - Z). - { apply unsigned_repr. generalize wordsize_max_unsigned; omega. } - rewrite bits_shl, A by omega. + { apply unsigned_repr. generalize wordsize_max_unsigned; lia. } + rewrite bits_shl, A by lia. destruct (zlt i (Y - Z)). -+ apply zlt_true. destruct (zlt (i + Z) zwordsize); omega. -+ rewrite zlt_false by (destruct (zlt (i + Z) zwordsize); omega). - rewrite bits_sign_ext by omega. f_equal. ++ apply zlt_true. destruct (zlt (i + Z) zwordsize); lia. ++ rewrite zlt_false by (destruct (zlt (i + Z) zwordsize); lia). + rewrite bits_sign_ext by lia. f_equal. destruct (zlt (i + Z) zwordsize). - rewrite zlt_true by omega. omega. - rewrite zlt_false by omega. omega. + rewrite zlt_true by lia. lia. + rewrite zlt_false by lia. lia. - assert (A: unsigned (sub z y) = Z - Y). - { apply unsigned_repr. generalize wordsize_max_unsigned; omega. } - rewrite bits_sign_ext by omega. - rewrite bits_shr by (destruct (zlt i (zwordsize - Z)); omega). - rewrite A. rewrite zlt_false by (destruct (zlt (i + Z) zwordsize); omega). + { apply unsigned_repr. generalize wordsize_max_unsigned; lia. } + rewrite bits_sign_ext by lia. + rewrite bits_shr by (destruct (zlt i (zwordsize - Z)); lia). + rewrite A. rewrite zlt_false by (destruct (zlt (i + Z) zwordsize); lia). f_equal. destruct (zlt i (zwordsize - Z)). -+ rewrite ! zlt_true by omega. omega. -+ rewrite ! zlt_false by omega. rewrite zlt_true by omega. omega. ++ rewrite ! zlt_true by lia. lia. ++ rewrite ! zlt_false by lia. rewrite zlt_true by lia. lia. Qed. Corollary sign_ext_shr_shl: forall n x, - 0 < n < zwordsize -> + 0 < n <= zwordsize -> let y := repr (zwordsize - n) in sign_ext n x = shr (shl x y) y. Proof. intros. assert (A: unsigned y = zwordsize - n). - { unfold y. apply unsigned_repr. generalize wordsize_max_unsigned. omega. } + { unfold y. apply unsigned_repr. generalize wordsize_max_unsigned. lia. } assert (B: ltu y iwordsize = true). - { unfold ltu; rewrite A, unsigned_repr_wordsize. apply zlt_true; omega. } - rewrite shr_shl by auto. unfold ltu; rewrite zlt_false by omega. - rewrite sub_idem, shr_zero. f_equal. rewrite A; omega. + { unfold ltu; rewrite A, unsigned_repr_wordsize. apply zlt_true; lia. } + rewrite shr_shl by auto. unfold ltu; rewrite zlt_false by lia. + rewrite sub_idem, shr_zero. f_equal. rewrite A; lia. Qed. (** [zero_ext n x] is the unique integer congruent to [x] modulo [2^n] @@ -2784,14 +2785,14 @@ Qed. Lemma zero_ext_range: forall n x, 0 <= n < zwordsize -> 0 <= unsigned (zero_ext n x) < two_p n. Proof. - intros. rewrite zero_ext_mod; auto. apply Z_mod_lt. apply two_p_gt_ZERO. omega. + intros. rewrite zero_ext_mod; auto. apply Z_mod_lt. apply two_p_gt_ZERO. lia. Qed. Lemma eqmod_zero_ext: forall n x, 0 <= n < zwordsize -> eqmod (two_p n) (unsigned (zero_ext n x)) (unsigned x). Proof. intros. rewrite zero_ext_mod; auto. apply eqmod_sym. apply eqmod_mod. - apply two_p_gt_ZERO. omega. + apply two_p_gt_ZERO. lia. Qed. (** [sign_ext n x] is the unique integer congruent to [x] modulo [2^n] @@ -2800,28 +2801,28 @@ Qed. Lemma sign_ext_range: forall n x, 0 < n < zwordsize -> -two_p (n-1) <= signed (sign_ext n x) < two_p (n-1). Proof. - intros. rewrite sign_ext_shr_shl; auto. + intros. rewrite sign_ext_shr_shl by lia. set (X := shl x (repr (zwordsize - n))). - assert (two_p (n - 1) > 0) by (apply two_p_gt_ZERO; omega). + assert (two_p (n - 1) > 0) by (apply two_p_gt_ZERO; lia). assert (unsigned (repr (zwordsize - n)) = zwordsize - n). apply unsigned_repr. - split. omega. generalize wordsize_max_unsigned; omega. + split. lia. generalize wordsize_max_unsigned; lia. rewrite shr_div_two_p. rewrite signed_repr. rewrite H1. apply Zdiv_interval_1. - omega. omega. apply two_p_gt_ZERO; omega. + lia. lia. apply two_p_gt_ZERO; lia. replace (- two_p (n - 1) * two_p (zwordsize - n)) with (- (two_p (n - 1) * two_p (zwordsize - n))) by ring. rewrite <- two_p_is_exp. - replace (n - 1 + (zwordsize - n)) with (zwordsize - 1) by omega. + replace (n - 1 + (zwordsize - n)) with (zwordsize - 1) by lia. rewrite <- half_modulus_power. - generalize (signed_range X). unfold min_signed, max_signed. omega. - omega. omega. + generalize (signed_range X). unfold min_signed, max_signed. lia. + lia. lia. apply Zdiv_interval_2. apply signed_range. - generalize min_signed_neg; omega. - generalize max_signed_pos; omega. - rewrite H1. apply two_p_gt_ZERO. omega. + generalize min_signed_neg; lia. + generalize max_signed_pos; lia. + rewrite H1. apply two_p_gt_ZERO. lia. Qed. Lemma eqmod_sign_ext': @@ -2830,12 +2831,12 @@ Lemma eqmod_sign_ext': Proof. intros. set (N := Z.to_nat n). - assert (Z.of_nat N = n) by (apply Z2Nat.id; omega). + assert (Z.of_nat N = n) by (apply Z2Nat.id; lia). rewrite <- H0. rewrite <- two_power_nat_two_p. apply eqmod_same_bits; intros. rewrite H0 in H1. rewrite H0. fold (testbit (sign_ext n x) i). rewrite bits_sign_ext. - rewrite zlt_true. auto. omega. omega. + rewrite zlt_true. auto. lia. lia. Qed. Lemma eqmod_sign_ext: @@ -2846,7 +2847,7 @@ Proof. apply eqmod_divides with modulus. apply eqm_signed_unsigned. exists (two_p (zwordsize - n)). unfold modulus. rewrite two_power_nat_two_p. fold zwordsize. - rewrite <- two_p_is_exp. f_equal. omega. omega. omega. + rewrite <- two_p_is_exp. f_equal. lia. lia. lia. apply eqmod_sign_ext'; auto. Qed. @@ -2857,11 +2858,11 @@ Lemma shl_zero_ext: shl (zero_ext n x) m = zero_ext (n + unsigned m) (shl x m). Proof. intros. apply same_bits_eq; intros. - rewrite bits_zero_ext, ! bits_shl by omega. + rewrite bits_zero_ext, ! bits_shl by lia. destruct (zlt i (unsigned m)). -- rewrite zlt_true by omega; auto. -- rewrite bits_zero_ext by omega. - destruct (zlt (i - unsigned m) n); [rewrite zlt_true by omega|rewrite zlt_false by omega]; auto. +- rewrite zlt_true by lia; auto. +- rewrite bits_zero_ext by lia. + destruct (zlt (i - unsigned m) n); [rewrite zlt_true by lia|rewrite zlt_false by lia]; auto. Qed. Lemma shl_sign_ext: @@ -2870,12 +2871,12 @@ Lemma shl_sign_ext: Proof. intros. generalize (unsigned_range m); intros. apply same_bits_eq; intros. - rewrite bits_sign_ext, ! bits_shl by omega. + rewrite bits_sign_ext, ! bits_shl by lia. destruct (zlt i (n + unsigned m)). - rewrite bits_shl by auto. destruct (zlt i (unsigned m)); auto. - rewrite bits_sign_ext by omega. f_equal. apply zlt_true. omega. -- rewrite zlt_false by omega. rewrite bits_shl by omega. rewrite zlt_false by omega. - rewrite bits_sign_ext by omega. f_equal. rewrite zlt_false by omega. omega. + rewrite bits_sign_ext by lia. f_equal. apply zlt_true. lia. +- rewrite zlt_false by lia. rewrite bits_shl by lia. rewrite zlt_false by lia. + rewrite bits_sign_ext by lia. f_equal. rewrite zlt_false by lia. lia. Qed. Lemma shru_zero_ext: @@ -2884,10 +2885,10 @@ Lemma shru_zero_ext: Proof. intros. bit_solve. - destruct (zlt (i + unsigned m) zwordsize). -* destruct (zlt i n); [rewrite zlt_true by omega|rewrite zlt_false by omega]; auto. +* destruct (zlt i n); [rewrite zlt_true by lia|rewrite zlt_false by lia]; auto. * destruct (zlt i n); auto. -- generalize (unsigned_range m); omega. -- omega. +- generalize (unsigned_range m); lia. +- lia. Qed. Lemma shru_zero_ext_0: @@ -2896,8 +2897,8 @@ Lemma shru_zero_ext_0: Proof. intros. bit_solve. - destruct (zlt (i + unsigned m) zwordsize); auto. - apply zlt_false. omega. -- generalize (unsigned_range m); omega. + apply zlt_false. lia. +- generalize (unsigned_range m); lia. Qed. Lemma shr_sign_ext: @@ -2910,12 +2911,12 @@ Proof. rewrite bits_sign_ext, bits_shr. - f_equal. destruct (zlt i n), (zlt (i + unsigned m) zwordsize). -+ apply zlt_true; omega. -+ apply zlt_true; omega. -+ rewrite zlt_false by omega. rewrite zlt_true by omega. omega. -+ rewrite zlt_false by omega. rewrite zlt_true by omega. omega. -- destruct (zlt i n); omega. -- destruct (zlt (i + unsigned m) zwordsize); omega. ++ apply zlt_true; lia. ++ apply zlt_true; lia. ++ rewrite zlt_false by lia. rewrite zlt_true by lia. lia. ++ rewrite zlt_false by lia. rewrite zlt_true by lia. lia. +- destruct (zlt i n); lia. +- destruct (zlt (i + unsigned m) zwordsize); lia. Qed. Lemma zero_ext_shru_min: @@ -2924,10 +2925,10 @@ Lemma zero_ext_shru_min: Proof. intros. apply ltu_iwordsize_inv in H. apply Z.min_case_strong; intros; auto. - bit_solve; try omega. + bit_solve; try lia. destruct (zlt i (zwordsize - unsigned n)). - rewrite zlt_true by omega. auto. - destruct (zlt i s); auto. rewrite zlt_false by omega; auto. + rewrite zlt_true by lia. auto. + destruct (zlt i s); auto. rewrite zlt_false by lia; auto. Qed. Lemma sign_ext_shr_min: @@ -2939,12 +2940,12 @@ Proof. destruct (Z.min_spec (zwordsize - unsigned n) s) as [[A B] | [A B]]; rewrite B; auto. apply same_bits_eq; intros. rewrite ! bits_sign_ext by auto. destruct (zlt i (zwordsize - unsigned n)). - rewrite zlt_true by omega. auto. + rewrite zlt_true by lia. auto. assert (C: testbit (shr x n) (zwordsize - unsigned n - 1) = testbit x (zwordsize - 1)). - { rewrite bits_shr by omega. rewrite zlt_true by omega. f_equal; omega. } - rewrite C. destruct (zlt i s); rewrite bits_shr by omega. - rewrite zlt_false by omega. auto. - rewrite zlt_false by omega. auto. + { rewrite bits_shr by lia. rewrite zlt_true by lia. f_equal; lia. } + rewrite C. destruct (zlt i s); rewrite bits_shr by lia. + rewrite zlt_false by lia. auto. + rewrite zlt_false by lia. auto. Qed. Lemma shl_zero_ext_min: @@ -2955,10 +2956,10 @@ Proof. apply Z.min_case_strong; intros; auto. apply same_bits_eq; intros. rewrite ! bits_shl by auto. destruct (zlt i (unsigned n)); auto. - rewrite ! bits_zero_ext by omega. + rewrite ! bits_zero_ext by lia. destruct (zlt (i - unsigned n) s). - rewrite zlt_true by omega; auto. - rewrite zlt_false by omega; auto. + rewrite zlt_true by lia; auto. + rewrite zlt_false by lia; auto. Qed. Lemma shl_sign_ext_min: @@ -2970,10 +2971,10 @@ Proof. destruct (Z.min_spec (zwordsize - unsigned n) s) as [[A B] | [A B]]; rewrite B; auto. apply same_bits_eq; intros. rewrite ! bits_shl by auto. destruct (zlt i (unsigned n)); auto. - rewrite ! bits_sign_ext by omega. f_equal. + rewrite ! bits_sign_ext by lia. f_equal. destruct (zlt (i - unsigned n) s). - rewrite zlt_true by omega; auto. - omegaContradiction. + rewrite zlt_true by lia; auto. + extlia. Qed. (** ** Properties of [one_bits] (decomposition in sum of powers of two) *) @@ -2984,8 +2985,8 @@ Proof. assert (A: forall p, 0 <= p < zwordsize -> ltu (repr p) iwordsize = true). intros. unfold ltu, iwordsize. apply zlt_true. repeat rewrite unsigned_repr. tauto. - generalize wordsize_max_unsigned; omega. - generalize wordsize_max_unsigned; omega. + generalize wordsize_max_unsigned; lia. + generalize wordsize_max_unsigned; lia. unfold one_bits. intros. destruct (list_in_map_inv _ _ _ H) as [i0 [EQ IN]]. subst i. apply A. apply Z_one_bits_range with (unsigned x); auto. @@ -3015,7 +3016,7 @@ Proof. rewrite mul_one. apply eqm_unsigned_repr_r. rewrite unsigned_repr. auto with ints. generalize (H a (in_eq _ _)). change (Z.of_nat wordsize) with zwordsize. - generalize wordsize_max_unsigned. omega. + generalize wordsize_max_unsigned. lia. auto with ints. intros; apply H; auto with coqlib. Qed. @@ -3059,7 +3060,7 @@ Proof. apply eqm_sub. apply eqm_trans with (unsigned (repr (unsigned x + unsigned d))). eauto with ints. apply eqm_trans with (unsigned (repr (unsigned y + unsigned d))). eauto with ints. eauto with ints. eauto with ints. - omega. omega. + lia. lia. Qed. Lemma translate_ltu: @@ -3070,8 +3071,8 @@ Lemma translate_ltu: Proof. intros. unfold add. unfold ltu. repeat rewrite unsigned_repr; auto. case (zlt (unsigned x) (unsigned y)); intro. - apply zlt_true. omega. - apply zlt_false. omega. + apply zlt_true. lia. + apply zlt_false. lia. Qed. Theorem translate_cmpu: @@ -3092,8 +3093,8 @@ Lemma translate_lt: Proof. intros. repeat rewrite add_signed. unfold lt. repeat rewrite signed_repr; auto. case (zlt (signed x) (signed y)); intro. - apply zlt_true. omega. - apply zlt_false. omega. + apply zlt_true. lia. + apply zlt_false. lia. Qed. Theorem translate_cmp: @@ -3129,7 +3130,7 @@ Proof. intros. unfold ltu in H. destruct (zlt (unsigned x) (unsigned y)); try discriminate. rewrite signed_eq_unsigned. - generalize (unsigned_range x). omega. omega. + generalize (unsigned_range x). lia. lia. Qed. Theorem lt_sub_overflow: @@ -3143,30 +3144,30 @@ Proof. unfold min_signed, max_signed in *. generalize half_modulus_pos half_modulus_modulus; intros HM MM. destruct (zle 0 (X - Y)). -- unfold proj_sumbool at 1; rewrite zle_true at 1 by omega. simpl. - rewrite (zlt_false _ X) by omega. +- unfold proj_sumbool at 1; rewrite zle_true at 1 by lia. simpl. + rewrite (zlt_false _ X) by lia. destruct (zlt (X - Y) half_modulus). - + unfold proj_sumbool; rewrite zle_true by omega. - rewrite signed_repr. rewrite zlt_false by omega. apply xor_idem. - unfold min_signed, max_signed; omega. - + unfold proj_sumbool; rewrite zle_false by omega. + + unfold proj_sumbool; rewrite zle_true by lia. + rewrite signed_repr. rewrite zlt_false by lia. apply xor_idem. + unfold min_signed, max_signed; lia. + + unfold proj_sumbool; rewrite zle_false by lia. replace (signed (repr (X - Y))) with (X - Y - modulus). - rewrite zlt_true by omega. apply xor_idem. + rewrite zlt_true by lia. apply xor_idem. rewrite signed_repr_eq. replace ((X - Y) mod modulus) with (X - Y). rewrite zlt_false; auto. - symmetry. apply Zmod_unique with 0; omega. -- unfold proj_sumbool at 2. rewrite zle_true at 1 by omega. rewrite andb_true_r. - rewrite (zlt_true _ X) by omega. + symmetry. apply Zmod_unique with 0; lia. +- unfold proj_sumbool at 2. rewrite zle_true at 1 by lia. rewrite andb_true_r. + rewrite (zlt_true _ X) by lia. destruct (zlt (X - Y) (-half_modulus)). - + unfold proj_sumbool; rewrite zle_false by omega. + + unfold proj_sumbool; rewrite zle_false by lia. replace (signed (repr (X - Y))) with (X - Y + modulus). - rewrite zlt_false by omega. apply xor_zero. + rewrite zlt_false by lia. apply xor_zero. rewrite signed_repr_eq. replace ((X - Y) mod modulus) with (X - Y + modulus). - rewrite zlt_true by omega; auto. - symmetry. apply Zmod_unique with (-1); omega. - + unfold proj_sumbool; rewrite zle_true by omega. - rewrite signed_repr. rewrite zlt_true by omega. apply xor_zero_l. - unfold min_signed, max_signed; omega. + rewrite zlt_true by lia; auto. + symmetry. apply Zmod_unique with (-1); lia. + + unfold proj_sumbool; rewrite zle_true by lia. + rewrite signed_repr. rewrite zlt_true by lia. apply xor_zero_l. + unfold min_signed, max_signed; lia. Qed. Lemma signed_eq: @@ -3186,10 +3187,10 @@ Lemma not_lt: Proof. intros. unfold lt. rewrite signed_eq. unfold proj_sumbool. destruct (zlt (signed y) (signed x)). - rewrite zlt_false. rewrite zeq_false. auto. omega. omega. + rewrite zlt_false. rewrite zeq_false. auto. lia. lia. destruct (zeq (signed x) (signed y)). - rewrite zlt_false. auto. omega. - rewrite zlt_true. auto. omega. + rewrite zlt_false. auto. lia. + rewrite zlt_true. auto. lia. Qed. Lemma lt_not: @@ -3203,10 +3204,10 @@ Lemma not_ltu: Proof. intros. unfold ltu, eq. destruct (zlt (unsigned y) (unsigned x)). - rewrite zlt_false. rewrite zeq_false. auto. omega. omega. + rewrite zlt_false. rewrite zeq_false. auto. lia. lia. destruct (zeq (unsigned x) (unsigned y)). - rewrite zlt_false. auto. omega. - rewrite zlt_true. auto. omega. + rewrite zlt_false. auto. lia. + rewrite zlt_true. auto. lia. Qed. Lemma ltu_not: @@ -3238,7 +3239,7 @@ Proof. clear H3. generalize (unsigned_range ofs1) (unsigned_range ofs2). intros P Q. generalize (unsigned_add_either base ofs1) (unsigned_add_either base ofs2). - intros [C|C] [D|D]; omega. + intros [C|C] [D|D]; lia. Qed. (** ** Size of integers, in bits. *) @@ -3255,14 +3256,14 @@ Theorem bits_size_1: Proof. intros. destruct (zeq (unsigned x) 0). left. rewrite <- (repr_unsigned x). rewrite e; auto. - right. apply Ztestbit_size_1. generalize (unsigned_range x); omega. + right. apply Ztestbit_size_1. generalize (unsigned_range x); lia. Qed. Theorem bits_size_2: forall x i, size x <= i -> testbit x i = false. Proof. - intros. apply Ztestbit_size_2. generalize (unsigned_range x); omega. - fold (size x); omega. + intros. apply Ztestbit_size_2. generalize (unsigned_range x); lia. + fold (size x); lia. Qed. Theorem size_range: @@ -3270,9 +3271,9 @@ Theorem size_range: Proof. intros; split. apply Zsize_pos. destruct (bits_size_1 x). - subst x; unfold size; rewrite unsigned_zero; simpl. generalize wordsize_pos; omega. + subst x; unfold size; rewrite unsigned_zero; simpl. generalize wordsize_pos; lia. destruct (zle (size x) zwordsize); auto. - rewrite bits_above in H. congruence. omega. + rewrite bits_above in H. congruence. lia. Qed. Theorem bits_size_3: @@ -3285,7 +3286,7 @@ Proof. destruct (bits_size_1 x). subst x. unfold size; rewrite unsigned_zero; assumption. rewrite (H0 (Z.pred (size x))) in H1. congruence. - generalize (size_range x); omega. + generalize (size_range x); lia. Qed. Theorem bits_size_4: @@ -3299,14 +3300,14 @@ Proof. assert (size x <= n). apply bits_size_3; auto. destruct (zlt (size x) n). - rewrite bits_size_2 in H0. congruence. omega. - omega. + rewrite bits_size_2 in H0. congruence. lia. + lia. Qed. Theorem size_interval_1: forall x, 0 <= unsigned x < two_p (size x). Proof. - intros; apply Zsize_interval_1. generalize (unsigned_range x); omega. + intros; apply Zsize_interval_1. generalize (unsigned_range x); lia. Qed. Theorem size_interval_2: @@ -3320,9 +3321,9 @@ Theorem size_and: Proof. intros. assert (0 <= Z.min (size a) (size b)). - generalize (size_range a) (size_range b). zify; omega. + generalize (size_range a) (size_range b). zify; lia. apply bits_size_3. auto. intros. - rewrite bits_and by omega. + rewrite bits_and by lia. rewrite andb_false_iff. generalize (bits_size_2 a i). generalize (bits_size_2 b i). @@ -3335,9 +3336,9 @@ Proof. intros. generalize (size_interval_1 (and a b)); intros. assert (two_p (size (and a b)) <= two_p (Z.min (size a) (size b))). - apply two_p_monotone. split. generalize (size_range (and a b)); omega. + apply two_p_monotone. split. generalize (size_range (and a b)); lia. apply size_and. - omega. + lia. Qed. Theorem size_or: @@ -3345,17 +3346,17 @@ Theorem size_or: Proof. intros. generalize (size_range a) (size_range b); intros. destruct (bits_size_1 a). - subst a. rewrite size_zero. rewrite or_zero_l. zify; omega. + subst a. rewrite size_zero. rewrite or_zero_l. zify; lia. destruct (bits_size_1 b). - subst b. rewrite size_zero. rewrite or_zero. zify; omega. + subst b. rewrite size_zero. rewrite or_zero. zify; lia. zify. destruct H3 as [[P Q] | [P Q]]; subst. apply bits_size_4. tauto. rewrite bits_or. rewrite H2. apply orb_true_r. - omega. - intros. rewrite bits_or. rewrite !bits_size_2. auto. omega. omega. omega. + lia. + intros. rewrite bits_or. rewrite !bits_size_2. auto. lia. lia. lia. apply bits_size_4. tauto. rewrite bits_or. rewrite H1. apply orb_true_l. destruct (zeq (size a) 0). unfold testbit in H1. rewrite Z.testbit_neg_r in H1. - congruence. omega. omega. - intros. rewrite bits_or. rewrite !bits_size_2. auto. omega. omega. omega. + congruence. lia. lia. + intros. rewrite bits_or. rewrite !bits_size_2. auto. lia. lia. lia. Qed. Corollary or_interval: @@ -3369,12 +3370,12 @@ Theorem size_xor: Proof. intros. assert (0 <= Z.max (size a) (size b)). - generalize (size_range a) (size_range b). zify; omega. + generalize (size_range a) (size_range b). zify; lia. apply bits_size_3. auto. intros. rewrite bits_xor. rewrite !bits_size_2. auto. - zify; omega. - zify; omega. - omega. + zify; lia. + zify; lia. + lia. Qed. Corollary xor_interval: @@ -3383,9 +3384,121 @@ Proof. intros. generalize (size_interval_1 (xor a b)); intros. assert (two_p (size (xor a b)) <= two_p (Z.max (size a) (size b))). - apply two_p_monotone. split. generalize (size_range (xor a b)); omega. + apply two_p_monotone. split. generalize (size_range (xor a b)); lia. apply size_xor. - omega. + lia. +Qed. + +(** ** Accessing bit fields *) + +Definition unsigned_bitfield_extract (pos width: Z) (n: int) : int := + zero_ext width (shru n (repr pos)). + +Definition signed_bitfield_extract (pos width: Z) (n: int) : int := + sign_ext width (shru n (repr pos)). + +Definition bitfield_insert (pos width: Z) (n p: int) : int := + let mask := shl (repr (two_p width - 1)) (repr pos) in + or (shl (zero_ext width p) (repr pos)) + (and n (not mask)). + +Lemma bits_unsigned_bitfield_extract: + forall pos width n i, + 0 <= pos -> 0 < width -> pos + width <= zwordsize -> + 0 <= i < zwordsize -> + testbit (unsigned_bitfield_extract pos width n) i = + if zlt i width then testbit n (i + pos) else false. +Proof. + intros. unfold unsigned_bitfield_extract. rewrite bits_zero_ext by lia. + destruct (zlt i width); auto. + rewrite bits_shru by auto. rewrite unsigned_repr, zlt_true. auto. + lia. + generalize wordsize_max_unsigned; lia. +Qed. + +Lemma bits_signed_bitfield_extract: + forall pos width n i, + 0 <= pos -> 0 < width -> pos + width <= zwordsize -> + 0 <= i < zwordsize -> + testbit (signed_bitfield_extract pos width n) i = + testbit n (if zlt i width then i + pos else width - 1 + pos). +Proof. + intros. unfold signed_bitfield_extract. rewrite bits_sign_ext by lia. + rewrite bits_shru, unsigned_repr, zlt_true. + destruct (zlt i width); auto. + destruct (zlt i width); lia. + generalize wordsize_max_unsigned; lia. + destruct (zlt i width); lia. +Qed. + +Lemma bits_bitfield_insert: + forall pos width n p i, + 0 <= pos -> 0 < width -> pos + width <= zwordsize -> + 0 <= i < zwordsize -> + testbit (bitfield_insert pos width n p) i = + if zle pos i && zlt i (pos + width) then testbit p (i - pos) else testbit n i. +Proof. + intros. unfold bitfield_insert. + assert (P: unsigned (repr pos) = pos). + { apply unsigned_repr. generalize wordsize_max_unsigned; lia. } + rewrite bits_or, bits_and, bits_not, ! bits_shl, ! P by auto. + destruct (zlt i pos). +- unfold proj_sumbool; rewrite zle_false by lia. cbn. apply andb_true_r. +- unfold proj_sumbool; rewrite zle_true by lia; cbn. + rewrite bits_zero_ext, testbit_repr, Ztestbit_two_p_m1 by lia. + destruct (zlt (i - pos) width); cbn. ++ rewrite zlt_true by lia. rewrite andb_false_r, orb_false_r. auto. ++ rewrite zlt_false by lia. apply andb_true_r. +Qed. + +Lemma unsigned_bitfield_extract_by_shifts: + forall pos width n, + 0 <= pos -> 0 < width -> pos + width <= zwordsize -> + unsigned_bitfield_extract pos width n = + shru (shl n (repr (zwordsize - pos - width))) (repr (zwordsize - width)). +Proof. + intros. apply same_bits_eq; intros. + rewrite bits_unsigned_bitfield_extract by lia. + rewrite bits_shru by auto. + rewrite unsigned_repr by (generalize wordsize_max_unsigned; lia). + destruct (zlt i width). +- rewrite bits_shl by lia. + rewrite unsigned_repr by (generalize wordsize_max_unsigned; lia). + rewrite zlt_true by lia. rewrite zlt_false by lia. f_equal; lia. +- rewrite zlt_false by lia. auto. +Qed. + +Lemma signed_bitfield_extract_by_shifts: + forall pos width n, + 0 <= pos -> 0 < width -> pos + width <= zwordsize -> + signed_bitfield_extract pos width n = + shr (shl n (repr (zwordsize - pos - width))) (repr (zwordsize - width)). +Proof. + intros. apply same_bits_eq; intros. + rewrite bits_signed_bitfield_extract by lia. + rewrite bits_shr by auto. + rewrite unsigned_repr by (generalize wordsize_max_unsigned; lia). + rewrite bits_shl. + rewrite unsigned_repr by (generalize wordsize_max_unsigned; lia). + symmetry. rewrite zlt_false. f_equal. + destruct (zlt i width); [rewrite zlt_true | rewrite zlt_false]; lia. + destruct zlt; lia. + destruct zlt; lia. +Qed. + +Lemma bitfield_insert_alternative: + forall pos width n p, + 0 <= width -> + bitfield_insert pos width n p = + let mask := shl (repr (two_p width - 1)) (repr pos) in + or (and (shl p (repr pos)) mask) + (and n (not mask)). +Proof. + intros. unfold bitfield_insert. + set (m1 := repr (two_p width - 1)). + set (m2 := shl m1 (repr pos)). + f_equal. + rewrite zero_ext_and by lia. fold m1. unfold m2. rewrite <- and_shl. auto. Qed. End Make. @@ -3465,7 +3578,7 @@ Proof. intros. unfold shl'. rewrite testbit_repr; auto. destruct (zlt i (Int.unsigned y)). apply Z.shiftl_spec_low. auto. - apply Z.shiftl_spec_high. omega. omega. + apply Z.shiftl_spec_high. lia. lia. Qed. Lemma bits_shru': @@ -3479,7 +3592,7 @@ Proof. destruct (zlt (i + Int.unsigned y) zwordsize). auto. apply bits_above; auto. - omega. + lia. Qed. Lemma bits_shr': @@ -3490,8 +3603,8 @@ Lemma bits_shr': Proof. intros. unfold shr'. rewrite testbit_repr; auto. rewrite Z.shiftr_spec. apply bits_signed. - generalize (Int.unsigned_range y); omega. - omega. + generalize (Int.unsigned_range y); lia. + lia. Qed. Lemma shl'_mul_two_p: @@ -3500,7 +3613,7 @@ Lemma shl'_mul_two_p: Proof. intros. unfold shl', mul. apply eqm_samerepr. rewrite Zshiftl_mul_two_p. apply eqm_mult. apply eqm_refl. apply eqm_unsigned_repr. - generalize (Int.unsigned_range y); omega. + generalize (Int.unsigned_range y); lia. Qed. Lemma shl'_one_two_p: @@ -3551,7 +3664,7 @@ Proof. intros. apply Int.ltu_inv in H. change (Int.unsigned (Int.repr 63)) with 63 in H. set (y1 := Int64.repr (Int.unsigned y)). assert (U: unsigned y1 = Int.unsigned y). - { apply unsigned_repr. assert (63 < max_unsigned) by reflexivity. omega. } + { apply unsigned_repr. assert (63 < max_unsigned) by reflexivity. lia. } transitivity (shrx x y1). - unfold shrx', shrx, shl', shl. rewrite U; auto. - rewrite shrx_carry. @@ -3572,20 +3685,20 @@ Proof. assert (N1: 63 < max_unsigned) by reflexivity. assert (N2: 63 < Int.max_unsigned) by reflexivity. assert (A: unsigned z = Int.unsigned y). - { unfold z; apply unsigned_repr; omega. } + { unfold z; apply unsigned_repr; lia. } assert (B: unsigned (sub (repr 64) z) = Int.unsigned (Int.sub (Int.repr 64) y)). { unfold z. unfold sub, Int.sub. change (unsigned (repr 64)) with 64. change (Int.unsigned (Int.repr 64)) with 64. - rewrite (unsigned_repr (Int.unsigned y)) by omega. - rewrite unsigned_repr, Int.unsigned_repr by omega. + rewrite (unsigned_repr (Int.unsigned y)) by lia. + rewrite unsigned_repr, Int.unsigned_repr by lia. auto. } unfold shrx', shr', shru', shl'. rewrite <- A. change (Int.unsigned (Int.repr 63)) with (unsigned (repr 63)). rewrite <- B. apply shrx_shr_2. - unfold ltu. apply zlt_true. change (unsigned z < 63). rewrite A; omega. + unfold ltu. apply zlt_true. change (unsigned z < 63). rewrite A; lia. Qed. Remark int_ltu_2_inv: @@ -3606,11 +3719,11 @@ Proof. change (Int.unsigned iwordsize') with 64 in *. assert (128 < max_unsigned) by reflexivity. assert (128 < Int.max_unsigned) by reflexivity. - assert (Y: unsigned y' = Int.unsigned y) by (apply unsigned_repr; omega). - assert (Z: unsigned z' = Int.unsigned z) by (apply unsigned_repr; omega). + assert (Y: unsigned y' = Int.unsigned y) by (apply unsigned_repr; lia). + assert (Z: unsigned z' = Int.unsigned z) by (apply unsigned_repr; lia). assert (P: Int.unsigned (Int.add y z) = unsigned (add y' z')). - { unfold Int.add. rewrite Int.unsigned_repr by omega. - unfold add. rewrite unsigned_repr by omega. congruence. } + { unfold Int.add. rewrite Int.unsigned_repr by lia. + unfold add. rewrite unsigned_repr by lia. congruence. } intuition auto. apply zlt_true. rewrite Y; auto. apply zlt_true. rewrite Z; auto. @@ -3624,7 +3737,7 @@ Theorem or_ror': Int.add y z = iwordsize' -> ror x (repr (Int.unsigned z)) = or (shl' x y) (shru' x z). Proof. - intros. destruct (int_ltu_2_inv y z) as (A & B & C & D & E & F); auto. rewrite H1; omega. + intros. destruct (int_ltu_2_inv y z) as (A & B & C & D & E & F); auto. rewrite H1; lia. replace (shl' x y) with (shl x (repr (Int.unsigned y))). replace (shru' x z) with (shru x (repr (Int.unsigned z))). apply or_ror; auto. rewrite F, H1. reflexivity. @@ -3640,7 +3753,7 @@ Theorem shl'_shl': shl' (shl' x y) z = shl' x (Int.add y z). Proof. intros. apply Int.ltu_inv in H1. - destruct (int_ltu_2_inv y z) as (A & B & C & D & E & F); auto. omega. + destruct (int_ltu_2_inv y z) as (A & B & C & D & E & F); auto. lia. set (y' := repr (Int.unsigned y)) in *. set (z' := repr (Int.unsigned z)) in *. replace (shl' x y) with (shl x y'). @@ -3661,7 +3774,7 @@ Theorem shru'_shru': shru' (shru' x y) z = shru' x (Int.add y z). Proof. intros. apply Int.ltu_inv in H1. - destruct (int_ltu_2_inv y z) as (A & B & C & D & E & F); auto. omega. + destruct (int_ltu_2_inv y z) as (A & B & C & D & E & F); auto. lia. set (y' := repr (Int.unsigned y)) in *. set (z' := repr (Int.unsigned z)) in *. replace (shru' x y) with (shru x y'). @@ -3682,7 +3795,7 @@ Theorem shr'_shr': shr' (shr' x y) z = shr' x (Int.add y z). Proof. intros. apply Int.ltu_inv in H1. - destruct (int_ltu_2_inv y z) as (A & B & C & D & E & F); auto. omega. + destruct (int_ltu_2_inv y z) as (A & B & C & D & E & F); auto. lia. set (y' := repr (Int.unsigned y)) in *. set (z' := repr (Int.unsigned z)) in *. replace (shr' x y) with (shr x y'). @@ -3707,21 +3820,21 @@ Proof. apply same_bits_eq; intros. rewrite bits_shru' by auto. fold Z. destruct (zlt Z Y). - assert (A: Int.unsigned (Int.sub y z) = Y - Z). - { apply Int.unsigned_repr. assert (zwordsize < Int.max_unsigned) by reflexivity. omega. } - symmetry; rewrite bits_shl', A by omega. + { apply Int.unsigned_repr. assert (zwordsize < Int.max_unsigned) by reflexivity. lia. } + symmetry; rewrite bits_shl', A by lia. destruct (zlt (i + Z) zwordsize). -+ rewrite bits_shl' by omega. fold Y. - destruct (zlt i (Y - Z)); [rewrite zlt_true by omega|rewrite zlt_false by omega]; auto. - rewrite bits_zero_ext by omega. rewrite zlt_true by omega. f_equal; omega. -+ rewrite bits_zero_ext by omega. rewrite ! zlt_false by omega. auto. ++ rewrite bits_shl' by lia. fold Y. + destruct (zlt i (Y - Z)); [rewrite zlt_true by lia|rewrite zlt_false by lia]; auto. + rewrite bits_zero_ext by lia. rewrite zlt_true by lia. f_equal; lia. ++ rewrite bits_zero_ext by lia. rewrite ! zlt_false by lia. auto. - assert (A: Int.unsigned (Int.sub z y) = Z - Y). - { apply Int.unsigned_repr. assert (zwordsize < Int.max_unsigned) by reflexivity. omega. } - rewrite bits_zero_ext, bits_shru', A by omega. - destruct (zlt (i + Z) zwordsize); [rewrite zlt_true by omega|rewrite zlt_false by omega]; auto. - rewrite bits_shl' by omega. fold Y. + { apply Int.unsigned_repr. assert (zwordsize < Int.max_unsigned) by reflexivity. lia. } + rewrite bits_zero_ext, bits_shru', A by lia. + destruct (zlt (i + Z) zwordsize); [rewrite zlt_true by lia|rewrite zlt_false by lia]; auto. + rewrite bits_shl' by lia. fold Y. destruct (zlt (i + Z) Y). -+ rewrite zlt_false by omega. auto. -+ rewrite zlt_true by omega. f_equal; omega. ++ rewrite zlt_false by lia. auto. ++ rewrite zlt_true by lia. f_equal; lia. Qed. Theorem shr'_shl': @@ -3734,26 +3847,26 @@ Proof. change (Int.unsigned iwordsize') with zwordsize in *. unfold Int.ltu. set (Y := Int.unsigned y) in *; set (Z := Int.unsigned z) in *. apply same_bits_eq; intros. rewrite bits_shr' by auto. fold Z. - rewrite bits_shl' by (destruct (zlt (i + Z) zwordsize); omega). fold Y. + rewrite bits_shl' by (destruct (zlt (i + Z) zwordsize); lia). fold Y. destruct (zlt Z Y). - assert (A: Int.unsigned (Int.sub y z) = Y - Z). - { apply Int.unsigned_repr. assert (zwordsize < Int.max_unsigned) by reflexivity. omega. } - rewrite bits_shl', A by omega. + { apply Int.unsigned_repr. assert (zwordsize < Int.max_unsigned) by reflexivity. lia. } + rewrite bits_shl', A by lia. destruct (zlt i (Y - Z)). -+ apply zlt_true. destruct (zlt (i + Z) zwordsize); omega. -+ rewrite zlt_false by (destruct (zlt (i + Z) zwordsize); omega). - rewrite bits_sign_ext by omega. f_equal. ++ apply zlt_true. destruct (zlt (i + Z) zwordsize); lia. ++ rewrite zlt_false by (destruct (zlt (i + Z) zwordsize); lia). + rewrite bits_sign_ext by lia. f_equal. destruct (zlt (i + Z) zwordsize). - rewrite zlt_true by omega. omega. - rewrite zlt_false by omega. omega. + rewrite zlt_true by lia. lia. + rewrite zlt_false by lia. lia. - assert (A: Int.unsigned (Int.sub z y) = Z - Y). - { apply Int.unsigned_repr. assert (zwordsize < Int.max_unsigned) by reflexivity. omega. } - rewrite bits_sign_ext by omega. - rewrite bits_shr' by (destruct (zlt i (zwordsize - Z)); omega). - rewrite A. rewrite zlt_false by (destruct (zlt (i + Z) zwordsize); omega). + { apply Int.unsigned_repr. assert (zwordsize < Int.max_unsigned) by reflexivity. lia. } + rewrite bits_sign_ext by lia. + rewrite bits_shr' by (destruct (zlt i (zwordsize - Z)); lia). + rewrite A. rewrite zlt_false by (destruct (zlt (i + Z) zwordsize); lia). f_equal. destruct (zlt i (zwordsize - Z)). -+ rewrite ! zlt_true by omega. omega. -+ rewrite ! zlt_false by omega. rewrite zlt_true by omega. omega. ++ rewrite ! zlt_true by lia. lia. ++ rewrite ! zlt_false by lia. rewrite zlt_true by lia. lia. Qed. Lemma shl'_zero_ext: @@ -3761,11 +3874,11 @@ Lemma shl'_zero_ext: shl' (zero_ext n x) m = zero_ext (n + Int.unsigned m) (shl' x m). Proof. intros. apply same_bits_eq; intros. - rewrite bits_zero_ext, ! bits_shl' by omega. + rewrite bits_zero_ext, ! bits_shl' by lia. destruct (zlt i (Int.unsigned m)). -- rewrite zlt_true by omega; auto. -- rewrite bits_zero_ext by omega. - destruct (zlt (i - Int.unsigned m) n); [rewrite zlt_true by omega|rewrite zlt_false by omega]; auto. +- rewrite zlt_true by lia; auto. +- rewrite bits_zero_ext by lia. + destruct (zlt (i - Int.unsigned m) n); [rewrite zlt_true by lia|rewrite zlt_false by lia]; auto. Qed. Lemma shl'_sign_ext: @@ -3774,12 +3887,12 @@ Lemma shl'_sign_ext: Proof. intros. generalize (Int.unsigned_range m); intros. apply same_bits_eq; intros. - rewrite bits_sign_ext, ! bits_shl' by omega. + rewrite bits_sign_ext, ! bits_shl' by lia. destruct (zlt i (n + Int.unsigned m)). - rewrite bits_shl' by auto. destruct (zlt i (Int.unsigned m)); auto. - rewrite bits_sign_ext by omega. f_equal. apply zlt_true. omega. -- rewrite zlt_false by omega. rewrite bits_shl' by omega. rewrite zlt_false by omega. - rewrite bits_sign_ext by omega. f_equal. rewrite zlt_false by omega. omega. + rewrite bits_sign_ext by lia. f_equal. apply zlt_true. lia. +- rewrite zlt_false by lia. rewrite bits_shl' by lia. rewrite zlt_false by lia. + rewrite bits_sign_ext by lia. f_equal. rewrite zlt_false by lia. lia. Qed. Lemma shru'_zero_ext: @@ -3787,9 +3900,9 @@ Lemma shru'_zero_ext: shru' (zero_ext (n + Int.unsigned m) x) m = zero_ext n (shru' x m). Proof. intros. generalize (Int.unsigned_range m); intros. - bit_solve; [|omega]. rewrite bits_shru', bits_zero_ext, bits_shru' by omega. + bit_solve; [|lia]. rewrite bits_shru', bits_zero_ext, bits_shru' by lia. destruct (zlt (i + Int.unsigned m) zwordsize). -* destruct (zlt i n); [rewrite zlt_true by omega|rewrite zlt_false by omega]; auto. +* destruct (zlt i n); [rewrite zlt_true by lia|rewrite zlt_false by lia]; auto. * destruct (zlt i n); auto. Qed. @@ -3798,9 +3911,9 @@ Lemma shru'_zero_ext_0: shru' (zero_ext n x) m = zero. Proof. intros. generalize (Int.unsigned_range m); intros. - bit_solve. rewrite bits_shru', bits_zero_ext by omega. + bit_solve. rewrite bits_shru', bits_zero_ext by lia. destruct (zlt (i + Int.unsigned m) zwordsize); auto. - apply zlt_false. omega. + apply zlt_false. lia. Qed. Lemma shr'_sign_ext: @@ -3813,12 +3926,12 @@ Proof. rewrite bits_sign_ext, bits_shr'. - f_equal. destruct (zlt i n), (zlt (i + Int.unsigned m) zwordsize). -+ apply zlt_true; omega. -+ apply zlt_true; omega. -+ rewrite zlt_false by omega. rewrite zlt_true by omega. omega. -+ rewrite zlt_false by omega. rewrite zlt_true by omega. omega. -- destruct (zlt i n); omega. -- destruct (zlt (i + Int.unsigned m) zwordsize); omega. ++ apply zlt_true; lia. ++ apply zlt_true; lia. ++ rewrite zlt_false by lia. rewrite zlt_true by lia. lia. ++ rewrite zlt_false by lia. rewrite zlt_true by lia. lia. +- destruct (zlt i n); lia. +- destruct (zlt (i + Int.unsigned m) zwordsize); lia. Qed. Lemma zero_ext_shru'_min: @@ -3827,10 +3940,10 @@ Lemma zero_ext_shru'_min: Proof. intros. apply Int.ltu_inv in H. change (Int.unsigned iwordsize') with zwordsize in H. apply Z.min_case_strong; intros; auto. - bit_solve; try omega. rewrite ! bits_shru' by omega. + bit_solve; try lia. rewrite ! bits_shru' by lia. destruct (zlt i (zwordsize - Int.unsigned n)). - rewrite zlt_true by omega. auto. - destruct (zlt i s); auto. rewrite zlt_false by omega; auto. + rewrite zlt_true by lia. auto. + destruct (zlt i s); auto. rewrite zlt_false by lia; auto. Qed. Lemma sign_ext_shr'_min: @@ -3842,12 +3955,12 @@ Proof. destruct (Z.min_spec (zwordsize - Int.unsigned n) s) as [[A B] | [A B]]; rewrite B; auto. apply same_bits_eq; intros. rewrite ! bits_sign_ext by auto. destruct (zlt i (zwordsize - Int.unsigned n)). - rewrite zlt_true by omega. auto. + rewrite zlt_true by lia. auto. assert (C: testbit (shr' x n) (zwordsize - Int.unsigned n - 1) = testbit x (zwordsize - 1)). - { rewrite bits_shr' by omega. rewrite zlt_true by omega. f_equal; omega. } - rewrite C. destruct (zlt i s); rewrite bits_shr' by omega. - rewrite zlt_false by omega. auto. - rewrite zlt_false by omega. auto. + { rewrite bits_shr' by lia. rewrite zlt_true by lia. f_equal; lia. } + rewrite C. destruct (zlt i s); rewrite bits_shr' by lia. + rewrite zlt_false by lia. auto. + rewrite zlt_false by lia. auto. Qed. Lemma shl'_zero_ext_min: @@ -3858,10 +3971,10 @@ Proof. apply Z.min_case_strong; intros; auto. apply same_bits_eq; intros. rewrite ! bits_shl' by auto. destruct (zlt i (Int.unsigned n)); auto. - rewrite ! bits_zero_ext by omega. + rewrite ! bits_zero_ext by lia. destruct (zlt (i - Int.unsigned n) s). - rewrite zlt_true by omega; auto. - rewrite zlt_false by omega; auto. + rewrite zlt_true by lia; auto. + rewrite zlt_false by lia; auto. Qed. Lemma shl'_sign_ext_min: @@ -3873,10 +3986,10 @@ Proof. destruct (Z.min_spec (zwordsize - Int.unsigned n) s) as [[A B] | [A B]]; rewrite B; auto. apply same_bits_eq; intros. rewrite ! bits_shl' by auto. destruct (zlt i (Int.unsigned n)); auto. - rewrite ! bits_sign_ext by omega. f_equal. + rewrite ! bits_sign_ext by lia. f_equal. destruct (zlt (i - Int.unsigned n) s). - rewrite zlt_true by omega; auto. - omegaContradiction. + rewrite zlt_true by lia; auto. + extlia. Qed. (** Powers of two with exponents given as 32-bit ints *) @@ -3897,8 +4010,8 @@ Proof. destruct (list_in_map_inv _ _ _ H) as [i0 [EQ IN]]. exploit Z_one_bits_range; eauto. fold zwordsize. intros R. unfold Int.ltu. rewrite EQ. rewrite Int.unsigned_repr. - change (Int.unsigned iwordsize') with zwordsize. apply zlt_true. omega. - assert (zwordsize < Int.max_unsigned) by reflexivity. omega. + change (Int.unsigned iwordsize') with zwordsize. apply zlt_true. lia. + assert (zwordsize < Int.max_unsigned) by reflexivity. lia. Qed. Fixpoint int_of_one_bits' (l: list Int.int) : int := @@ -3917,7 +4030,7 @@ Proof. - auto. - rewrite IHl by eauto. apply eqm_samerepr; apply eqm_add. + rewrite shl'_one_two_p. rewrite Int.unsigned_repr. apply eqm_sym; apply eqm_unsigned_repr. - exploit (H a). auto. assert (zwordsize < Int.max_unsigned) by reflexivity. omega. + exploit (H a). auto. assert (zwordsize < Int.max_unsigned) by reflexivity. lia. + apply eqm_sym; apply eqm_unsigned_repr. } intros. rewrite <- (repr_unsigned x) at 1. unfold one_bits'. rewrite REC. @@ -3936,7 +4049,7 @@ Proof. { apply Z_one_bits_range with (unsigned n). rewrite B; auto with coqlib. } rewrite Int.unsigned_repr. auto. assert (zwordsize < Int.max_unsigned) by reflexivity. - omega. + lia. Qed. Theorem is_power2'_range: @@ -3955,11 +4068,11 @@ Proof. unfold is_power2'; intros. destruct (Z_one_bits wordsize (unsigned n) 0) as [ | i [ | ? ?]] eqn:B; inv H. rewrite (Z_one_bits_powerserie wordsize (unsigned n)) by (apply unsigned_range). - rewrite Int.unsigned_repr. rewrite B; simpl. omega. + rewrite Int.unsigned_repr. rewrite B; simpl. lia. assert (0 <= i < zwordsize). { apply Z_one_bits_range with (unsigned n). rewrite B; auto with coqlib. } assert (zwordsize < Int.max_unsigned) by reflexivity. - omega. + lia. Qed. Theorem mul_pow2': @@ -4003,7 +4116,7 @@ Proof. assert (zwordsize = 2 * Int.zwordsize) by reflexivity. fold (testbit (shru n (repr Int.zwordsize)) i). rewrite bits_shru. change (unsigned (repr Int.zwordsize)) with Int.zwordsize. - apply zlt_true. omega. omega. + apply zlt_true. lia. lia. Qed. Lemma bits_ofwords: @@ -4018,15 +4131,15 @@ Proof. rewrite testbit_repr; auto. rewrite !testbit_repr; auto. fold (Int.testbit lo i). rewrite Int.bits_above. apply orb_false_r. auto. - omega. + lia. Qed. Lemma lo_ofwords: forall hi lo, loword (ofwords hi lo) = lo. Proof. intros. apply Int.same_bits_eq; intros. - rewrite bits_loword; auto. rewrite bits_ofwords. apply zlt_true. omega. - assert (zwordsize = 2 * Int.zwordsize) by reflexivity. omega. + rewrite bits_loword; auto. rewrite bits_ofwords. apply zlt_true. lia. + assert (zwordsize = 2 * Int.zwordsize) by reflexivity. lia. Qed. Lemma hi_ofwords: @@ -4034,8 +4147,8 @@ Lemma hi_ofwords: Proof. intros. apply Int.same_bits_eq; intros. rewrite bits_hiword; auto. rewrite bits_ofwords. - rewrite zlt_false. f_equal. omega. omega. - assert (zwordsize = 2 * Int.zwordsize) by reflexivity. omega. + rewrite zlt_false. f_equal. lia. lia. + assert (zwordsize = 2 * Int.zwordsize) by reflexivity. lia. Qed. Lemma ofwords_recompose: @@ -4043,9 +4156,9 @@ Lemma ofwords_recompose: Proof. intros. apply same_bits_eq; intros. rewrite bits_ofwords; auto. destruct (zlt i Int.zwordsize). - apply bits_loword. omega. - rewrite bits_hiword. f_equal. omega. - assert (zwordsize = 2 * Int.zwordsize) by reflexivity. omega. + apply bits_loword. lia. + rewrite bits_hiword. f_equal. lia. + assert (zwordsize = 2 * Int.zwordsize) by reflexivity. lia. Qed. Lemma ofwords_add: @@ -4056,10 +4169,10 @@ Proof. apply eqm_sym; apply eqm_unsigned_repr. apply eqm_refl. apply eqm_sym; apply eqm_unsigned_repr. - change Int.zwordsize with 32; change zwordsize with 64; omega. + change Int.zwordsize with 32; change zwordsize with 64; lia. rewrite unsigned_repr. generalize (Int.unsigned_range lo). intros [A B]. exact B. assert (Int.max_unsigned < max_unsigned) by (compute; auto). - generalize (Int.unsigned_range_2 lo); omega. + generalize (Int.unsigned_range_2 lo); lia. Qed. Lemma ofwords_add': @@ -4070,7 +4183,7 @@ Proof. change (two_p 32) with Int.modulus. change Int.modulus with 4294967296. change max_unsigned with 18446744073709551615. - omega. + lia. Qed. Remark eqm_mul_2p32: @@ -4094,7 +4207,7 @@ Proof. change min_signed with (Int.min_signed * Int.modulus). change max_signed with (Int.max_signed * Int.modulus + Int.modulus - 1). change Int.modulus with 4294967296. - omega. + lia. apply eqm_samerepr. apply eqm_add. apply eqm_mul_2p32. apply Int.eqm_signed_unsigned. apply eqm_refl. Qed. @@ -4109,7 +4222,7 @@ Proof. intros. apply Int64.same_bits_eq; intros. rewrite H by auto. rewrite ! bits_ofwords by auto. assert (zwordsize = 2 * Int.zwordsize) by reflexivity. - destruct (zlt i Int.zwordsize); rewrite H0 by omega; auto. + destruct (zlt i Int.zwordsize); rewrite H0 by lia; auto. Qed. Lemma decompose_and: @@ -4154,21 +4267,21 @@ Proof. intros. assert (Int.unsigned (Int.sub Int.iwordsize y) = Int.zwordsize - Int.unsigned y). { unfold Int.sub. rewrite Int.unsigned_repr. auto. - rewrite Int.unsigned_repr_wordsize. generalize Int.wordsize_max_unsigned; omega. } + rewrite Int.unsigned_repr_wordsize. generalize Int.wordsize_max_unsigned; lia. } assert (zwordsize = 2 * Int.zwordsize) by reflexivity. apply Int64.same_bits_eq; intros. rewrite bits_shl' by auto. symmetry. rewrite bits_ofwords by auto. - destruct (zlt i Int.zwordsize). rewrite Int.bits_shl by omega. + destruct (zlt i Int.zwordsize). rewrite Int.bits_shl by lia. destruct (zlt i (Int.unsigned y)). auto. - rewrite bits_ofwords by omega. rewrite zlt_true by omega. auto. - rewrite zlt_false by omega. rewrite bits_ofwords by omega. - rewrite Int.bits_or by omega. rewrite Int.bits_shl by omega. - rewrite Int.bits_shru by omega. rewrite H0. + rewrite bits_ofwords by lia. rewrite zlt_true by lia. auto. + rewrite zlt_false by lia. rewrite bits_ofwords by lia. + rewrite Int.bits_or by lia. rewrite Int.bits_shl by lia. + rewrite Int.bits_shru by lia. rewrite H0. destruct (zlt (i - Int.unsigned y) (Int.zwordsize)). - rewrite zlt_true by omega. rewrite zlt_true by omega. - rewrite orb_false_l. f_equal. omega. - rewrite zlt_false by omega. rewrite zlt_false by omega. - rewrite orb_false_r. f_equal. omega. + rewrite zlt_true by lia. rewrite zlt_true by lia. + rewrite orb_false_l. f_equal. lia. + rewrite zlt_false by lia. rewrite zlt_false by lia. + rewrite orb_false_r. f_equal. lia. Qed. Lemma decompose_shl_2: @@ -4181,15 +4294,15 @@ Proof. assert (zwordsize = 2 * Int.zwordsize) by reflexivity. assert (Int.unsigned (Int.sub y Int.iwordsize) = Int.unsigned y - Int.zwordsize). { unfold Int.sub. rewrite Int.unsigned_repr. auto. - rewrite Int.unsigned_repr_wordsize. generalize (Int.unsigned_range_2 y). omega. } + rewrite Int.unsigned_repr_wordsize. generalize (Int.unsigned_range_2 y). lia. } apply Int64.same_bits_eq; intros. rewrite bits_shl' by auto. symmetry. rewrite bits_ofwords by auto. - destruct (zlt i Int.zwordsize). rewrite zlt_true by omega. apply Int.bits_zero. - rewrite Int.bits_shl by omega. + destruct (zlt i Int.zwordsize). rewrite zlt_true by lia. apply Int.bits_zero. + rewrite Int.bits_shl by lia. destruct (zlt i (Int.unsigned y)). - rewrite zlt_true by omega. auto. - rewrite zlt_false by omega. - rewrite bits_ofwords by omega. rewrite zlt_true by omega. f_equal. omega. + rewrite zlt_true by lia. auto. + rewrite zlt_false by lia. + rewrite bits_ofwords by lia. rewrite zlt_true by lia. f_equal. lia. Qed. Lemma decompose_shru_1: @@ -4202,25 +4315,25 @@ Proof. intros. assert (Int.unsigned (Int.sub Int.iwordsize y) = Int.zwordsize - Int.unsigned y). { unfold Int.sub. rewrite Int.unsigned_repr. auto. - rewrite Int.unsigned_repr_wordsize. generalize Int.wordsize_max_unsigned; omega. } + rewrite Int.unsigned_repr_wordsize. generalize Int.wordsize_max_unsigned; lia. } assert (zwordsize = 2 * Int.zwordsize) by reflexivity. apply Int64.same_bits_eq; intros. rewrite bits_shru' by auto. symmetry. rewrite bits_ofwords by auto. destruct (zlt i Int.zwordsize). - rewrite zlt_true by omega. - rewrite bits_ofwords by omega. - rewrite Int.bits_or by omega. rewrite Int.bits_shl by omega. - rewrite Int.bits_shru by omega. rewrite H0. + rewrite zlt_true by lia. + rewrite bits_ofwords by lia. + rewrite Int.bits_or by lia. rewrite Int.bits_shl by lia. + rewrite Int.bits_shru by lia. rewrite H0. destruct (zlt (i + Int.unsigned y) (Int.zwordsize)). - rewrite zlt_true by omega. + rewrite zlt_true by lia. rewrite orb_false_r. auto. - rewrite zlt_false by omega. - rewrite orb_false_l. f_equal. omega. - rewrite Int.bits_shru by omega. + rewrite zlt_false by lia. + rewrite orb_false_l. f_equal. lia. + rewrite Int.bits_shru by lia. destruct (zlt (i + Int.unsigned y) zwordsize). - rewrite bits_ofwords by omega. - rewrite zlt_true by omega. rewrite zlt_false by omega. f_equal. omega. - rewrite zlt_false by omega. auto. + rewrite bits_ofwords by lia. + rewrite zlt_true by lia. rewrite zlt_false by lia. f_equal. lia. + rewrite zlt_false by lia. auto. Qed. Lemma decompose_shru_2: @@ -4233,16 +4346,16 @@ Proof. assert (zwordsize = 2 * Int.zwordsize) by reflexivity. assert (Int.unsigned (Int.sub y Int.iwordsize) = Int.unsigned y - Int.zwordsize). { unfold Int.sub. rewrite Int.unsigned_repr. auto. - rewrite Int.unsigned_repr_wordsize. generalize (Int.unsigned_range_2 y). omega. } + rewrite Int.unsigned_repr_wordsize. generalize (Int.unsigned_range_2 y). lia. } apply Int64.same_bits_eq; intros. rewrite bits_shru' by auto. symmetry. rewrite bits_ofwords by auto. destruct (zlt i Int.zwordsize). - rewrite Int.bits_shru by omega. rewrite H1. + rewrite Int.bits_shru by lia. rewrite H1. destruct (zlt (i + Int.unsigned y) zwordsize). - rewrite zlt_true by omega. rewrite bits_ofwords by omega. - rewrite zlt_false by omega. f_equal; omega. - rewrite zlt_false by omega. auto. - rewrite zlt_false by omega. apply Int.bits_zero. + rewrite zlt_true by lia. rewrite bits_ofwords by lia. + rewrite zlt_false by lia. f_equal; lia. + rewrite zlt_false by lia. auto. + rewrite zlt_false by lia. apply Int.bits_zero. Qed. Lemma decompose_shr_1: @@ -4255,26 +4368,26 @@ Proof. intros. assert (Int.unsigned (Int.sub Int.iwordsize y) = Int.zwordsize - Int.unsigned y). { unfold Int.sub. rewrite Int.unsigned_repr. auto. - rewrite Int.unsigned_repr_wordsize. generalize Int.wordsize_max_unsigned; omega. } + rewrite Int.unsigned_repr_wordsize. generalize Int.wordsize_max_unsigned; lia. } assert (zwordsize = 2 * Int.zwordsize) by reflexivity. apply Int64.same_bits_eq; intros. rewrite bits_shr' by auto. symmetry. rewrite bits_ofwords by auto. destruct (zlt i Int.zwordsize). - rewrite zlt_true by omega. - rewrite bits_ofwords by omega. - rewrite Int.bits_or by omega. rewrite Int.bits_shl by omega. - rewrite Int.bits_shru by omega. rewrite H0. + rewrite zlt_true by lia. + rewrite bits_ofwords by lia. + rewrite Int.bits_or by lia. rewrite Int.bits_shl by lia. + rewrite Int.bits_shru by lia. rewrite H0. destruct (zlt (i + Int.unsigned y) (Int.zwordsize)). - rewrite zlt_true by omega. + rewrite zlt_true by lia. rewrite orb_false_r. auto. - rewrite zlt_false by omega. - rewrite orb_false_l. f_equal. omega. - rewrite Int.bits_shr by omega. + rewrite zlt_false by lia. + rewrite orb_false_l. f_equal. lia. + rewrite Int.bits_shr by lia. destruct (zlt (i + Int.unsigned y) zwordsize). - rewrite bits_ofwords by omega. - rewrite zlt_true by omega. rewrite zlt_false by omega. f_equal. omega. - rewrite zlt_false by omega. rewrite bits_ofwords by omega. - rewrite zlt_false by omega. f_equal. + rewrite bits_ofwords by lia. + rewrite zlt_true by lia. rewrite zlt_false by lia. f_equal. lia. + rewrite zlt_false by lia. rewrite bits_ofwords by lia. + rewrite zlt_false by lia. f_equal. Qed. Lemma decompose_shr_2: @@ -4288,24 +4401,24 @@ Proof. assert (zwordsize = 2 * Int.zwordsize) by reflexivity. assert (Int.unsigned (Int.sub y Int.iwordsize) = Int.unsigned y - Int.zwordsize). { unfold Int.sub. rewrite Int.unsigned_repr. auto. - rewrite Int.unsigned_repr_wordsize. generalize (Int.unsigned_range_2 y). omega. } + rewrite Int.unsigned_repr_wordsize. generalize (Int.unsigned_range_2 y). lia. } apply Int64.same_bits_eq; intros. rewrite bits_shr' by auto. symmetry. rewrite bits_ofwords by auto. destruct (zlt i Int.zwordsize). - rewrite Int.bits_shr by omega. rewrite H1. + rewrite Int.bits_shr by lia. rewrite H1. destruct (zlt (i + Int.unsigned y) zwordsize). - rewrite zlt_true by omega. rewrite bits_ofwords by omega. - rewrite zlt_false by omega. f_equal; omega. - rewrite zlt_false by omega. rewrite bits_ofwords by omega. - rewrite zlt_false by omega. auto. - rewrite Int.bits_shr by omega. + rewrite zlt_true by lia. rewrite bits_ofwords by lia. + rewrite zlt_false by lia. f_equal; lia. + rewrite zlt_false by lia. rewrite bits_ofwords by lia. + rewrite zlt_false by lia. auto. + rewrite Int.bits_shr by lia. change (Int.unsigned (Int.sub Int.iwordsize Int.one)) with (Int.zwordsize - 1). destruct (zlt (i + Int.unsigned y) zwordsize); - rewrite bits_ofwords by omega. - symmetry. rewrite zlt_false by omega. f_equal. - destruct (zlt (i - Int.zwordsize + (Int.zwordsize - 1)) Int.zwordsize); omega. - symmetry. rewrite zlt_false by omega. f_equal. - destruct (zlt (i - Int.zwordsize + (Int.zwordsize - 1)) Int.zwordsize); omega. + rewrite bits_ofwords by lia. + symmetry. rewrite zlt_false by lia. f_equal. + destruct (zlt (i - Int.zwordsize + (Int.zwordsize - 1)) Int.zwordsize); lia. + symmetry. rewrite zlt_false by lia. f_equal. + destruct (zlt (i - Int.zwordsize + (Int.zwordsize - 1)) Int.zwordsize); lia. Qed. Lemma decompose_add: @@ -4442,14 +4555,14 @@ Proof. intros. unfold ltu. rewrite ! ofwords_add'. unfold Int.ltu, Int.eq. destruct (zeq (Int.unsigned xh) (Int.unsigned yh)). rewrite e. destruct (zlt (Int.unsigned xl) (Int.unsigned yl)). - apply zlt_true; omega. - apply zlt_false; omega. + apply zlt_true; lia. + apply zlt_false; lia. change (two_p 32) with Int.modulus. generalize (Int.unsigned_range xl) (Int.unsigned_range yl). change Int.modulus with 4294967296. intros. destruct (zlt (Int.unsigned xh) (Int.unsigned yh)). - apply zlt_true; omega. - apply zlt_false; omega. + apply zlt_true; lia. + apply zlt_false; lia. Qed. Lemma decompose_leu: @@ -4461,8 +4574,8 @@ Proof. unfold Int.eq. destruct (zeq (Int.unsigned xh) (Int.unsigned yh)). auto. unfold Int.ltu. destruct (zlt (Int.unsigned xh) (Int.unsigned yh)). - rewrite zlt_false by omega; auto. - rewrite zlt_true by omega; auto. + rewrite zlt_false by lia; auto. + rewrite zlt_true by lia; auto. Qed. Lemma decompose_lt: @@ -4472,14 +4585,14 @@ Proof. intros. unfold lt. rewrite ! ofwords_add''. rewrite Int.eq_signed. destruct (zeq (Int.signed xh) (Int.signed yh)). rewrite e. unfold Int.ltu. destruct (zlt (Int.unsigned xl) (Int.unsigned yl)). - apply zlt_true; omega. - apply zlt_false; omega. + apply zlt_true; lia. + apply zlt_false; lia. change (two_p 32) with Int.modulus. generalize (Int.unsigned_range xl) (Int.unsigned_range yl). change Int.modulus with 4294967296. intros. unfold Int.lt. destruct (zlt (Int.signed xh) (Int.signed yh)). - apply zlt_true; omega. - apply zlt_false; omega. + apply zlt_true; lia. + apply zlt_false; lia. Qed. Lemma decompose_le: @@ -4491,8 +4604,8 @@ Proof. rewrite Int.eq_signed. destruct (zeq (Int.signed xh) (Int.signed yh)). auto. unfold Int.lt. destruct (zlt (Int.signed xh) (Int.signed yh)). - rewrite zlt_false by omega; auto. - rewrite zlt_true by omega; auto. + rewrite zlt_false by lia; auto. + rewrite zlt_true by lia; auto. Qed. (** Utility proofs for mixed 32bit and 64bit arithmetic *) @@ -4507,7 +4620,7 @@ Proof. change (wordsize) with 64%nat in *. change (Int.wordsize) with 32%nat in *. unfold two_power_nat. simpl. - omega. + lia. Qed. Remark int_unsigned_repr: @@ -4527,9 +4640,9 @@ Proof. rewrite unsigned_repr by apply int_unsigned_range. rewrite int_unsigned_repr. reflexivity. rewrite unsigned_repr by apply int_unsigned_range. rewrite int_unsigned_repr. generalize (int_unsigned_range y). - omega. + lia. generalize (Int.sub_ltu x y H). intros. - generalize (Int.unsigned_range_2 y). intros. omega. + generalize (Int.unsigned_range_2 y). intros. lia. Qed. End Int64. @@ -4687,7 +4800,7 @@ Lemma to_int_of_int: forall n, to_int (of_int n) = n. Proof. intros; unfold of_int, to_int. rewrite unsigned_repr. apply Int.repr_unsigned. - unfold max_unsigned. rewrite modulus_eq32. destruct (Int.unsigned_range n); omega. + unfold max_unsigned. rewrite modulus_eq32. destruct (Int.unsigned_range n); lia. Qed. End AGREE32. @@ -4797,12 +4910,12 @@ Lemma to_int64_of_int64: forall n, to_int64 (of_int64 n) = n. Proof. intros; unfold of_int64, to_int64. rewrite unsigned_repr. apply Int64.repr_unsigned. - unfold max_unsigned. rewrite modulus_eq64. destruct (Int64.unsigned_range n); omega. + unfold max_unsigned. rewrite modulus_eq64. destruct (Int64.unsigned_range n); lia. Qed. End AGREE64. -Hint Resolve +Global Hint Resolve agree32_repr agree32_of_int agree32_of_ints agree32_of_int_eq agree32_of_ints_eq agree32_to_int agree32_to_int_eq agree32_neg agree32_add agree32_sub agree32_mul agree32_divs agree64_repr agree64_of_int agree64_of_int_eq @@ -4816,19 +4929,22 @@ Notation ptrofs := Ptrofs.int. Global Opaque Ptrofs.repr. -Hint Resolve Int.modulus_pos Int.eqm_refl Int.eqm_refl2 Int.eqm_sym Int.eqm_trans +Global Hint Resolve + Int.modulus_pos Int.eqm_refl Int.eqm_refl2 Int.eqm_sym Int.eqm_trans Int.eqm_small_eq Int.eqm_add Int.eqm_neg Int.eqm_sub Int.eqm_mult Int.eqm_unsigned_repr Int.eqm_unsigned_repr_l Int.eqm_unsigned_repr_r Int.unsigned_range Int.unsigned_range_2 Int.repr_unsigned Int.repr_signed Int.unsigned_repr : ints. -Hint Resolve Int64.modulus_pos Int64.eqm_refl Int64.eqm_refl2 Int64.eqm_sym Int64.eqm_trans +Global Hint Resolve + Int64.modulus_pos Int64.eqm_refl Int64.eqm_refl2 Int64.eqm_sym Int64.eqm_trans Int64.eqm_small_eq Int64.eqm_add Int64.eqm_neg Int64.eqm_sub Int64.eqm_mult Int64.eqm_unsigned_repr Int64.eqm_unsigned_repr_l Int64.eqm_unsigned_repr_r Int64.unsigned_range Int64.unsigned_range_2 Int64.repr_unsigned Int64.repr_signed Int64.unsigned_repr : ints. -Hint Resolve Ptrofs.modulus_pos Ptrofs.eqm_refl Ptrofs.eqm_refl2 Ptrofs.eqm_sym Ptrofs.eqm_trans +Global Hint Resolve + Ptrofs.modulus_pos Ptrofs.eqm_refl Ptrofs.eqm_refl2 Ptrofs.eqm_sym Ptrofs.eqm_trans Ptrofs.eqm_small_eq Ptrofs.eqm_add Ptrofs.eqm_neg Ptrofs.eqm_sub Ptrofs.eqm_mult Ptrofs.eqm_unsigned_repr Ptrofs.eqm_unsigned_repr_l Ptrofs.eqm_unsigned_repr_r Ptrofs.unsigned_range Ptrofs.unsigned_range_2 @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -41,14 +42,14 @@ Lemma notin_range: forall x i, x < fst i \/ x >= snd i -> ~In x i. Proof. - unfold In; intros; omega. + unfold In; intros; lia. Qed. Lemma range_notin: forall x i, ~In x i -> fst i < snd i -> x < fst i \/ x >= snd i. Proof. - unfold In; intros; omega. + unfold In; intros; lia. Qed. (** * Emptyness *) @@ -60,26 +61,26 @@ Lemma empty_dec: Proof. unfold empty; intros. case (zle (snd i) (fst i)); intros. - left; omega. - right; omega. + left; lia. + right; lia. Qed. Lemma is_notempty: forall i, fst i < snd i -> ~empty i. Proof. - unfold empty; intros; omega. + unfold empty; intros; lia. Qed. Lemma empty_notin: forall x i, empty i -> ~In x i. Proof. - unfold empty, In; intros. omega. + unfold empty, In; intros. lia. Qed. Lemma in_notempty: forall x i, In x i -> ~empty i. Proof. - unfold empty, In; intros. omega. + unfold empty, In; intros. lia. Qed. (** * Disjointness *) @@ -109,7 +110,7 @@ Lemma disjoint_range: forall i j, snd i <= fst j \/ snd j <= fst i -> disjoint i j. Proof. - unfold disjoint, In; intros. omega. + unfold disjoint, In; intros. lia. Qed. Lemma range_disjoint: @@ -127,13 +128,13 @@ Proof. (* Case 1.1: i ends to the left of j, OK *) auto. (* Case 1.2: i ends to the right of j's start, not disjoint. *) - elim (H (fst j)). red; omega. red; omega. + elim (H (fst j)). red; lia. red; lia. (* Case 2: j starts to the left of i *) destruct (zle (snd j) (fst i)). (* Case 2.1: j ends to the left of i, OK *) auto. (* Case 2.2: j ends to the right of i's start, not disjoint. *) - elim (H (fst i)). red; omega. red; omega. + elim (H (fst i)). red; lia. red; lia. Qed. Lemma range_disjoint': @@ -141,7 +142,7 @@ Lemma range_disjoint': disjoint i j -> fst i < snd i -> fst j < snd j -> snd i <= fst j \/ snd j <= fst i. Proof. - intros. exploit range_disjoint; eauto. unfold empty; intuition omega. + intros. exploit range_disjoint; eauto. unfold empty; intuition lia. Qed. Lemma disjoint_dec: @@ -163,14 +164,14 @@ Lemma in_shift: forall x i delta, In x i -> In (x + delta) (shift i delta). Proof. - unfold shift, In; intros. simpl. omega. + unfold shift, In; intros. simpl. lia. Qed. Lemma in_shift_inv: forall x i delta, In x (shift i delta) -> In (x - delta) i. Proof. - unfold shift, In; simpl; intros. omega. + unfold shift, In; simpl; intros. lia. Qed. (** * Enumerating the elements of an interval *) @@ -182,7 +183,7 @@ Variable lo: Z. Function elements_rec (hi: Z) {wf (Zwf lo) hi} : list Z := if zlt lo hi then (hi-1) :: elements_rec (hi-1) else nil. Proof. - intros. red. omega. + intros. red. lia. apply Zwf_well_founded. Qed. @@ -192,8 +193,8 @@ Lemma In_elements_rec: Proof. intros. functional induction (elements_rec hi). simpl; split; intros. - destruct H. clear IHl. omega. rewrite IHl in H. clear IHl. omega. - destruct (zeq (hi - 1) x); auto. right. rewrite IHl. clear IHl. omega. + destruct H. clear IHl. lia. rewrite IHl in H. clear IHl. lia. + destruct (zeq (hi - 1) x); auto. right. rewrite IHl. clear IHl. lia. simpl; intuition. Qed. @@ -241,20 +242,20 @@ Program Fixpoint forall_rec (hi: Z) {wf (Zwf lo) hi}: left _ _ . Next Obligation. - red. omega. + red. lia. Qed. Next Obligation. - assert (x = hi - 1 \/ x < hi - 1) by omega. + assert (x = hi - 1 \/ x < hi - 1) by lia. destruct H2. congruence. auto. Qed. Next Obligation. - exists wildcard'; split; auto. omega. + exists wildcard'; split; auto. lia. Qed. Next Obligation. - exists (hi - 1); split; auto. omega. + exists (hi - 1); split; auto. lia. Qed. Next Obligation. - omegaContradiction. + extlia. Defined. End FORALL. @@ -276,7 +277,7 @@ Variable a: A. Function fold_rec (hi: Z) {wf (Zwf lo) hi} : A := if zlt lo hi then f (hi - 1) (fold_rec (hi - 1)) else a. Proof. - intros. red. omega. + intros. red. lia. apply Zwf_well_founded. Qed. @@ -303,7 +304,7 @@ Qed. (** Hints *) -Hint Resolve +Global Hint Resolve notin_range range_notin is_notempty empty_notin in_notempty disjoint_sym empty_disjoint_r empty_disjoint_l diff --git a/lib/IntvSets.v b/lib/IntvSets.v index b97d9882..c3fda5f7 100644 --- a/lib/IntvSets.v +++ b/lib/IntvSets.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -59,7 +60,7 @@ Proof. + destruct (zle l x); simpl. * tauto. * split; intros. congruence. - exfalso. destruct H0. omega. exploit BELOW; eauto. omega. + exfalso. destruct H0. lia. exploit BELOW; eauto. lia. + rewrite IHok. intuition. Qed. @@ -74,14 +75,14 @@ Lemma contains_In: (contains l0 h0 s = true <-> (forall x, l0 <= x < h0 -> In x s)). Proof. induction 2; simpl. -- intuition. elim (H0 l0); omega. +- intuition. elim (H0 l0); lia. - destruct (zle h0 h); simpl. destruct (zle l l0); simpl. intuition. rewrite IHok. intuition. destruct (H3 x); auto. exfalso. - destruct (H3 l0). omega. omega. exploit BELOW; eauto. omega. + destruct (H3 l0). lia. lia. exploit BELOW; eauto. lia. rewrite IHok. intuition. destruct (H3 x); auto. exfalso. - destruct (H3 h). omega. omega. exploit BELOW; eauto. omega. + destruct (H3 h). lia. lia. exploit BELOW; eauto. lia. Qed. Fixpoint add (L H: Z) (s: t) {struct s} : t := @@ -103,9 +104,9 @@ Proof. destruct (zlt h0 l). simpl. tauto. rewrite IHok. intuition idtac. - assert (l0 <= x < h0 \/ l <= x < h) by xomega. tauto. - left; xomega. - left; xomega. + assert (l0 <= x < h0 \/ l <= x < h) by extlia. tauto. + left; extlia. + left; extlia. Qed. Lemma add_ok: @@ -115,11 +116,11 @@ Proof. constructor. auto. intros. inv H0. constructor. destruct (zlt h l0). constructor; auto. intros. rewrite In_add in H1; auto. - destruct H1. omega. auto. + destruct H1. lia. auto. destruct (zlt h0 l). - constructor. auto. simpl; intros. destruct H1. omega. exploit BELOW; eauto. omega. - constructor. omega. auto. auto. - apply IHok. xomega. + constructor. auto. simpl; intros. destruct H1. lia. exploit BELOW; eauto. lia. + constructor. lia. auto. auto. + apply IHok. extlia. Qed. Fixpoint remove (L H: Z) (s: t) {struct s} : t := @@ -141,22 +142,22 @@ Proof. induction 1; simpl. tauto. destruct (zlt h l0). - simpl. rewrite IHok. intuition omega. + simpl. rewrite IHok. intuition lia. destruct (zlt h0 l). - simpl. intuition. exploit BELOW; eauto. omega. + simpl. intuition. exploit BELOW; eauto. lia. destruct (zlt l l0). destruct (zlt h0 h); simpl. clear IHok. split. intros [A | [A | A]]. - split. omega. left; omega. - split. omega. left; omega. - split. exploit BELOW; eauto. omega. auto. + split. lia. left; lia. + split. lia. left; lia. + split. exploit BELOW; eauto. lia. auto. intros [A [B | B]]. - destruct (zlt x l0). left; omega. right; left; omega. + destruct (zlt x l0). left; lia. right; left; lia. auto. - intuition omega. + intuition lia. destruct (zlt h0 h); simpl. - intuition. exploit BELOW; eauto. omega. - rewrite IHok. intuition. omegaContradiction. + intuition. exploit BELOW; eauto. lia. + rewrite IHok. intuition. extlia. Qed. Lemma remove_ok: @@ -170,9 +171,9 @@ Proof. constructor; auto. destruct (zlt l l0). destruct (zlt h0 h). - constructor. omega. intros. inv H1. omega. exploit BELOW; eauto. omega. - constructor. omega. auto. auto. - constructor; auto. intros. rewrite In_remove in H1 by auto. destruct H1. exploit BELOW; eauto. omega. + constructor. lia. intros. inv H1. lia. exploit BELOW; eauto. lia. + constructor. lia. auto. auto. + constructor; auto. intros. rewrite In_remove in H1 by auto. destruct H1. exploit BELOW; eauto. lia. destruct (zlt h0 h). constructor; auto. auto. @@ -204,19 +205,19 @@ Proof. tauto. assert (ok (Cons l0 h0 s0)) by (constructor; auto). destruct (zle h l0). - rewrite IHok; auto. simpl. intuition. omegaContradiction. - exploit BELOW0; eauto. intros. omegaContradiction. + rewrite IHok; auto. simpl. intuition. extlia. + exploit BELOW0; eauto. intros. extlia. destruct (zle h0 l). - simpl in IHok0; rewrite IHok0. intuition. omegaContradiction. - exploit BELOW; eauto. intros; omegaContradiction. + simpl in IHok0; rewrite IHok0. intuition. extlia. + exploit BELOW; eauto. intros; extlia. destruct (zle l l0). destruct (zle h0 h). simpl. simpl in IHok0; rewrite IHok0. intuition. - simpl. rewrite IHok; auto. simpl. intuition. exploit BELOW0; eauto. intros; omegaContradiction. + simpl. rewrite IHok; auto. simpl. intuition. exploit BELOW0; eauto. intros; extlia. destruct (zle h h0). simpl. rewrite IHok; auto. simpl. intuition. simpl. simpl in IHok0; rewrite IHok0. intuition. - exploit BELOW; eauto. intros; omegaContradiction. + exploit BELOW; eauto. intros; extlia. Qed. Lemma inter_ok: @@ -237,12 +238,12 @@ Proof. constructor; auto. intros. assert (In x (inter (Cons l h s) s0)) by exact H3. rewrite In_inter in H4; auto. apply BELOW0. tauto. - constructor. omega. intros. rewrite In_inter in H3; auto. apply BELOW. tauto. + constructor. lia. intros. rewrite In_inter in H3; auto. apply BELOW. tauto. auto. destruct (zle h h0). - constructor. omega. intros. rewrite In_inter in H3; auto. apply BELOW. tauto. + constructor. lia. intros. rewrite In_inter in H3; auto. apply BELOW. tauto. auto. - constructor. omega. intros. + constructor. lia. intros. assert (In x (inter (Cons l h s) s0)) by exact H3. rewrite In_inter in H4; auto. apply BELOW0. tauto. auto. @@ -281,20 +282,20 @@ Lemma beq_spec: Proof. induction 1; destruct 1; simpl. - tauto. -- split; intros. discriminate. exfalso. apply (H0 l). left; omega. -- split; intros. discriminate. exfalso. apply (H0 l). left; omega. +- split; intros. discriminate. exfalso. apply (H0 l). left; lia. +- split; intros. discriminate. exfalso. apply (H0 l). left; lia. - split; intros. + InvBooleans. subst. rewrite IHok in H3 by auto. rewrite H3. tauto. + destruct (zeq l l0). destruct (zeq h h0). simpl. subst. apply IHok. auto. intros; split; intros. - destruct (proj1 (H1 x)); auto. exfalso. exploit BELOW; eauto. omega. - destruct (proj2 (H1 x)); auto. exfalso. exploit BELOW0; eauto. omega. + destruct (proj1 (H1 x)); auto. exfalso. exploit BELOW; eauto. lia. + destruct (proj2 (H1 x)); auto. exfalso. exploit BELOW0; eauto. lia. exfalso. subst l0. destruct (zlt h h0). - destruct (proj2 (H1 h)). left; omega. omega. exploit BELOW; eauto. omega. - destruct (proj1 (H1 h0)). left; omega. omega. exploit BELOW0; eauto. omega. + destruct (proj2 (H1 h)). left; lia. lia. exploit BELOW; eauto. lia. + destruct (proj1 (H1 h0)). left; lia. lia. exploit BELOW0; eauto. lia. exfalso. destruct (zlt l l0). - destruct (proj1 (H1 l)). left; omega. omega. exploit BELOW0; eauto. omega. - destruct (proj2 (H1 l0)). left; omega. omega. exploit BELOW; eauto. omega. + destruct (proj1 (H1 l)). left; lia. lia. exploit BELOW0; eauto. lia. + destruct (proj2 (H1 l0)). left; lia. lia. exploit BELOW; eauto. lia. Qed. End R. @@ -340,7 +341,7 @@ Proof. unfold add, In; intros. destruct (zlt l h). simpl. apply R.In_add. apply proj2_sig. - intuition. omegaContradiction. + intuition. extlia. Qed. Program Definition remove (l h: Z) (s: t) : t := @@ -392,7 +393,7 @@ Theorem contains_spec: Proof. unfold contains, In; intros. destruct (zlt l h). apply R.contains_In. auto. apply proj2_sig. - split; intros. omegaContradiction. auto. + split; intros. extlia. auto. Qed. Program Definition beq (s1 s2: t) : bool := R.beq s1 s2. diff --git a/lib/Iteration.v b/lib/Iteration.v index 6a9d3253..66bb3970 100644 --- a/lib/Iteration.v +++ b/lib/Iteration.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -19,6 +20,8 @@ Require Import Axioms. Require Import Coqlib. Require Import Wfsimpl. +Set Asymmetric Patterns. + (** This modules defines several Coq encodings of a general "while" loop. The loop is presented in functional style as the iteration of a [step] function of type [A -> B + A]: @@ -237,8 +240,8 @@ Lemma iter_monot: Proof. induction p; intros. simpl. red; intros; red; auto. - destruct q. elimtype False; omega. - simpl. apply F_iter_monot. apply IHp. omega. + destruct q. elimtype False; lia. + simpl. apply F_iter_monot. apply IHp. lia. Qed. Lemma iter_either: diff --git a/lib/Lattice.v b/lib/Lattice.v index 85fc03f3..6fed3f21 100644 --- a/lib/Lattice.v +++ b/lib/Lattice.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -1285,102 +1286,121 @@ Module ZTree := ITree(ZIndexed). Module Tree_Properties(T: TREE). -(** An induction principle over [fold]. *) +(** Two induction principles over [fold]. *) Section TREE_FOLD_IND. Variables V A: Type. Variable f: A -> T.elt -> V -> A. -Variable P: T.t V -> A -> Prop. +Variable P: T.t V -> A -> Type. Variable init: A. Variable m_final: T.t V. -Hypothesis P_compat: - forall m m' a, - (forall x, T.get x m = T.get x m') -> - P m a -> P m' a. - Hypothesis H_base: - P (T.empty _) init. + forall m, + (forall k, T.get k m = None) -> + P m init. Hypothesis H_rec: forall m a k v, - T.get k m = None -> T.get k m_final = Some v -> P m a -> P (T.set k v m) (f a k v). + T.get k m = Some v -> T.get k m_final = Some v -> + P (T.remove k m) a -> P m (f a k v). -Let f' (a: A) (p : T.elt * V) := f a (fst p) (snd p). +Let f' (p : T.elt * V) (a: A) := f a (fst p) (snd p). -Let P' (l: list (T.elt * V)) (a: A) : Prop := - forall m, list_equiv l (T.elements m) -> P m a. +Let P' (l: list (T.elt * V)) (a: A) : Type := + forall m, (forall k v, In (k, v) l <-> T.get k m = Some v) -> P m a. -Remark H_base': +Let H_base': P' nil init. Proof. - red; intros. apply P_compat with (T.empty _); auto. - intros. rewrite T.gempty. symmetry. case_eq (T.get x m); intros; auto. - assert (In (x, v) nil). rewrite (H (x, v)). apply T.elements_correct. auto. - contradiction. + intros m EQV. apply H_base. + intros. destruct (T.get k m) as [v|] eqn:G; auto. + apply EQV in G. contradiction. Qed. -Remark H_rec': +Let H_rec': forall k v l a, - ~In k (List.map (@fst T.elt V) l) -> - In (k, v) (T.elements m_final) -> + ~In k (List.map fst l) -> + T.get k m_final = Some v -> P' l a -> - P' (l ++ (k, v) :: nil) (f a k v). + P' ((k, v) :: l) (f a k v). Proof. - unfold P'; intros. + unfold P'; intros k v l a NOTIN FINAL HR m EQV. set (m0 := T.remove k m). - apply P_compat with (T.set k v m0). - intros. unfold m0. rewrite T.gsspec. destruct (T.elt_eq x k). - symmetry. apply T.elements_complete. rewrite <- (H2 (x, v)). - apply in_or_app. simpl. intuition congruence. - apply T.gro. auto. - apply H_rec. unfold m0. apply T.grs. apply T.elements_complete. auto. - apply H1. red. intros [k' v']. - split; intros. - apply T.elements_correct. unfold m0. rewrite T.gro. apply T.elements_complete. - rewrite <- (H2 (k', v')). apply in_or_app. auto. - red; intro; subst k'. elim H. change k with (fst (k, v')). apply in_map. auto. - assert (T.get k' m0 = Some v'). apply T.elements_complete. auto. - unfold m0 in H4. rewrite T.grspec in H4. destruct (T.elt_eq k' k). congruence. - assert (In (k', v') (T.elements m)). apply T.elements_correct; auto. - rewrite <- (H2 (k', v')) in H5. destruct (in_app_or _ _ _ H5). auto. - simpl in H6. intuition congruence. + apply H_rec. +- apply EQV. simpl; auto. +- auto. +- apply HR. intros k' v'. rewrite T.grspec. split; intros; destruct (T.elt_eq k' k). + + subst k'. elim NOTIN. change k with (fst (k, v')). apply List.in_map; auto. + + apply EQV. simpl; auto. + + congruence. + + apply EQV in H. simpl in H. intuition congruence. Qed. -Lemma fold_rec_aux: - forall l1 l2 a, - list_equiv (l2 ++ l1) (T.elements m_final) -> - list_disjoint (List.map (@fst T.elt V) l1) (List.map (@fst T.elt V) l2) -> - list_norepet (List.map (@fst T.elt V) l1) -> - P' l2 a -> P' (l2 ++ l1) (List.fold_left f' l1 a). +Lemma fold_ind_aux: + forall l, + (forall k v, In (k, v) l -> T.get k m_final = Some v) -> + list_norepet (List.map fst l) -> + P' l (List.fold_right f' init l). Proof. - induction l1; intros; simpl. - rewrite <- List.app_nil_end. auto. - destruct a as [k v]; simpl in *. inv H1. - change ((k, v) :: l1) with (((k, v) :: nil) ++ l1). rewrite <- List.app_ass. apply IHl1. - rewrite app_ass. auto. - red; intros. rewrite map_app in H3. destruct (in_app_or _ _ _ H3). apply H0; auto with coqlib. - simpl in H4. intuition congruence. - auto. - unfold f'. simpl. apply H_rec'; auto. eapply list_disjoint_notin; eauto with coqlib. - rewrite <- (H (k, v)). apply in_or_app. simpl. auto. -Qed. + induction l as [ | [k v] l ]; simpl; intros FINAL NOREPET. +- apply H_base'. +- apply H_rec'. + + inv NOREPET. auto. + + apply FINAL. auto. + + apply IHl. auto. inv NOREPET; auto. +Defined. + +Theorem fold_ind: + P m_final (T.fold f m_final init). +Proof. + intros. + set (l' := List.rev (T.elements m_final)). + assert (P' l' (List.fold_right f' init l')). + { apply fold_ind_aux. + intros. apply T.elements_complete. apply List.in_rev. auto. + unfold l'; rewrite List.map_rev. apply list_norepet_rev. apply T.elements_keys_norepet. } + unfold l', f' in X; rewrite fold_left_rev_right in X. + rewrite T.fold_spec. apply X. + intros; simpl. rewrite <- List.in_rev. + split. apply T.elements_complete. apply T.elements_correct. +Defined. + +End TREE_FOLD_IND. + +Section TREE_FOLD_REC. + +Variables V A: Type. +Variable f: A -> T.elt -> V -> A. +Variable P: T.t V -> A -> Prop. +Variable init: A. +Variable m_final: T.t V. + +Hypothesis P_compat: + forall m m' a, + (forall x, T.get x m = T.get x m') -> + P m a -> P m' a. + +Hypothesis H_base: + P (T.empty _) init. + +Hypothesis H_rec: + forall m a k v, + T.get k m = None -> T.get k m_final = Some v -> P m a -> P (T.set k v m) (f a k v). Theorem fold_rec: P m_final (T.fold f m_final init). Proof. - intros. rewrite T.fold_spec. fold f'. - assert (P' (nil ++ T.elements m_final) (List.fold_left f' (T.elements m_final) init)). - apply fold_rec_aux. - simpl. red; intros; tauto. - simpl. red; intros. elim H0. - apply T.elements_keys_norepet. - apply H_base'. - simpl in H. red in H. apply H. red; intros. tauto. + apply fold_ind. +- intros. apply P_compat with (T.empty V); auto. + + intros. rewrite T.gempty. auto. +- intros. apply P_compat with (T.set k v (T.remove k m)). + + intros. rewrite T.gsspec, T.grspec. destruct (T.elt_eq x k); auto. congruence. + + apply H_rec; auto. apply T.grs. Qed. -End TREE_FOLD_IND. +End TREE_FOLD_REC. (** A nonnegative measure over trees *) @@ -1395,7 +1415,7 @@ Theorem cardinal_remove: Proof. unfold cardinal; intros. exploit T.elements_remove; eauto. intros (l1 & l2 & P & Q). - rewrite P, Q. rewrite ! app_length. simpl. omega. + rewrite P, Q. rewrite ! app_length. simpl. lia. Qed. Theorem cardinal_set: diff --git a/lib/Ordered.v b/lib/Ordered.v index 1adbd330..d02892ce 100644 --- a/lib/Ordered.v +++ b/lib/Ordered.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -70,7 +71,7 @@ Proof (@eq_trans t). Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. Proof Z.lt_trans. Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. -Proof. unfold lt, eq, t; intros. omega. Qed. +Proof. unfold lt, eq, t; intros. lia. Qed. Lemma compare : forall x y : t, Compare lt eq x y. Proof. intros. destruct (Z.compare x y) as [] eqn:E. @@ -99,11 +100,11 @@ Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. Proof (@eq_trans t). Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. Proof. - unfold lt; intros. omega. + unfold lt; intros. lia. Qed. Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. Proof. - unfold lt,eq; intros; red; intros. subst. omega. + unfold lt,eq; intros; red; intros. subst. lia. Qed. Lemma compare : forall x y : t, Compare lt eq x y. Proof. @@ -114,7 +115,7 @@ Proof. apply GT. assert (Int.unsigned x <> Int.unsigned y). red; intros. rewrite <- (Int.repr_unsigned x) in n. rewrite <- (Int.repr_unsigned y) in n. congruence. - red. omega. + red. lia. Defined. Definition eq_dec : forall x y, { eq x y } + { ~ eq x y } := Int.eq_dec. diff --git a/lib/Parmov.v b/lib/Parmov.v index db27e83f..d7cab86a 100644 --- a/lib/Parmov.v +++ b/lib/Parmov.v @@ -8,10 +8,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -1106,7 +1107,7 @@ Lemma measure_decreasing_1: forall st st', dtransition st st' -> measure st' < measure st. Proof. - induction 1; repeat (simpl; rewrite List.app_length); simpl; omega. + induction 1; repeat (simpl; rewrite List.app_length); simpl; lia. Qed. Lemma measure_decreasing_2: diff --git a/lib/Postorder.v b/lib/Postorder.v index 3181c4cc..0be7d0b4 100644 --- a/lib/Postorder.v +++ b/lib/Postorder.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -314,10 +315,10 @@ Proof. destruct (wrk s) as [ | [x succs] l]. discriminate. destruct succs as [ | y succs ]. - inv H. simpl. apply lex_ord_right. omega. + inv H. simpl. apply lex_ord_right. lia. destruct ((gr s)!y) as [succs'|] eqn:?. inv H. simpl. apply lex_ord_left. eapply PTree_Properties.cardinal_remove; eauto. - inv H. simpl. apply lex_ord_right. omega. + inv H. simpl. apply lex_ord_right. lia. Qed. End POSTORDER. diff --git a/lib/Printlines.ml b/lib/Printlines.ml index 453096bc..135672cc 100644 --- a/lib/Printlines.ml +++ b/lib/Printlines.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/lib/Printlines.mli b/lib/Printlines.mli index 545eb033..ec4a1040 100644 --- a/lib/Printlines.mli +++ b/lib/Printlines.mli @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/lib/Readconfig.mli b/lib/Readconfig.mli index c81e7786..9e3e03d5 100644 --- a/lib/Readconfig.mli +++ b/lib/Readconfig.mli @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/lib/Readconfig.mll b/lib/Readconfig.mll index 8abcc407..9d5b692b 100644 --- a/lib/Readconfig.mll +++ b/lib/Readconfig.mll @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/lib/Responsefile.mli b/lib/Responsefile.mli index ada5a15d..84a58971 100644 --- a/lib/Responsefile.mli +++ b/lib/Responsefile.mli @@ -7,10 +7,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/lib/Responsefile.mll b/lib/Responsefile.mll index 35a2dbdb..430c6b4e 100644 --- a/lib/Responsefile.mll +++ b/lib/Responsefile.mll @@ -7,10 +7,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/lib/Tokenize.mli b/lib/Tokenize.mli index a9f22c4d..f119dcfa 100644 --- a/lib/Tokenize.mli +++ b/lib/Tokenize.mli @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/lib/Tokenize.mll b/lib/Tokenize.mll index 70e21d55..bd0f433b 100644 --- a/lib/Tokenize.mll +++ b/lib/Tokenize.mll @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/lib/UnionFind.v b/lib/UnionFind.v index 20bb91cd..1bc2f657 100644 --- a/lib/UnionFind.v +++ b/lib/UnionFind.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -20,6 +21,7 @@ Require Import Coqlib. Open Scope nat_scope. Set Implicit Arguments. +Set Asymmetric Patterns. (* To avoid useless definitions of inductors in extracted code. *) Local Unset Elimination Schemes. @@ -552,10 +554,10 @@ Proof. rewrite H; auto. simpl in G. rewrite M.gsspec in G. destruct (M.elt_eq x0 (repr uf a)). rewrite e. rewrite repr_canonical. rewrite dec_eq_true. inversion G. subst x'. rewrite dec_eq_false; auto. - replace (pathlen uf (repr uf a)) with 0. omega. + replace (pathlen uf (repr uf a)) with 0. lia. symmetry. apply pathlen_none. apply repr_res_none. rewrite (repr_unroll uf x0), (pathlen_unroll uf x0); rewrite G. - destruct (M.elt_eq (repr uf x') (repr uf a)); omega. + destruct (M.elt_eq (repr uf x') (repr uf a)); lia. simpl in G. rewrite M.gsspec in G. destruct (M.elt_eq x0 (repr uf a)); try discriminate. rewrite (repr_none uf x0) by auto. rewrite dec_eq_false; auto. symmetry. apply pathlen_zero; auto. apply repr_none; auto. @@ -570,7 +572,7 @@ Proof. intros. repeat rewrite pathlen_merge. destruct (M.elt_eq (repr uf a) (repr uf b)). auto. rewrite H. destruct (M.elt_eq (repr uf y) (repr uf a)). - omega. auto. + lia. auto. Qed. (* Path compression *) diff --git a/lib/Wfsimpl.v b/lib/Wfsimpl.v index a1e4b4ff..6e52cd36 100644 --- a/lib/Wfsimpl.v +++ b/lib/Wfsimpl.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/lib/Zbits.v b/lib/Zbits.v index 6f3acaab..f6dc0c9d 100644 --- a/lib/Zbits.v +++ b/lib/Zbits.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -33,7 +34,7 @@ Definition eqmod (x y: Z) : Prop := exists k, x = k * modul + y. Lemma eqmod_refl: forall x, eqmod x x. Proof. - intros; red. exists 0. omega. + intros; red. exists 0. lia. Qed. Lemma eqmod_refl2: forall x y, x = y -> eqmod x y. @@ -57,7 +58,7 @@ Lemma eqmod_small_eq: Proof. intros x y [k EQ] I1 I2. generalize (Zdiv_unique _ _ _ _ EQ I2). intro. - rewrite (Z.div_small x modul I1) in H. subst k. omega. + rewrite (Z.div_small x modul I1) in H. subst k. lia. Qed. Lemma eqmod_mod_eq: @@ -136,11 +137,11 @@ Lemma P_mod_two_p_range: forall n p, 0 <= P_mod_two_p p n < two_power_nat n. Proof. induction n; simpl; intros. - - rewrite two_power_nat_O. omega. + - rewrite two_power_nat_O. lia. - rewrite two_power_nat_S. destruct p. - + generalize (IHn p). rewrite Z.succ_double_spec. omega. - + generalize (IHn p). rewrite Z.double_spec. omega. - + generalize (two_power_nat_pos n). omega. + + generalize (IHn p). rewrite Z.succ_double_spec. lia. + + generalize (IHn p). rewrite Z.double_spec. lia. + + generalize (two_power_nat_pos n). lia. Qed. Lemma P_mod_two_p_eq: @@ -157,7 +158,7 @@ Proof. + destruct (IHn p) as [y EQ]. exists y. change (Zpos p~0) with (2 * Zpos p). rewrite EQ. rewrite (Z.double_spec (P_mod_two_p p n)). ring. - + exists 0; omega. + + exists 0; lia. } intros. destruct (H n p) as [y EQ]. @@ -221,8 +222,8 @@ Remark Zshiftin_spec: forall b x, Zshiftin b x = 2 * x + (if b then 1 else 0). Proof. unfold Zshiftin; intros. destruct b. - - rewrite Z.succ_double_spec. omega. - - rewrite Z.double_spec. omega. + - rewrite Z.succ_double_spec. lia. + - rewrite Z.double_spec. lia. Qed. Remark Zshiftin_inj: @@ -231,10 +232,10 @@ Remark Zshiftin_inj: Proof. intros. rewrite !Zshiftin_spec in H. destruct b1; destruct b2. - split; [auto|omega]. - omegaContradiction. - omegaContradiction. - split; [auto|omega]. + split; [auto|lia]. + extlia. + extlia. + split; [auto|lia]. Qed. Remark Zdecomp: @@ -255,9 +256,9 @@ Proof. - subst n. destruct b. + apply Z.testbit_odd_0. + rewrite Z.add_0_r. apply Z.testbit_even_0. - - assert (0 <= Z.pred n) by omega. + - assert (0 <= Z.pred n) by lia. set (n' := Z.pred n) in *. - replace n with (Z.succ n') by (unfold n'; omega). + replace n with (Z.succ n') by (unfold n'; lia). destruct b. + apply Z.testbit_odd_succ; auto. + rewrite Z.add_0_r. apply Z.testbit_even_succ; auto. @@ -273,7 +274,7 @@ Remark Ztestbit_shiftin_succ: forall b x n, 0 <= n -> Z.testbit (Zshiftin b x) (Z.succ n) = Z.testbit x n. Proof. intros. rewrite Ztestbit_shiftin. rewrite zeq_false. rewrite Z.pred_succ. auto. - omega. omega. + lia. lia. Qed. Lemma Zshiftin_ind: @@ -287,7 +288,7 @@ Proof. - induction p. + change (P (Zshiftin true (Z.pos p))). auto. + change (P (Zshiftin false (Z.pos p))). auto. - + change (P (Zshiftin true 0)). apply H0. omega. auto. + + change (P (Zshiftin true 0)). apply H0. lia. auto. - compute in H1. intuition congruence. Qed. @@ -323,7 +324,7 @@ Remark Ztestbit_succ: forall n x, 0 <= n -> Z.testbit x (Z.succ n) = Z.testbit (Z.div2 x) n. Proof. intros. rewrite Ztestbit_eq. rewrite zeq_false. rewrite Z.pred_succ. auto. - omega. omega. + lia. lia. Qed. Lemma eqmod_same_bits: @@ -335,13 +336,13 @@ Proof. - change (two_power_nat 0) with 1. exists (x-y); ring. - rewrite two_power_nat_S. assert (eqmod (two_power_nat n) (Z.div2 x) (Z.div2 y)). - apply IHn. intros. rewrite <- !Ztestbit_succ. apply H. rewrite Nat2Z.inj_succ; omega. - omega. omega. + apply IHn. intros. rewrite <- !Ztestbit_succ. apply H. rewrite Nat2Z.inj_succ; lia. + lia. lia. destruct H0 as [k EQ]. exists k. rewrite (Zdecomp x). rewrite (Zdecomp y). replace (Z.odd y) with (Z.odd x). rewrite EQ. rewrite !Zshiftin_spec. ring. - exploit (H 0). rewrite Nat2Z.inj_succ; omega. + exploit (H 0). rewrite Nat2Z.inj_succ; lia. rewrite !Ztestbit_base. auto. Qed. @@ -351,7 +352,7 @@ Lemma same_bits_eqmod: Z.testbit x i = Z.testbit y i. Proof. induction n; intros. - - simpl in H0. omegaContradiction. + - simpl in H0. extlia. - rewrite Nat2Z.inj_succ in H0. rewrite two_power_nat_S in H. rewrite !(Ztestbit_eq i); intuition. destruct H as [k EQ]. @@ -364,7 +365,7 @@ Proof. exploit Zshiftin_inj; eauto. intros [A B]. destruct (zeq i 0). + auto. - + apply IHn. exists k; auto. omega. + + apply IHn. exists k; auto. lia. Qed. Lemma equal_same_bits: @@ -383,7 +384,7 @@ Proof. replace (- Zshiftin (Z.odd x) y - 1) with (Zshiftin (negb (Z.odd x)) (- y - 1)). rewrite !Ztestbit_shiftin; auto. - destruct (zeq i 0). auto. apply IND. omega. + destruct (zeq i 0). auto. apply IND. lia. rewrite !Zshiftin_spec. destruct (Z.odd x); simpl negb; ring. Qed. @@ -395,12 +396,12 @@ Lemma Ztestbit_above: Proof. induction n; intros. - change (two_power_nat 0) with 1 in H. - replace x with 0 by omega. + replace x with 0 by lia. apply Z.testbit_0_l. - rewrite Nat2Z.inj_succ in H0. rewrite Ztestbit_eq. rewrite zeq_false. apply IHn. rewrite two_power_nat_S in H. rewrite (Zdecomp x) in H. - rewrite Zshiftin_spec in H. destruct (Z.odd x); omega. - omega. omega. omega. + rewrite Zshiftin_spec in H. destruct (Z.odd x); lia. + lia. lia. lia. Qed. Lemma Ztestbit_above_neg: @@ -412,10 +413,10 @@ Proof. intros. set (y := -x-1). assert (Z.testbit y i = false). apply Ztestbit_above with n. - unfold y; omega. auto. + unfold y; lia. auto. unfold y in H1. rewrite Z_one_complement in H1. change true with (negb false). rewrite <- H1. rewrite negb_involutive; auto. - omega. + lia. Qed. Lemma Zsign_bit: @@ -425,16 +426,16 @@ Lemma Zsign_bit: Proof. induction n; intros. - change (two_power_nat 1) with 2 in H. - assert (x = 0 \/ x = 1) by omega. + assert (x = 0 \/ x = 1) by lia. destruct H0; subst x; reflexivity. - rewrite Nat2Z.inj_succ. rewrite Ztestbit_eq. rewrite zeq_false. rewrite Z.pred_succ. rewrite IHn. rewrite two_power_nat_S. destruct (zlt (Z.div2 x) (two_power_nat n)); rewrite (Zdecomp x); rewrite Zshiftin_spec. - rewrite zlt_true. auto. destruct (Z.odd x); omega. - rewrite zlt_false. auto. destruct (Z.odd x); omega. + rewrite zlt_true. auto. destruct (Z.odd x); lia. + rewrite zlt_false. auto. destruct (Z.odd x); lia. rewrite (Zdecomp x) in H; rewrite Zshiftin_spec in H. - rewrite two_power_nat_S in H. destruct (Z.odd x); omega. - omega. omega. + rewrite two_power_nat_S in H. destruct (Z.odd x); lia. + lia. lia. Qed. Lemma Ztestbit_le: @@ -444,16 +445,16 @@ Lemma Ztestbit_le: x <= y. Proof. intros x y0 POS0; revert x; pattern y0; apply Zshiftin_ind; auto; intros. - - replace x with 0. omega. apply equal_same_bits; intros. + - replace x with 0. lia. apply equal_same_bits; intros. rewrite Ztestbit_0. destruct (Z.testbit x i) as [] eqn:E; auto. exploit H; eauto. rewrite Ztestbit_0. auto. - assert (Z.div2 x0 <= x). { apply H0. intros. exploit (H1 (Z.succ i)). - omega. rewrite Ztestbit_succ; auto. rewrite Ztestbit_shiftin_succ; auto. + lia. rewrite Ztestbit_succ; auto. rewrite Ztestbit_shiftin_succ; auto. } rewrite (Zdecomp x0). rewrite !Zshiftin_spec. - destruct (Z.odd x0) as [] eqn:E1; destruct b as [] eqn:E2; try omega. - exploit (H1 0). omega. rewrite Ztestbit_base; auto. + destruct (Z.odd x0) as [] eqn:E1; destruct b as [] eqn:E2; try lia. + exploit (H1 0). lia. rewrite Ztestbit_base; auto. rewrite Ztestbit_shiftin_base. congruence. Qed. @@ -464,16 +465,16 @@ Lemma Ztestbit_mod_two_p: Proof. intros n0 x i N0POS. revert x i; pattern n0; apply natlike_ind; auto. - intros. change (two_p 0) with 1. rewrite Zmod_1_r. rewrite Z.testbit_0_l. - rewrite zlt_false; auto. omega. + rewrite zlt_false; auto. lia. - intros. rewrite two_p_S; auto. replace (x0 mod (2 * two_p x)) with (Zshiftin (Z.odd x0) (Z.div2 x0 mod two_p x)). rewrite Ztestbit_shiftin; auto. rewrite (Ztestbit_eq i x0); auto. destruct (zeq i 0). - + rewrite zlt_true; auto. omega. + + rewrite zlt_true; auto. lia. + rewrite H0. destruct (zlt (Z.pred i) x). - * rewrite zlt_true; auto. omega. - * rewrite zlt_false; auto. omega. - * omega. + * rewrite zlt_true; auto. lia. + * rewrite zlt_false; auto. lia. + * lia. + rewrite (Zdecomp x0) at 3. set (x1 := Z.div2 x0). symmetry. apply Zmod_unique with (x1 / two_p x). rewrite !Zshiftin_spec. rewrite Z.add_assoc. f_equal. @@ -481,7 +482,7 @@ Proof. f_equal. apply Z_div_mod_eq. apply two_p_gt_ZERO; auto. ring. rewrite Zshiftin_spec. exploit (Z_mod_lt x1 (two_p x)). apply two_p_gt_ZERO; auto. - destruct (Z.odd x0); omega. + destruct (Z.odd x0); lia. Qed. Corollary Ztestbit_two_p_m1: @@ -491,7 +492,7 @@ Proof. intros. replace (two_p n - 1) with ((-1) mod (two_p n)). rewrite Ztestbit_mod_two_p; auto. destruct (zlt i n); auto. apply Ztestbit_m1; auto. apply Zmod_unique with (-1). ring. - exploit (two_p_gt_ZERO n). auto. omega. + exploit (two_p_gt_ZERO n). auto. lia. Qed. Corollary Ztestbit_neg_two_p: @@ -499,7 +500,7 @@ Corollary Ztestbit_neg_two_p: Z.testbit (- (two_p n)) i = if zlt i n then false else true. Proof. intros. - replace (- two_p n) with (- (two_p n - 1) - 1) by omega. + replace (- two_p n) with (- (two_p n - 1) - 1) by lia. rewrite Z_one_complement by auto. rewrite Ztestbit_two_p_m1 by auto. destruct (zlt i n); auto. @@ -516,16 +517,16 @@ Proof. rewrite (Zdecomp x) in *. rewrite (Zdecomp y) in *. transitivity (Z.testbit (Zshiftin (Z.odd x || Z.odd y) (Z.div2 x + Z.div2 y)) i). - f_equal. rewrite !Zshiftin_spec. - exploit (EXCL 0). omega. rewrite !Ztestbit_shiftin_base. intros. + exploit (EXCL 0). lia. rewrite !Ztestbit_shiftin_base. intros. Opaque Z.mul. destruct (Z.odd x); destruct (Z.odd y); simpl in *; discriminate || ring. - rewrite !Ztestbit_shiftin; auto. destruct (zeq i 0). + auto. - + apply IND. omega. intros. - exploit (EXCL (Z.succ j)). omega. + + apply IND. lia. intros. + exploit (EXCL (Z.succ j)). lia. rewrite !Ztestbit_shiftin_succ. auto. - omega. omega. + lia. lia. Qed. (** ** Zero and sign extensions *) @@ -583,8 +584,8 @@ Lemma Znatlike_ind: forall n, P n. Proof. intros. destruct (zle 0 n). - apply natlike_ind; auto. apply H; omega. - apply H. omega. + apply natlike_ind; auto. apply H; lia. + apply H. lia. Qed. Lemma Zzero_ext_spec: @@ -593,16 +594,16 @@ Lemma Zzero_ext_spec: Proof. unfold Zzero_ext. induction n using Znatlike_ind. - intros. rewrite Ziter_base; auto. - rewrite zlt_false. rewrite Ztestbit_0; auto. omega. + rewrite zlt_false. rewrite Ztestbit_0; auto. lia. - intros. rewrite Ziter_succ; auto. rewrite Ztestbit_shiftin; auto. rewrite (Ztestbit_eq i x); auto. destruct (zeq i 0). - + subst i. rewrite zlt_true; auto. omega. + + subst i. rewrite zlt_true; auto. lia. + rewrite IHn. destruct (zlt (Z.pred i) n). - rewrite zlt_true; auto. omega. - rewrite zlt_false; auto. omega. - omega. + rewrite zlt_true; auto. lia. + rewrite zlt_false; auto. lia. + lia. Qed. Lemma Zsign_ext_spec: @@ -611,29 +612,29 @@ Lemma Zsign_ext_spec: Proof. intros n0 x i I0. unfold Zsign_ext. unfold proj_sumbool; destruct (zlt 0 n0) as [N0|N0]; simpl. -- revert x i I0. pattern n0. apply Zlt_lower_bound_ind with (z := 1); [ | omega ]. +- revert x i I0. pattern n0. apply Zlt_lower_bound_ind with (z := 1); [ | lia ]. unfold Zsign_ext. intros. destruct (zeq x 1). + subst x; simpl. replace (if zlt i 1 then i else 0) with 0. rewrite Ztestbit_base. destruct (Z.odd x0); [ apply Ztestbit_m1; auto | apply Ztestbit_0 ]. - destruct (zlt i 1); omega. - + set (x1 := Z.pred x). replace x1 with (Z.succ (Z.pred x1)) by omega. - rewrite Ziter_succ by (unfold x1; omega). rewrite Ztestbit_shiftin by auto. + destruct (zlt i 1); lia. + + set (x1 := Z.pred x). replace x1 with (Z.succ (Z.pred x1)) by lia. + rewrite Ziter_succ by (unfold x1; lia). rewrite Ztestbit_shiftin by auto. destruct (zeq i 0). - * subst i. rewrite zlt_true. rewrite Ztestbit_base; auto. omega. - * rewrite H by (unfold x1; omega). + * subst i. rewrite zlt_true. rewrite Ztestbit_base; auto. lia. + * rewrite H by (unfold x1; lia). unfold x1; destruct (zlt (Z.pred i) (Z.pred x)). - ** rewrite zlt_true by omega. - rewrite (Ztestbit_eq i x0) by omega. - rewrite zeq_false by omega. auto. - ** rewrite zlt_false by omega. - rewrite (Ztestbit_eq (x - 1) x0) by omega. - rewrite zeq_false by omega. auto. -- rewrite Ziter_base by omega. rewrite andb_false_r. + ** rewrite zlt_true by lia. + rewrite (Ztestbit_eq i x0) by lia. + rewrite zeq_false by lia. auto. + ** rewrite zlt_false by lia. + rewrite (Ztestbit_eq (x - 1) x0) by lia. + rewrite zeq_false by lia. auto. +- rewrite Ziter_base by lia. rewrite andb_false_r. rewrite Z.testbit_0_l, Z.testbit_neg_r. auto. - destruct (zlt i n0); omega. + destruct (zlt i n0); lia. Qed. (** [Zzero_ext n x] is [x modulo 2^n] *) @@ -650,14 +651,14 @@ Qed. Lemma Zzero_ext_range: forall n x, 0 <= n -> 0 <= Zzero_ext n x < two_p n. Proof. - intros. rewrite Zzero_ext_mod; auto. apply Z_mod_lt. apply two_p_gt_ZERO. omega. + intros. rewrite Zzero_ext_mod; auto. apply Z_mod_lt. apply two_p_gt_ZERO. lia. Qed. Lemma eqmod_Zzero_ext: forall n x, 0 <= n -> eqmod (two_p n) (Zzero_ext n x) x. Proof. intros. rewrite Zzero_ext_mod; auto. apply eqmod_sym. apply eqmod_mod. - apply two_p_gt_ZERO. omega. + apply two_p_gt_ZERO. lia. Qed. (** Relation between [Zsign_ext n x] and (Zzero_ext n x] *) @@ -670,13 +671,13 @@ Proof. rewrite Zsign_ext_spec by auto. destruct (Z.testbit x (n - 1)) eqn:SIGNBIT. - set (n' := - two_p n). - replace (Zzero_ext n x - two_p n) with (Zzero_ext n x + n') by (unfold n'; omega). + replace (Zzero_ext n x - two_p n) with (Zzero_ext n x + n') by (unfold n'; lia). rewrite Z_add_is_or; auto. - rewrite Zzero_ext_spec by auto. unfold n'; rewrite Ztestbit_neg_two_p by omega. + rewrite Zzero_ext_spec by auto. unfold n'; rewrite Ztestbit_neg_two_p by lia. destruct (zlt i n). rewrite orb_false_r; auto. auto. - intros. rewrite Zzero_ext_spec by omega. unfold n'; rewrite Ztestbit_neg_two_p by omega. + intros. rewrite Zzero_ext_spec by lia. unfold n'; rewrite Ztestbit_neg_two_p by lia. destruct (zlt j n); auto using andb_false_r. -- replace (Zzero_ext n x - 0) with (Zzero_ext n x) by omega. +- replace (Zzero_ext n x - 0) with (Zzero_ext n x) by lia. rewrite Zzero_ext_spec by auto. destruct (zlt i n); auto. Qed. @@ -688,20 +689,20 @@ Lemma Zsign_ext_range: forall n x, 0 < n -> -two_p (n-1) <= Zsign_ext n x < two_p (n-1). Proof. intros. - assert (A: 0 <= Zzero_ext n x < two_p n) by (apply Zzero_ext_range; omega). + assert (A: 0 <= Zzero_ext n x < two_p n) by (apply Zzero_ext_range; lia). assert (B: Z.testbit (Zzero_ext n x) (n - 1) = if zlt (Zzero_ext n x) (two_p (n - 1)) then false else true). { set (N := Z.to_nat (n - 1)). generalize (Zsign_bit N (Zzero_ext n x)). rewrite ! two_power_nat_two_p. - rewrite inj_S. unfold N; rewrite Z2Nat.id by omega. - intros X; apply X. replace (Z.succ (n - 1)) with n by omega. exact A. + rewrite inj_S. unfold N; rewrite Z2Nat.id by lia. + intros X; apply X. replace (Z.succ (n - 1)) with n by lia. exact A. } assert (C: two_p n = 2 * two_p (n - 1)). - { rewrite <- two_p_S by omega. f_equal; omega. } - rewrite Zzero_ext_spec, zlt_true in B by omega. - rewrite Zsign_ext_zero_ext by omega. rewrite B. - destruct (zlt (Zzero_ext n x) (two_p (n - 1))); omega. + { rewrite <- two_p_S by lia. f_equal; lia. } + rewrite Zzero_ext_spec, zlt_true in B by lia. + rewrite Zsign_ext_zero_ext by lia. rewrite B. + destruct (zlt (Zzero_ext n x) (two_p (n - 1))); lia. Qed. Lemma eqmod_Zsign_ext: @@ -711,9 +712,9 @@ Proof. intros. rewrite Zsign_ext_zero_ext by auto. apply eqmod_trans with (x - 0). apply eqmod_sub. - apply eqmod_Zzero_ext; omega. + apply eqmod_Zzero_ext; lia. exists (if Z.testbit x (n - 1) then 1 else 0). destruct (Z.testbit x (n - 1)); ring. - apply eqmod_refl2; omega. + apply eqmod_refl2; lia. Qed. (** ** Decomposition of a number as a sum of powers of two. *) @@ -743,19 +744,19 @@ Proof. { induction n; intros. simpl. rewrite two_power_nat_O in H0. - assert (x = 0) by omega. subst x. omega. + assert (x = 0) by lia. subst x. lia. rewrite two_power_nat_S in H0. simpl Z_one_bits. rewrite (Zdecomp x) in H0. rewrite Zshiftin_spec in H0. assert (EQ: Z.div2 x * two_p (i + 1) = powerserie (Z_one_bits n (Z.div2 x) (i + 1))). - apply IHn. omega. - destruct (Z.odd x); omega. + apply IHn. lia. + destruct (Z.odd x); lia. rewrite two_p_is_exp in EQ. change (two_p 1) with 2 in EQ. rewrite (Zdecomp x) at 1. rewrite Zshiftin_spec. destruct (Z.odd x); simpl powerserie; rewrite <- EQ; ring. - omega. omega. + lia. lia. } - intros. rewrite <- H. change (two_p 0) with 1. omega. - omega. exact H0. + intros. rewrite <- H. change (two_p 0) with 1. lia. + lia. exact H0. Qed. Lemma Z_one_bits_range: @@ -768,12 +769,12 @@ Proof. tauto. intros x i j. rewrite Nat2Z.inj_succ. assert (In j (Z_one_bits n (Z.div2 x) (i + 1)) -> i <= j < i + Z.succ (Z.of_nat n)). - intros. exploit IHn; eauto. omega. + intros. exploit IHn; eauto. lia. destruct (Z.odd x); simpl. - intros [A|B]. subst j. omega. auto. + intros [A|B]. subst j. lia. auto. auto. } - intros. generalize (H n x 0 i H0). omega. + intros. generalize (H n x 0 i H0). lia. Qed. Remark Z_one_bits_zero: @@ -787,15 +788,15 @@ Remark Z_one_bits_two_p: 0 <= x < Z.of_nat n -> Z_one_bits n (two_p x) i = (i + x) :: nil. Proof. - induction n; intros; simpl. simpl in H. omegaContradiction. + induction n; intros; simpl. simpl in H. extlia. rewrite Nat2Z.inj_succ in H. - assert (x = 0 \/ 0 < x) by omega. destruct H0. - subst x; simpl. decEq. omega. apply Z_one_bits_zero. + assert (x = 0 \/ 0 < x) by lia. destruct H0. + subst x; simpl. decEq. lia. apply Z_one_bits_zero. assert (Z.odd (two_p x) = false /\ Z.div2 (two_p x) = two_p (x-1)). apply Zshiftin_inj. rewrite <- Zdecomp. rewrite !Zshiftin_spec. - rewrite <- two_p_S. rewrite Z.add_0_r. f_equal; omega. omega. + rewrite <- two_p_S. rewrite Z.add_0_r. f_equal; lia. lia. destruct H1 as [A B]; rewrite A; rewrite B. - rewrite IHn. f_equal; omega. omega. + rewrite IHn. f_equal; lia. lia. Qed. (** ** Recognition of powers of two *) @@ -820,7 +821,7 @@ Proof. induction p; simpl P_is_power2; intros. - discriminate. - change (Z.pos p~0) with (2 * Z.pos p). apply IHp in H. - rewrite Z.log2_double by xomega. rewrite two_p_S. congruence. + rewrite Z.log2_double by extlia. rewrite two_p_S. congruence. apply Z.log2_nonneg. - reflexivity. Qed. @@ -848,7 +849,7 @@ Proof. intros. assert (x <> 0) by (red; intros; subst x; discriminate). apply Z_is_power2_sound in H1. destruct H1 as [P Q]. subst i. - split. apply Z.log2_nonneg. apply Z.log2_lt_pow2. omega. rewrite <- two_p_equiv; tauto. + split. apply Z.log2_nonneg. apply Z.log2_lt_pow2. lia. rewrite <- two_p_equiv; tauto. Qed. Lemma Z_is_power2_complete: @@ -858,11 +859,11 @@ Opaque Z.log2. assert (A: forall x i, Z_is_power2 x = Some i -> Z_is_power2 (2 * x) = Some (Z.succ i)). { destruct x; simpl; intros; try discriminate. change (2 * Z.pos p) with (Z.pos (xO p)); simpl. - destruct (P_is_power2 p); inv H. rewrite <- Z.log2_double by xomega. auto. + destruct (P_is_power2 p); inv H. rewrite <- Z.log2_double by extlia. auto. } induction i using Znatlike_ind; intros. -- replace i with 0 by omega. reflexivity. -- rewrite two_p_S by omega. apply A. apply IHi; omega. +- replace i with 0 by lia. reflexivity. +- rewrite two_p_S by lia. apply A. apply IHi; lia. Qed. Definition Z_is_power2m1 (x: Z) : option Z := Z_is_power2 (Z.succ x). @@ -876,13 +877,13 @@ Qed. Lemma Z_is_power2m1_sound: forall x i, Z_is_power2m1 x = Some i -> x = two_p i - 1. Proof. - unfold Z_is_power2m1; intros. apply Z_is_power2_sound in H. omega. + unfold Z_is_power2m1; intros. apply Z_is_power2_sound in H. lia. Qed. Lemma Z_is_power2m1_complete: forall i, 0 <= i -> Z_is_power2m1 (two_p i - 1) = Some i. Proof. - intros. unfold Z_is_power2m1. replace (Z.succ (two_p i - 1)) with (two_p i) by omega. + intros. unfold Z_is_power2m1. replace (Z.succ (two_p i - 1)) with (two_p i) by lia. apply Z_is_power2_complete; auto. Qed. @@ -891,8 +892,8 @@ Lemma Z_is_power2m1_range: 0 <= n -> 0 <= x < two_p n -> Z_is_power2m1 x = Some i -> 0 <= i <= n. Proof. intros. destruct (zeq x (two_p n - 1)). -- subst x. rewrite Z_is_power2m1_complete in H1 by auto. inv H1; omega. -- unfold Z_is_power2m1 in H1. apply (Z_is_power2_range n (Z.succ x) i) in H1; omega. +- subst x. rewrite Z_is_power2m1_complete in H1 by auto. inv H1; lia. +- unfold Z_is_power2m1 in H1. apply (Z_is_power2_range n (Z.succ x) i) in H1; lia. Qed. (** ** Relation between bitwise operations and multiplications / divisions by powers of 2 *) @@ -903,7 +904,7 @@ Lemma Zshiftl_mul_two_p: forall x n, 0 <= n -> Z.shiftl x n = x * two_p n. Proof. intros. destruct n; simpl. - - omega. + - lia. - pattern p. apply Pos.peano_ind. + change (two_power_pos 1) with 2. simpl. ring. + intros. rewrite Pos.iter_succ. rewrite H0. @@ -925,7 +926,7 @@ Proof. rewrite Pplus_one_succ_l. rewrite two_power_pos_is_exp. change (two_power_pos 1) with 2. rewrite Zdiv2_div. rewrite Z.mul_comm. apply Zdiv_Zdiv. - rewrite two_power_pos_nat. apply two_power_nat_pos. omega. + rewrite two_power_pos_nat. apply two_power_nat_pos. lia. - compute in H. congruence. Qed. @@ -938,12 +939,12 @@ Lemma Zquot_Zdiv: Proof. intros. destruct (zlt x 0). - symmetry. apply Zquot_unique_full with ((x + y - 1) mod y - (y - 1)). - + red. right; split. omega. + + red. right; split. lia. exploit (Z_mod_lt (x + y - 1) y); auto. - rewrite Z.abs_eq. omega. omega. + rewrite Z.abs_eq. lia. lia. + transitivity ((y * ((x + y - 1) / y) + (x + y - 1) mod y) - (y-1)). rewrite <- Z_div_mod_eq. ring. auto. ring. - - apply Zquot_Zdiv_pos; omega. + - apply Zquot_Zdiv_pos; lia. Qed. Lemma Zdiv_shift: @@ -953,8 +954,8 @@ Proof. intros. generalize (Z_div_mod_eq x y H). generalize (Z_mod_lt x y H). set (q := x / y). set (r := x mod y). intros. destruct (zeq r 0). - apply Zdiv_unique with (y - 1). rewrite H1. rewrite e. ring. omega. - apply Zdiv_unique with (r - 1). rewrite H1. ring. omega. + apply Zdiv_unique with (y - 1). rewrite H1. rewrite e. ring. lia. + apply Zdiv_unique with (r - 1). rewrite H1. ring. lia. Qed. (** ** Size of integers, in bits. *) @@ -967,7 +968,7 @@ Definition Zsize (x: Z) : Z := Remark Zsize_pos: forall x, 0 <= Zsize x. Proof. - destruct x; simpl. omega. compute; intuition congruence. omega. + destruct x; simpl. lia. compute; intuition congruence. lia. Qed. Remark Zsize_pos': forall x, 0 < x -> 0 < Zsize x. @@ -991,8 +992,8 @@ Lemma Ztestbit_size_1: Proof. intros x0 POS0; pattern x0; apply Zshiftin_pos_ind; auto. intros. rewrite Zsize_shiftin; auto. - replace (Z.pred (Z.succ (Zsize x))) with (Z.succ (Z.pred (Zsize x))) by omega. - rewrite Ztestbit_shiftin_succ. auto. generalize (Zsize_pos' x H); omega. + replace (Z.pred (Z.succ (Zsize x))) with (Z.succ (Z.pred (Zsize x))) by lia. + rewrite Ztestbit_shiftin_succ. auto. generalize (Zsize_pos' x H); lia. Qed. Lemma Ztestbit_size_2: @@ -1002,12 +1003,12 @@ Proof. - subst x0; intros. apply Ztestbit_0. - pattern x0; apply Zshiftin_pos_ind. + simpl. intros. change 1 with (Zshiftin true 0). rewrite Ztestbit_shiftin. - rewrite zeq_false. apply Ztestbit_0. omega. omega. + rewrite zeq_false. apply Ztestbit_0. lia. lia. + intros. rewrite Zsize_shiftin in H1; auto. generalize (Zsize_pos' _ H); intros. - rewrite Ztestbit_shiftin. rewrite zeq_false. apply H0. omega. - omega. omega. - + omega. + rewrite Ztestbit_shiftin. rewrite zeq_false. apply H0. lia. + lia. lia. + + lia. Qed. Lemma Zsize_interval_1: @@ -1029,18 +1030,18 @@ Proof. assert (Z.of_nat N = n) by (apply Z2Nat.id; auto). rewrite <- H1 in H0. rewrite <- two_power_nat_two_p in H0. destruct (zeq x 0). - subst x; simpl; omega. + subst x; simpl; lia. destruct (zlt n (Zsize x)); auto. - exploit (Ztestbit_above N x (Z.pred (Zsize x))). auto. omega. - rewrite Ztestbit_size_1. congruence. omega. + exploit (Ztestbit_above N x (Z.pred (Zsize x))). auto. lia. + rewrite Ztestbit_size_1. congruence. lia. Qed. Lemma Zsize_monotone: forall x y, 0 <= x <= y -> Zsize x <= Zsize y. Proof. intros. apply Z.ge_le. apply Zsize_interval_2. apply Zsize_pos. - exploit (Zsize_interval_1 y). omega. - omega. + exploit (Zsize_interval_1 y). lia. + lia. Qed. (** ** Bit insertion, bit extraction *) @@ -1070,7 +1071,7 @@ Lemma Zextract_s_spec: Proof. unfold Zextract_s; intros. rewrite Zsign_ext_spec by auto. rewrite Z.shiftr_spec. rewrite Z.add_comm. auto. - destruct (zlt i len); omega. + destruct (zlt i len); lia. Qed. (** Insert bits [0...len-1] of [y] into bits [to...to+len-1] of [x] *) @@ -1092,10 +1093,10 @@ Proof. { intros; apply Ztestbit_two_p_m1; auto. } rewrite Z.lor_spec, Z.land_spec, Z.ldiff_spec by auto. destruct (zle to i). -- rewrite ! Z.shiftl_spec by auto. rewrite ! M by omega. +- rewrite ! Z.shiftl_spec by auto. rewrite ! M by lia. unfold proj_sumbool; destruct (zlt (i - to) len); simpl; rewrite andb_true_r, andb_false_r. -+ rewrite zlt_true by omega. apply orb_false_r. -+ rewrite zlt_false by omega; auto. -- rewrite ! Z.shiftl_spec_low by omega. simpl. apply andb_true_r. ++ rewrite zlt_true by lia. apply orb_false_r. ++ rewrite zlt_false by lia; auto. +- rewrite ! Z.shiftl_spec_low by lia. simpl. apply andb_true_r. Qed. diff --git a/powerpc/Archi.v b/powerpc/Archi.v index ae10c54c..28859051 100644 --- a/powerpc/Archi.v +++ b/powerpc/Archi.v @@ -7,10 +7,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/powerpc/Asm.v b/powerpc/Asm.v index 4fb38ff8..6b1f2232 100644 --- a/powerpc/Asm.v +++ b/powerpc/Asm.v @@ -200,12 +200,9 @@ Inductive instruction : Type := | Pfadd: freg -> freg -> freg -> instruction (**r float addition *) | Pfadds: freg -> freg -> freg -> instruction (**r float addition *) | Pfcmpu: freg -> freg -> instruction (**r float comparison *) - | Pfcfi: freg -> ireg -> instruction (**r signed-int-to-float conversion (pseudo, PPC64) *) | Pfcfl: freg -> ireg -> instruction (**r signed-long-to-float conversion (pseudo, PPC64) *) - | Pfcfiu: freg -> ireg -> instruction (**r unsigned-int-to-float conversion (pseudo, PPC64) *) | Pfcfid: freg -> freg -> instruction (**r signed-long-to-float conversion (PPC64) *) | Pfcti: ireg -> freg -> instruction (**r float-to-signed-int conversion, round towards 0 (pseudo) *) - | Pfctiu: ireg -> freg -> instruction (**r float-to-unsigned-int conversion, round towards 0 (pseudo, PPC64) *) | Pfctid: ireg -> freg -> instruction (**r float-to-signed-int conversion, round towards 0 (pseudo, PPC64) *) | Pfctidz: freg -> freg -> instruction (**r float-to-signed-long conversion, round towards 0 (PPC64) *) | Pfctiw: freg -> freg -> instruction (**r float-to-signed-int conversion, round by default *) @@ -541,6 +538,8 @@ Axiom small_data_area_addressing: Parameter symbol_is_rel_data: ident -> ptrofs -> bool. +Parameter symbol_is_aligned: ident -> Z -> bool. + (** Armed with the [low_half] and [high_half] functions, we can define the evaluation of a symbolic constant. Note that for [const_high], integer constants @@ -825,16 +824,10 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#rd <- (Val.addfs rs#r1 rs#r2))) m | Pfcmpu r1 r2 => Next (nextinstr (compare_float rs rs#r1 rs#r2)) m - | Pfcfi rd r1 => - Next (nextinstr (rs#rd <- (Val.maketotal (Val.floatofint rs#r1)))) m | Pfcfl rd r1 => Next (nextinstr (rs#rd <- (Val.maketotal (Val.floatoflong rs#r1)))) m - | Pfcfiu rd r1 => - Next (nextinstr (rs#rd <- (Val.maketotal (Val.floatofintu rs#r1)))) m | Pfcti rd r1 => Next (nextinstr (rs#FPR13 <- Vundef #rd <- (Val.maketotal (Val.intoffloat rs#r1)))) m - | Pfctiu rd r1 => - Next (nextinstr (rs#FPR13 <- Vundef #rd <- (Val.maketotal (Val.intuoffloat rs#r1)))) m | Pfctid rd r1 => Next (nextinstr (rs#FPR13 <- Vundef #rd <- (Val.maketotal (Val.longoffloat rs#r1)))) m | Pfdiv rd r1 r2 => @@ -1204,7 +1197,7 @@ Inductive step: state -> trace -> state -> Prop := external_call ef ge vargs m t vres m' -> rs' = nextinstr (set_res res vres - (undef_regs (map preg_of (destroyed_by_builtin ef)) rs)) -> + (undef_regs (IR GPR0 :: map preg_of (destroyed_by_builtin ef)) rs)) -> step (State rs m) t (State rs' m') | exec_step_external: forall b ef args res rs m t rs' m', @@ -1285,7 +1278,7 @@ Ltac Equalities := split. auto. intros. destruct B; auto. subst. auto. (* trace length *) red; intros. inv H; simpl. - omega. + lia. eapply external_call_trace_length; eauto. eapply external_call_trace_length; eauto. (* initial states *) diff --git a/powerpc/AsmToJSON.ml b/powerpc/AsmToJSON.ml index f4d4285a..09cfc28d 100644 --- a/powerpc/AsmToJSON.ml +++ b/powerpc/AsmToJSON.ml @@ -198,12 +198,9 @@ let pp_instructions pp ic = | Pfadd (fr1,fr2,fr3) -> instruction pp "Pfadd" [Freg fr1; Freg fr2; Freg fr3] | Pfadds (fr1,fr2,fr3) -> instruction pp "Pfadds" [Freg fr1; Freg fr2; Freg fr3] | Pfcmpu (fr1,fr2) -> instruction pp "Pfcmpu" [Freg fr1; Freg fr2] - | Pfcfi (ir,fr) | Pfcfl (ir,fr) -> assert false (* Should not occur *) | Pfcfid (fr1,fr2) -> instruction pp "Pfcfid" [Freg fr1; Freg fr2] - | Pfcfiu _ (* Should not occur *) | Pfcti _ (* Should not occur *) - | Pfctiu _ (* Should not occur *) | Pfctid _ -> assert false (* Should not occur *) | Pfctidz (fr1,fr2) -> instruction pp "Pfctidz" [Freg fr1; Freg fr2] | Pfctiw (fr1,fr2) -> instruction pp "Pfctiw" [Freg fr1; Freg fr2] diff --git a/powerpc/Asmexpand.ml b/powerpc/Asmexpand.ml index d8cbd94e..7efa80a6 100644 --- a/powerpc/Asmexpand.ml +++ b/powerpc/Asmexpand.ml @@ -58,6 +58,20 @@ let emit_loadimm r n = let emit_addimm rd rs n = List.iter emit (Asmgen.addimm rd rs n []) +let emit_aindexed mk1 mk2 unaligned r1 temp ofs = + List.iter emit (Asmgen.aindexed mk1 mk2 unaligned r1 temp ofs []) + +let emit_aindexed2 mk r1 r2 = + List.iter emit (Asmgen.aindexed2 mk r1 r2 []) + +let emit_aglobal mk1 mk2 unaligned temp symb ofs = + List.iter emit (Asmgen.aglobal mk1 mk2 unaligned temp symb ofs []) + +let emit_abased mk1 mk2 unaligned r1 temp symb ofs = + List.iter emit (Asmgen.abased mk1 mk2 unaligned r1 temp symb ofs []) + +let emit_ainstack mk1 mk2 unaligned temp ofs = + List.iter emit (Asmgen.ainstack mk1 mk2 unaligned temp ofs []) (* Numbering of bits in the CR register *) let num_crbit = function @@ -175,52 +189,23 @@ let expand_builtin_memcpy sz al args = (* Handling of volatile reads and writes *) let expand_volatile_access - (mk1: ireg -> constant -> unit) - (mk2: ireg -> ireg -> unit) + (mk1: constant -> ireg -> instruction list -> instruction list) + (mk2: ireg -> ireg -> instruction list -> instruction list) + ?(ofs_unaligned = true) addr temp = match addr with | BA(IR r) -> - mk1 r (Cint _0) + List.iter emit (mk1 (Cint _0) r []) | BA_addrstack ofs -> - if offset_in_range ofs then - mk1 GPR1 (Cint ofs) - else begin - emit (Paddis(temp, GPR1, Cint (Asmgen.high_s ofs))); - mk1 temp (Cint (Asmgen.low_s ofs)) - end + emit_ainstack mk1 mk2 ofs_unaligned temp ofs | BA_addrglobal(id, ofs) -> - if symbol_is_small_data id ofs then - mk1 GPR0 (Csymbol_sda(id, ofs)) - else if symbol_is_rel_data id ofs then begin - emit (Paddis(temp, GPR0, Csymbol_rel_high(id, ofs))); - emit (Paddi(temp, temp, Csymbol_rel_low(id, ofs))); - mk1 temp (Cint _0) - end else begin - emit (Paddis(temp, GPR0, Csymbol_high(id, ofs))); - mk1 temp (Csymbol_low(id, ofs)) - end + emit_aglobal mk1 mk2 ofs_unaligned temp id ofs | BA_addptr(BA(IR r), BA_int n) -> - if offset_in_range n then - mk1 r (Cint n) - else begin - emit (Paddis(temp, r, Cint (Asmgen.high_s n))); - mk1 temp (Cint (Asmgen.low_s n)) - end + emit_aindexed mk1 mk2 ofs_unaligned r temp n | BA_addptr(BA_addrglobal(id, ofs), BA(IR r)) -> - if symbol_is_small_data id ofs then begin - emit (Paddi(GPR0, GPR0, Csymbol_sda(id, ofs))); - mk2 r GPR0 - end else if symbol_is_rel_data id ofs then begin - emit (Pmr(GPR0, r)); - emit (Paddis(temp, GPR0, Csymbol_rel_high(id, ofs))); - emit (Paddi(temp, temp, Csymbol_rel_low(id, ofs))); - mk2 temp GPR0 - end else begin - emit (Paddis(temp, r, Csymbol_high(id, ofs))); - mk1 temp (Csymbol_low(id, ofs)) - end + emit_abased mk1 mk2 ofs_unaligned r temp id ofs | BA_addptr(BA(IR r1), BA(IR r2)) -> - mk2 r1 r2 + emit_aindexed2 mk2 r1 r2 | _ -> assert false @@ -233,68 +218,69 @@ let offset_constant cst delta = Some (Csymbol_sda(id, Int.add ofs delta)) | _ -> None -let expand_load_int64 hi lo base ofs_hi ofs_lo = +let expand_load_int64 hi lo base ofs_hi ofs_lo k = if hi <> base then begin - emit (Plwz(hi, ofs_hi, base)); - emit (Plwz(lo, ofs_lo, base)) + Plwz(hi, ofs_hi, base) :: + Plwz(lo, ofs_lo, base) :: k end else begin - emit (Plwz(lo, ofs_lo, base)); - emit (Plwz(hi, ofs_hi, base)) + Plwz(lo, ofs_lo, base) :: + Plwz(hi, ofs_hi, base) :: k end let expand_builtin_vload_1 chunk addr res = match chunk, res with | Mint8unsigned, BR(IR res) -> expand_volatile_access - (fun r c -> emit (Plbz(res, c, r))) - (fun r1 r2 -> emit (Plbzx(res, r1, r2))) + (fun c r k -> Plbz(res, c, r) :: k) + (fun r1 r2 k -> Plbzx(res, r1, r2) :: k) addr GPR11 | Mint8signed, BR(IR res) -> expand_volatile_access - (fun r c -> emit (Plbz(res, c, r)); emit (Pextsb(res, res))) - (fun r1 r2 -> emit (Plbzx(res, r1, r2)); emit (Pextsb(res, res))) + (fun c r k-> Plbz(res, c, r) :: Pextsb(res, res) :: k) + (fun r1 r2 k -> Plbzx(res, r1, r2) :: Pextsb(res, res) :: k) addr GPR11 | Mint16unsigned, BR(IR res) -> expand_volatile_access - (fun r c -> emit (Plhz(res, c, r))) - (fun r1 r2 -> emit (Plhzx(res, r1, r2))) + (fun c r k -> Plhz(res, c, r) :: k) + (fun r1 r2 k -> Plhzx(res, r1, r2) :: k) addr GPR11 | Mint16signed, BR(IR res) -> expand_volatile_access - (fun r c -> emit (Plha(res, c, r))) - (fun r1 r2 -> emit (Plhax(res, r1, r2))) + (fun c r k-> Plha(res, c, r) :: k) + (fun r1 r2 k -> Plhax(res, r1, r2) :: k) addr GPR11 | (Mint32 | Many32), BR(IR res) -> expand_volatile_access - (fun r c -> emit (Plwz(res, c, r))) - (fun r1 r2 -> emit (Plwzx(res, r1, r2))) + (fun c r k-> Plwz(res, c, r) :: k) + (fun r1 r2 k -> Plwzx(res, r1, r2) :: k) addr GPR11 | Mfloat32, BR(FR res) -> expand_volatile_access - (fun r c -> emit (Plfs(res, c, r))) - (fun r1 r2 -> emit (Plfsx(res, r1, r2))) + (fun c r k-> Plfs(res, c, r) :: k) + (fun r1 r2 k -> Plfsx(res, r1, r2) :: k) addr GPR11 | (Mfloat64 | Many64), BR(FR res) -> expand_volatile_access - (fun r c -> emit (Plfd(res, c, r))) - (fun r1 r2 -> emit (Plfdx(res, r1, r2))) + (fun c r k-> Plfd(res, c, r) :: k) + (fun r1 r2 k -> Plfdx(res, r1, r2) :: k) addr GPR11 | (Mint64 | Many64), BR(IR res) -> expand_volatile_access - (fun r c -> emit (Pld(res, c, r))) - (fun r1 r2 -> emit (Pldx(res, r1, r2))) + (fun c r k-> Pld(res, c, r) :: k) + (fun r1 r2 k -> Pldx(res, r1, r2) :: k) + ~ofs_unaligned:false addr GPR11 | Mint64, BR_splitlong(BR(IR hi), BR(IR lo)) -> expand_volatile_access - (fun r c -> + (fun c r k-> match offset_constant c _4 with - | Some c' -> expand_load_int64 hi lo r c c' + | Some c' -> expand_load_int64 hi lo r c c' k | None -> - emit (Paddi(GPR11, r, c)); - expand_load_int64 hi lo GPR11 (Cint _0) (Cint _4)) - (fun r1 r2 -> - emit (Padd(GPR11, r1, r2)); - expand_load_int64 hi lo GPR11 (Cint _0) (Cint _4)) + Paddi(GPR11, r, c) :: + expand_load_int64 hi lo GPR11 (Cint _0) (Cint _4) k) + (fun r1 r2 k -> + Padd(GPR11, r1, r2) :: + expand_load_int64 hi lo GPR11 (Cint _0) (Cint _4) k) addr GPR11 | _, _ -> assert false @@ -310,54 +296,55 @@ let temp_for_vstore src = else if not (List.mem (IR GPR12) rl) then GPR12 else GPR10 -let expand_store_int64 hi lo base ofs_hi ofs_lo = - emit (Pstw(hi, ofs_hi, base)); - emit (Pstw(lo, ofs_lo, base)) +let expand_store_int64 hi lo base ofs_hi ofs_lo k = + Pstw(hi, ofs_hi, base) :: + Pstw(lo, ofs_lo, base) :: k let expand_builtin_vstore_1 chunk addr src = let temp = temp_for_vstore src in match chunk, src with | (Mint8signed | Mint8unsigned), BA(IR src) -> expand_volatile_access - (fun r c -> emit (Pstb(src, c, r))) - (fun r1 r2 -> emit (Pstbx(src, r1, r2))) + (fun c r k-> Pstb(src, c, r) :: k) + (fun r1 r2 k -> Pstbx(src, r1, r2) :: k) addr temp | (Mint16signed | Mint16unsigned), BA(IR src) -> expand_volatile_access - (fun r c -> emit (Psth(src, c, r))) - (fun r1 r2 -> emit (Psthx(src, r1, r2))) + (fun c r k-> Psth(src, c, r) :: k) + (fun r1 r2 k -> Psthx(src, r1, r2) :: k) addr temp | (Mint32 | Many32), BA(IR src) -> expand_volatile_access - (fun r c -> emit (Pstw(src, c, r))) - (fun r1 r2 -> emit (Pstwx(src, r1, r2))) + (fun c r k-> Pstw(src, c, r) :: k) + (fun r1 r2 k -> Pstwx(src, r1, r2) :: k) addr temp | Mfloat32, BA(FR src) -> expand_volatile_access - (fun r c -> emit (Pstfs(src, c, r))) - (fun r1 r2 -> emit (Pstfsx(src, r1, r2))) + (fun c r k-> Pstfs(src, c, r) :: k) + (fun r1 r2 k -> Pstfsx(src, r1, r2) :: k) addr temp | (Mfloat64 | Many64), BA(FR src) -> expand_volatile_access - (fun r c -> emit (Pstfd(src, c, r))) - (fun r1 r2 -> emit (Pstfdx(src, r1, r2))) + (fun c r k-> Pstfd(src, c, r) :: k) + (fun r1 r2 k -> Pstfdx(src, r1, r2) :: k) addr temp | (Mint64 | Many64), BA(IR src) -> expand_volatile_access - (fun r c -> emit (Pstd(src, c, r))) - (fun r1 r2 -> emit (Pstdx(src, r1, r2))) + (fun c r k-> Pstd(src, c, r) :: k) + (fun r1 r2 k -> Pstdx(src, r1, r2) :: k) + ~ofs_unaligned:false addr temp | Mint64, BA_splitlong(BA(IR hi), BA(IR lo)) -> expand_volatile_access - (fun r c -> + (fun c r k -> match offset_constant c _4 with - | Some c' -> expand_store_int64 hi lo r c c' + | Some c' -> expand_store_int64 hi lo r c c' k | None -> - emit (Paddi(temp, r, c)); - expand_store_int64 hi lo temp (Cint _0) (Cint _4)) - (fun r1 r2 -> - emit (Padd(temp, r1, r2)); - expand_store_int64 hi lo temp (Cint _0) (Cint _4)) + Paddi(temp, r, c) :: + expand_store_int64 hi lo temp (Cint _0) (Cint _4) k) + (fun r1 r2 k -> + Padd(temp, r1, r2) :: + expand_store_int64 hi lo temp (Cint _0) (Cint _4) k) addr temp | _, _ -> assert false @@ -388,8 +375,9 @@ let rec next_arg_locations ir fr ofs = function then next_arg_locations ir (fr + 1) ofs l else next_arg_locations ir fr (align ofs 8 + 8) l | Tlong :: l -> - if ir < 7 - then next_arg_locations (align ir 2 + 2) fr ofs l + let ir = align ir 2 in + if ir < 8 + then next_arg_locations (ir + 2) fr ofs l else next_arg_locations ir fr (align ofs 8 + 8) l let expand_builtin_va_start r = @@ -763,6 +751,9 @@ let expand_builtin_inline name args res = (* no operation *) | "__builtin_nop", [], _ -> emit (Pori (GPR0, GPR0, Cint _0)) + (* Optimization hint *) + | "__builtin_unreachable", [], _ -> + () (* atomic operations *) | "__builtin_atomic_exchange", [BA (IR a1); BA (IR a2); BA (IR a3)],_ -> (* Register constraints imposed by Machregs.v *) @@ -830,7 +821,7 @@ let expand_builtin_inline name args res = function is unprototyped. *) let set_cr6 sg = - if sg.sig_cc.cc_vararg || sg.sig_cc.cc_unproto then begin + if (sg.sig_cc.cc_vararg <> None) || sg.sig_cc.cc_unproto then begin if List.exists (function Tfloat | Tsingle -> true | _ -> false) sg.sig_args then emit (Pcreqv(CRbit_6, CRbit_6, CRbit_6)) else emit (Pcrxor(CRbit_6, CRbit_6, CRbit_6)) @@ -875,15 +866,6 @@ let expand_instruction instr = emit (Paddi(GPR1, GPR1, Cint(coqint_of_camlint sz))) else emit (Plwz(GPR1, Cint ofs, GPR1)) - | Pfcfi(r1, r2) -> - assert (Archi.ppc64); - emit (Pextsw(GPR0, r2)); - emit (Pstdu(GPR0, Cint _m8, GPR1)); - emit (Pcfi_adjust _8); - emit (Plfd(r1, Cint _0, GPR1)); - emit (Pfcfid(r1, r1)); - emit (Paddi(GPR1, GPR1, Cint _8)); - emit (Pcfi_adjust _m8) | Pfcfl(r1, r2) -> assert (Archi.ppc64); emit (Pstdu(r2, Cint _m8, GPR1)); @@ -892,15 +874,6 @@ let expand_instruction instr = emit (Pfcfid(r1, r1)); emit (Paddi(GPR1, GPR1, Cint _8)); emit (Pcfi_adjust _m8) - | Pfcfiu(r1, r2) -> - assert (Archi.ppc64); - emit (Prldicl(GPR0, r2, _0, _32)); - emit (Pstdu(GPR0, Cint _m8, GPR1)); - emit (Pcfi_adjust _8); - emit (Plfd(r1, Cint _0, GPR1)); - emit (Pfcfid(r1, r1)); - emit (Paddi(GPR1, GPR1, Cint _8)); - emit (Pcfi_adjust _m8) | Pfcti(r1, r2) -> emit (Pfctiwz(FPR13, r2)); emit (Pstfdu(FPR13, Cint _m8, GPR1)); @@ -908,14 +881,6 @@ let expand_instruction instr = emit (Plwz(r1, Cint _4, GPR1)); emit (Paddi(GPR1, GPR1, Cint _8)); emit (Pcfi_adjust _m8) - | Pfctiu(r1, r2) -> - assert (Archi.ppc64); - emit (Pfctidz(FPR13, r2)); - emit (Pstfdu(FPR13, Cint _m8, GPR1)); - emit (Pcfi_adjust _8); - emit (Plwz(r1, Cint _4, GPR1)); - emit (Paddi(GPR1, GPR1, Cint _8)); - emit (Pcfi_adjust _m8) | Pfctid(r1, r2) -> assert (Archi.ppc64); emit (Pfctidz(FPR13, r2)); diff --git a/powerpc/Asmgen.v b/powerpc/Asmgen.v index a686414a..7b6ac9af 100644 --- a/powerpc/Asmgen.v +++ b/powerpc/Asmgen.v @@ -190,36 +190,38 @@ Definition rolm64 (r1 r2: ireg) (amount: int) (mask: int64) (k: code) := (** Accessing slots in the stack frame. *) +(* For 64 bit load and store the offset needs to be a multiple of word size *) Definition accessind {A: Type} (instr1: A -> constant -> ireg -> instruction) (instr2: A -> ireg -> ireg -> instruction) + (unaligned : bool) (base: ireg) (ofs: ptrofs) (r: A) (k: code) := let ofs := Ptrofs.to_int ofs in - if Int.eq (high_s ofs) Int.zero + if Int.eq (high_s ofs) Int.zero && (unaligned || (Int.eq (Int.mods ofs (Int.repr 4)) Int.zero)) then instr1 r (Cint ofs) base :: k else loadimm GPR0 ofs (instr2 r base GPR0 :: k). Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: code) := match ty, preg_of dst with - | Tint, IR r => OK(accessind Plwz Plwzx base ofs r k) - | Tany32, IR r => OK(accessind Plwz_a Plwzx_a base ofs r k) - | Tsingle, FR r => OK(accessind Plfs Plfsx base ofs r k) - | Tlong, IR r => OK(accessind Pld Pldx base ofs r k) - | Tfloat, FR r => OK(accessind Plfd Plfdx base ofs r k) - | Tany64, IR r => OK(accessind Pld_a Pldx_a base ofs r k) - | Tany64, FR r => OK(accessind Plfd_a Plfdx_a base ofs r k) + | Tint, IR r => OK(accessind Plwz Plwzx true base ofs r k) + | Tany32, IR r => OK(accessind Plwz_a Plwzx_a true base ofs r k) + | Tsingle, FR r => OK(accessind Plfs Plfsx true base ofs r k) + | Tlong, IR r => OK(accessind Pld Pldx false base ofs r k) + | Tfloat, FR r => OK(accessind Plfd Plfdx true base ofs r k) + | Tany64, IR r => OK(accessind Pld_a Pldx_a false base ofs r k) + | Tany64, FR r => OK(accessind Plfd_a Plfdx_a true base ofs r k) | _, _ => Error (msg "Asmgen.loadind") end. Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: code) := match ty, preg_of src with - | Tint, IR r => OK(accessind Pstw Pstwx base ofs r k) - | Tany32, IR r => OK(accessind Pstw_a Pstwx_a base ofs r k) - | Tsingle, FR r => OK(accessind Pstfs Pstfsx base ofs r k) - | Tlong, IR r => OK(accessind Pstd Pstdx base ofs r k) - | Tfloat, FR r => OK(accessind Pstfd Pstfdx base ofs r k) - | Tany64, IR r => OK(accessind Pstd_a Pstdx_a base ofs r k) - | Tany64, FR r => OK(accessind Pstfd_a Pstfdx_a base ofs r k) + | Tint, IR r => OK(accessind Pstw Pstwx true base ofs r k) + | Tany32, IR r => OK(accessind Pstw_a Pstwx_a true base ofs r k) + | Tsingle, FR r => OK(accessind Pstfs Pstfsx true base ofs r k) + | Tlong, IR r => OK(accessind Pstd Pstdx false base ofs r k) + | Tfloat, FR r => OK(accessind Pstfd Pstfdx true base ofs r k) + | Tany64, IR r => OK(accessind Pstd_a Pstdx_a false base ofs r k) + | Tany64, FR r => OK(accessind Pstfd_a Pstfdx_a true base ofs r k) | _, _ => Error (msg "Asmgen.storeind") end. @@ -611,15 +613,6 @@ Definition transl_op | Ointoffloat, a1 :: nil => do r1 <- freg_of a1; do r <- ireg_of res; OK (Pfcti r r1 :: k) - | Ointuoffloat, a1 :: nil => - do r1 <- freg_of a1; do r <- ireg_of res; - OK (Pfctiu r r1 :: k) - | Ofloatofint, a1 :: nil => - do r1 <- ireg_of a1; do r <- freg_of res; - OK (Pfcfi r r1 :: k) - | Ofloatofintu, a1 :: nil => - do r1 <- ireg_of a1; do r <- freg_of res; - OK (Pfcfiu r r1 :: k) | Ofloatofwords, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r <- freg_of res; OK (Pfmake r r1 r2 :: k) @@ -733,52 +726,107 @@ Definition transl_op Definition int_temp_for (r: mreg) := if mreg_eq r R12 then GPR11 else GPR12. +Definition symbol_ofs_word_aligned symb ofs := + let ofs := Ptrofs.to_int ofs in + symbol_is_aligned symb 4 && (Int.eq (Int.mods ofs (Int.repr 4)) Int.zero). + +Definition aindexed + (mk1: constant -> ireg -> code -> code) + (mk2: ireg -> ireg -> code -> code) + (unaligned : bool) (r1 temp: ireg) (ofs: int) (k: code) := + if unaligned || Int.eq (Int.mods ofs (Int.repr 4)) Int.zero then + if Int.eq (high_s ofs) Int.zero then + mk1 (Cint ofs) r1 k + else + Paddis temp r1 (Cint (high_s ofs)) :: + mk1 (Cint (low_s ofs)) temp k + else + (loadimm GPR0 ofs (mk2 r1 GPR0 k)). + +Definition aindexed2 + (mk: ireg -> ireg -> code -> code) + (r1 r2: ireg) (k: code) := + mk r1 r2 k. + +Definition aglobal + (mk1: constant -> ireg -> code -> code) + (mk2: ireg -> ireg -> code -> code) + (unaligned : bool) (temp: ireg) + symb ofs k := + if symbol_is_small_data symb ofs then + if unaligned || symbol_ofs_word_aligned symb ofs then + mk1 (Csymbol_sda symb ofs) GPR0 k + else + Paddi temp GPR0 (Csymbol_sda symb ofs) :: + mk1 (Cint Int.zero) temp k + else if symbol_is_rel_data symb ofs then + Paddis temp GPR0 (Csymbol_rel_high symb ofs) :: + Paddi temp temp (Csymbol_rel_low symb ofs) :: + mk1 (Cint Int.zero) temp k + else if unaligned || symbol_ofs_word_aligned symb ofs then + Paddis temp GPR0 (Csymbol_high symb ofs) :: + mk1 (Csymbol_low symb ofs) temp k + else + Paddis temp GPR0 (Csymbol_high symb ofs) :: + Paddi temp temp (Csymbol_low symb ofs) :: + mk1 (Cint Int.zero) temp k. + +Definition abased + (mk1: constant -> ireg -> code -> code) + (mk2: ireg -> ireg -> code -> code) + (unaligned : bool) (r1 temp: ireg) + symb ofs k := + if symbol_is_small_data symb ofs then + Paddi GPR0 GPR0 (Csymbol_sda symb ofs) :: + mk2 r1 GPR0 k + else if symbol_is_rel_data symb ofs then + Pmr GPR0 r1 :: + Paddis temp GPR0 (Csymbol_rel_high symb ofs) :: + Paddi temp temp (Csymbol_rel_low symb ofs) :: + mk2 temp GPR0 k + else if unaligned || symbol_ofs_word_aligned symb ofs then + Paddis temp r1 (Csymbol_high symb ofs) :: + mk1 (Csymbol_low symb ofs) temp k + else + Pmr GPR0 r1 :: + Paddis temp GPR0 (Csymbol_high symb ofs) :: + Paddi temp temp (Csymbol_low symb ofs) :: + mk2 temp GPR0 k. + +Definition ainstack + (mk1 : constant -> ireg -> code -> code) + (mk2 : ireg -> ireg -> code -> code) + (unaligned : bool) (temp: ireg) ofs k := + if unaligned || Int.eq (Int.mods ofs (Int.repr 4)) Int.zero then + if Int.eq (high_s ofs) Int.zero then + mk1 (Cint ofs) GPR1 k + else + Paddis temp GPR1 (Cint (high_s ofs)) :: + mk1 (Cint (low_s ofs)) temp k + else + addimm temp GPR1 ofs (mk1 (Cint Int.zero) temp k). + Definition transl_memory_access (mk1: constant -> ireg -> instruction) (mk2: ireg -> ireg -> instruction) + (unaligned : bool) (addr: addressing) (args: list mreg) (temp: ireg) (k: code) := match addr, args with | Aindexed ofs, a1 :: nil => do r1 <- ireg_of a1; - OK (if Int.eq (high_s ofs) Int.zero then - mk1 (Cint ofs) r1 :: k - else - Paddis temp r1 (Cint (high_s ofs)) :: - mk1 (Cint (low_s ofs)) temp :: k) + OK (aindexed (fun c r k => mk1 c r :: k) (fun r1 r2 k => mk2 r1 r2 :: k) unaligned r1 temp ofs k) | Aindexed2, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (mk2 r1 r2 :: k) + OK (aindexed2 (fun r1 r2 k => mk2 r1 r2 :: k) r1 r2 k) | Aglobal symb ofs, nil => - OK (if symbol_is_small_data symb ofs then - mk1 (Csymbol_sda symb ofs) GPR0 :: k - else if symbol_is_rel_data symb ofs then - Paddis temp GPR0 (Csymbol_rel_high symb ofs) :: - Paddi temp temp (Csymbol_rel_low symb ofs) :: - mk1 (Cint Int.zero) temp :: k - else - Paddis temp GPR0 (Csymbol_high symb ofs) :: - mk1 (Csymbol_low symb ofs) temp :: k) + OK (aglobal (fun c r k => mk1 c r :: k) (fun r1 r2 k => mk2 r1 r2 :: k) unaligned temp symb ofs k) | Abased symb ofs, a1 :: nil => do r1 <- ireg_of a1; - OK (if symbol_is_small_data symb ofs then - Paddi GPR0 GPR0 (Csymbol_sda symb ofs) :: - mk2 r1 GPR0 :: k - else if symbol_is_rel_data symb ofs then - Pmr GPR0 r1 :: - Paddis temp GPR0 (Csymbol_rel_high symb ofs) :: - Paddi temp temp (Csymbol_rel_low symb ofs) :: - mk2 temp GPR0 :: k - else - Paddis temp r1 (Csymbol_high symb ofs) :: - mk1 (Csymbol_low symb ofs) temp :: k) + OK (abased (fun c r k => mk1 c r :: k) (fun r1 r2 k => mk2 r1 r2 :: k) unaligned r1 temp symb ofs k) | Ainstack ofs, nil => let ofs := Ptrofs.to_int ofs in - OK (if Int.eq (high_s ofs) Int.zero then - mk1 (Cint ofs) GPR1 :: k - else - Paddis temp GPR1 (Cint (high_s ofs)) :: - mk1 (Cint (low_s ofs)) temp :: k) + OK (ainstack (fun c r k => mk1 c r :: k) (fun r1 r2 k => mk2 r1 r2 :: k) unaligned temp ofs k) | _, _ => Error(msg "Asmgen.transl_memory_access") end. @@ -788,28 +836,28 @@ Definition transl_load (chunk: memory_chunk) (addr: addressing) match chunk with | Mint8signed => do r <- ireg_of dst; - transl_memory_access (Plbz r) (Plbzx r) addr args GPR12 (Pextsb r r :: k) + transl_memory_access (Plbz r) (Plbzx r) true addr args GPR12 (Pextsb r r :: k) | Mint8unsigned => do r <- ireg_of dst; - transl_memory_access (Plbz r) (Plbzx r) addr args GPR12 k + transl_memory_access (Plbz r) (Plbzx r) true addr args GPR12 k | Mint16signed => do r <- ireg_of dst; - transl_memory_access (Plha r) (Plhax r) addr args GPR12 k + transl_memory_access (Plha r) (Plhax r) true addr args GPR12 k | Mint16unsigned => do r <- ireg_of dst; - transl_memory_access (Plhz r) (Plhzx r) addr args GPR12 k + transl_memory_access (Plhz r) (Plhzx r) true addr args GPR12 k | Mint32 => do r <- ireg_of dst; - transl_memory_access (Plwz r) (Plwzx r) addr args GPR12 k + transl_memory_access (Plwz r) (Plwzx r) true addr args GPR12 k | Mint64 => do r <- ireg_of dst; - transl_memory_access (Pld r) (Pldx r) addr args GPR12 k + transl_memory_access (Pld r) (Pldx r) false addr args GPR12 k | Mfloat32 => do r <- freg_of dst; - transl_memory_access (Plfs r) (Plfsx r) addr args GPR12 k + transl_memory_access (Plfs r) (Plfsx r) true addr args GPR12 k | Mfloat64 => do r <- freg_of dst; - transl_memory_access (Plfd r) (Plfdx r) addr args GPR12 k + transl_memory_access (Plfd r) (Plfdx r) true addr args GPR12 k | _ => Error (msg "Asmgen.transl_load") end. @@ -820,22 +868,22 @@ Definition transl_store (chunk: memory_chunk) (addr: addressing) match chunk with | Mint8signed | Mint8unsigned => do r <- ireg_of src; - transl_memory_access (Pstb r) (Pstbx r) addr args temp k + transl_memory_access (Pstb r) (Pstbx r) true addr args temp k | Mint16signed | Mint16unsigned => do r <- ireg_of src; - transl_memory_access (Psth r) (Psthx r) addr args temp k + transl_memory_access (Psth r) (Psthx r) true addr args temp k | Mint32 => do r <- ireg_of src; - transl_memory_access (Pstw r) (Pstwx r) addr args temp k + transl_memory_access (Pstw r) (Pstwx r) true addr args temp k | Mint64 => do r <- ireg_of src; - transl_memory_access (Pstd r) (Pstdx r) addr args temp k + transl_memory_access (Pstd r) (Pstdx r) false addr args temp k | Mfloat32 => do r <- freg_of src; - transl_memory_access (Pstfs r) (Pstfsx r) addr args temp k + transl_memory_access (Pstfs r) (Pstfsx r) true addr args temp k | Mfloat64 => do r <- freg_of src; - transl_memory_access (Pstfd r) (Pstfdx r) addr args temp k + transl_memory_access (Pstfd r) (Pstfdx r) true addr args temp k | _ => Error (msg "Asmgen.transl_store") end. diff --git a/powerpc/Asmgenproof.v b/powerpc/Asmgenproof.v index d653633c..85541118 100644 --- a/powerpc/Asmgenproof.v +++ b/powerpc/Asmgenproof.v @@ -69,7 +69,7 @@ Lemma transf_function_no_overflow: transf_function f = OK tf -> list_length_z tf.(fn_code) <= Ptrofs.max_unsigned. Proof. intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. - omega. + lia. Qed. Lemma exec_straight_exec: @@ -205,10 +205,13 @@ Remark loadind_label: forall base ofs ty dst k c, loadind base ofs ty dst k = OK c -> tail_nolabel k c. Proof. - unfold loadind, accessind; intros. set (ofs' := Ptrofs.to_int ofs) in *. + unfold loadind, accessind ; intros. + set (ofs' := Ptrofs.to_int ofs) in *. + set (ofs_mod := Int.eq (Int.mods ofs' (Int.repr 4)) Int.zero) in *. destruct ty; try discriminate; destruct (preg_of dst); try discriminate; destruct (Int.eq (high_s ofs') Int.zero); + destruct ofs_mod; TailNoLabel; eapply tail_nolabel_trans; TailNoLabel. Qed. @@ -216,10 +219,13 @@ Remark storeind_label: forall base ofs ty src k c, storeind src base ofs ty k = OK c -> tail_nolabel k c. Proof. - unfold storeind, accessind; intros. set (ofs' := Ptrofs.to_int ofs) in *. + unfold storeind, accessind; + intros. set (ofs' := Ptrofs.to_int ofs) in *. + set (ofs_mod := Int.eq (Int.mods ofs' (Int.repr 4)) Int.zero) in *. destruct ty; try discriminate; destruct (preg_of src); try discriminate; destruct (Int.eq (high_s ofs') Int.zero); + destruct ofs_mod; TailNoLabel; eapply tail_nolabel_trans; TailNoLabel. Qed. @@ -298,17 +304,22 @@ Qed. Remark transl_memory_access_label: forall (mk1: constant -> ireg -> instruction) (mk2: ireg -> ireg -> instruction) - addr args temp k c, - transl_memory_access mk1 mk2 addr args temp k = OK c -> + unaligned addr args temp k c, + transl_memory_access mk1 mk2 unaligned addr args temp k = OK c -> (forall c r, nolabel (mk1 c r)) -> (forall r1 r2, nolabel (mk2 r1 r2)) -> tail_nolabel k c. Proof. - unfold transl_memory_access; intros; destruct addr; TailNoLabel. - destruct (Int.eq (high_s i) Int.zero); TailNoLabel. - destruct (symbol_is_small_data i i0). TailNoLabel. destruct (symbol_is_rel_data i i0); TailNoLabel. + unfold transl_memory_access, aindexed, aindexed2, aglobal, abased, ainstack; intros; destruct addr; TailNoLabel. + destruct (unaligned || Int.eq (Int.mods i (Int.repr 4)) Int.zero). destruct (Int.eq (high_s i) Int.zero); TailNoLabel. + eapply tail_nolabel_trans. apply loadimm_label. TailNoLabel. + destruct (symbol_is_small_data i i0). destruct (unaligned || symbol_ofs_word_aligned i i0); TailNoLabel. destruct (symbol_is_rel_data i i0); TailNoLabel. + destruct (unaligned || symbol_ofs_word_aligned i i0); TailNoLabel. destruct (symbol_is_small_data i i0). TailNoLabel. destruct (symbol_is_rel_data i i0); TailNoLabel. + destruct (unaligned || symbol_ofs_word_aligned i i0); TailNoLabel. + destruct (unaligned || Int.eq (Int.mods (Ptrofs.to_int i) (Int.repr 4)) Int.zero). destruct (Int.eq (high_s (Ptrofs.to_int i)) Int.zero); TailNoLabel. + eapply tail_nolabel_trans. eapply addimm_label. TailNoLabel. Qed. Remark transl_epilogue_label: @@ -401,8 +412,8 @@ Proof. split. unfold goto_label. rewrite P. rewrite H1. auto. split. rewrite Pregmap.gss. constructor; auto. rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. - auto. omega. - generalize (transf_function_no_overflow _ _ H0). omega. + auto. lia. + generalize (transf_function_no_overflow _ _ H0). lia. intros. apply Pregmap.gso; auto. Qed. @@ -781,16 +792,18 @@ Opaque loadind. econstructor; eauto. instantiate (2 := tf); instantiate (1 := x). unfold nextinstr. rewrite Pregmap.gss. - rewrite set_res_other. rewrite undef_regs_other_2. + rewrite set_res_other. simpl. rewrite undef_regs_other_2. + rewrite Pregmap.gso by auto with asmgen. rewrite <- H1. simpl. econstructor; eauto. eapply code_tail_next_int; eauto. rewrite preg_notin_charact. intros. auto with asmgen. auto with asmgen. apply agree_nextinstr. eapply agree_set_res; auto. - eapply agree_undef_regs; eauto. intros; apply undef_regs_other_2; auto. + eapply agree_undef_regs; eauto. + intros. simpl. rewrite undef_regs_other_2; auto. apply Pregmap.gso. auto with asmgen. congruence. intros. Simpl. rewrite set_res_other by auto. - rewrite undef_regs_other_2; auto with asmgen. + simpl. rewrite undef_regs_other_2; auto with asmgen. - (* Mgoto *) assert (f0 = f) by congruence. subst f0. @@ -924,14 +937,14 @@ Local Transparent destroyed_by_jumptable. simpl const_low. rewrite ATLR. erewrite storev_offset_ptr by eexact P. auto. congruence. auto. auto. auto. left; exists (State rs5 m3'); split. - eapply exec_straight_steps_1; eauto. omega. constructor. + eapply exec_straight_steps_1; eauto. lia. constructor. econstructor; eauto. change (rs5 PC) with (Val.offset_ptr (Val.offset_ptr (Val.offset_ptr (Val.offset_ptr (rs0 PC) Ptrofs.one) Ptrofs.one) Ptrofs.one) Ptrofs.one). rewrite ATPC. simpl. constructor; eauto. - eapply code_tail_next_int. omega. - eapply code_tail_next_int. omega. - eapply code_tail_next_int. omega. - eapply code_tail_next_int. omega. + eapply code_tail_next_int. lia. + eapply code_tail_next_int. lia. + eapply code_tail_next_int. lia. + eapply code_tail_next_int. lia. constructor. unfold rs5, rs4, rs3, rs2. apply agree_nextinstr. apply agree_nextinstr. @@ -956,7 +969,7 @@ Local Transparent destroyed_by_jumptable. - (* return *) inv STACKS. simpl in *. - right. split. omega. split. auto. + right. split. lia. split. auto. rewrite <- ATPC in H5. econstructor; eauto. congruence. diff --git a/powerpc/Asmgenproof1.v b/powerpc/Asmgenproof1.v index 20cf9c1d..6ae520ef 100644 --- a/powerpc/Asmgenproof1.v +++ b/powerpc/Asmgenproof1.v @@ -81,12 +81,12 @@ Proof. unfold Int.modu, Int.zero. decEq. change 0 with (0 mod 65536). change (Int.unsigned (Int.repr 65536)) with 65536. - apply eqmod_mod_eq. omega. + apply eqmod_mod_eq. lia. unfold x, low_s. eapply eqmod_trans. apply eqmod_divides with Int.modulus. unfold Int.sub. apply Int.eqm_unsigned_repr_l. apply Int.eqm_refl. exists 65536. compute; auto. - replace 0 with (Int.unsigned n - Int.unsigned n) by omega. + replace 0 with (Int.unsigned n - Int.unsigned n) by lia. apply eqmod_sub. apply eqmod_refl. apply Int.eqmod_sign_ext'. compute; auto. rewrite H0 in H. rewrite Int.add_zero in H. @@ -132,7 +132,7 @@ Lemma important_diff: Proof. congruence. Qed. -Hint Resolve important_diff: asmgen. +Global Hint Resolve important_diff: asmgen. Lemma important_data_preg_1: forall r, data_preg r = true -> important_preg r = true. @@ -146,7 +146,7 @@ Proof. intros. destruct (data_preg r) eqn:E; auto. apply important_data_preg_1 in E. congruence. Qed. -Hint Resolve important_data_preg_1 important_data_preg_2: asmgen. +Global Hint Resolve important_data_preg_1 important_data_preg_2: asmgen. Lemma nextinstr_inv2: forall r rs, important_preg r = true -> (nextinstr rs)#r = rs#r. @@ -166,7 +166,7 @@ Lemma gpr_or_zero_zero: Proof. intros. reflexivity. Qed. -Hint Resolve gpr_or_zero_not_zero gpr_or_zero_zero: asmgen. +Global Hint Resolve gpr_or_zero_not_zero gpr_or_zero_zero: asmgen. Lemma gpr_or_zero_l_not_zero: forall rs r, r <> GPR0 -> gpr_or_zero_l rs r = rs#r. @@ -178,21 +178,21 @@ Lemma gpr_or_zero_l_zero: Proof. intros. reflexivity. Qed. -Hint Resolve gpr_or_zero_l_not_zero gpr_or_zero_l_zero: asmgen. +Global Hint Resolve gpr_or_zero_l_not_zero gpr_or_zero_l_zero: asmgen. Lemma ireg_of_not_GPR0: forall m r, ireg_of m = OK r -> IR r <> IR GPR0. Proof. intros. erewrite <- ireg_of_eq; eauto with asmgen. Qed. -Hint Resolve ireg_of_not_GPR0: asmgen. +Global Hint Resolve ireg_of_not_GPR0: asmgen. Lemma ireg_of_not_GPR0': forall m r, ireg_of m = OK r -> r <> GPR0. Proof. intros. generalize (ireg_of_not_GPR0 _ _ H). congruence. Qed. -Hint Resolve ireg_of_not_GPR0': asmgen. +Global Hint Resolve ireg_of_not_GPR0': asmgen. (** Useful properties of the LR register *) @@ -208,7 +208,7 @@ Proof. intros. rewrite preg_notin_charact. intros. apply preg_of_not_LR. Qed. -Hint Resolve preg_of_not_LR preg_notin_LR: asmgen. +Global Hint Resolve preg_of_not_LR preg_notin_LR: asmgen. (** Useful simplification tactic *) @@ -543,7 +543,7 @@ Proof. - econstructor; split; [|split]. + apply exec_straight_one. simpl; eauto. auto. + Simpl. rewrite Int64.add_zero_l. rewrite H. unfold low64_s. - rewrite Int64.sign_ext_widen by omega. auto. + rewrite Int64.sign_ext_widen by lia. auto. + intros; Simpl. - econstructor; split; [|split]. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. @@ -551,16 +551,16 @@ Proof. apply Int64.same_bits_eq; intros. assert (Int64.zwordsize = 64) by auto. rewrite Int64.bits_or, Int64.bits_shl by auto. unfold low64_s, low64_u. - rewrite Int64.bits_zero_ext by omega. + rewrite Int64.bits_zero_ext by lia. change (Int64.unsigned (Int64.repr 16)) with 16. destruct (zlt i 16). - * rewrite Int64.bits_sign_ext by omega. rewrite zlt_true by omega. auto. - * rewrite ! Int64.bits_sign_ext by omega. rewrite orb_false_r. + * rewrite Int64.bits_sign_ext by lia. rewrite zlt_true by lia. auto. + * rewrite ! Int64.bits_sign_ext by lia. rewrite orb_false_r. destruct (zlt i 32). - ** rewrite zlt_true by omega. rewrite Int64.bits_shr by omega. + ** rewrite zlt_true by lia. rewrite Int64.bits_shr by lia. change (Int64.unsigned (Int64.repr 16)) with 16. - rewrite zlt_true by omega. f_equal; omega. - ** rewrite zlt_false by omega. rewrite Int64.bits_shr by omega. + rewrite zlt_true by lia. f_equal; lia. + ** rewrite zlt_false by lia. rewrite Int64.bits_shr by lia. change (Int64.unsigned (Int64.repr 16)) with 16. reflexivity. + intros; Simpl. @@ -605,11 +605,11 @@ Proof. rewrite Int64.bits_shl by auto. change (Int64.unsigned (Int64.repr 32)) with 32. destruct (zlt i 32); auto. - rewrite Int64.bits_sign_ext by omega. - rewrite zlt_true by omega. - unfold n2. rewrite Int64.bits_shru by omega. + rewrite Int64.bits_sign_ext by lia. + rewrite zlt_true by lia. + unfold n2. rewrite Int64.bits_shru by lia. change (Int64.unsigned (Int64.repr 32)) with 32. - rewrite zlt_true by omega. f_equal; omega. + rewrite zlt_true by lia. f_equal; lia. } assert (MI: forall i, 0 <= i < Int64.zwordsize -> Int64.testbit mi i = @@ -619,21 +619,21 @@ Proof. rewrite Int64.bits_shl by auto. change (Int64.unsigned (Int64.repr 16)) with 16. destruct (zlt i 16); auto. - unfold n1. rewrite Int64.bits_zero_ext by omega. - rewrite Int64.bits_shru by omega. + unfold n1. rewrite Int64.bits_zero_ext by lia. + rewrite Int64.bits_shru by lia. destruct (zlt i 32). - rewrite zlt_true by omega. + rewrite zlt_true by lia. change (Int64.unsigned (Int64.repr 16)) with 16. - rewrite zlt_true by omega. f_equal; omega. - rewrite zlt_false by omega. auto. + rewrite zlt_true by lia. f_equal; lia. + rewrite zlt_false by lia. auto. } assert (EQ: Int64.or (Int64.or hi mi) n0 = n). { apply Int64.same_bits_eq; intros. rewrite ! Int64.bits_or by auto. - unfold n0; rewrite Int64.bits_zero_ext by omega. + unfold n0; rewrite Int64.bits_zero_ext by lia. rewrite HI, MI by auto. destruct (zlt i 16). - rewrite zlt_true by omega. auto. + rewrite zlt_true by lia. auto. destruct (zlt i 32); rewrite ! orb_false_r; auto. } edestruct (loadimm64_32s_correct r n2) as (rs' & A & B & C). @@ -805,6 +805,7 @@ Lemma accessind_load_correct: forall (A: Type) (inj: A -> preg) (instr1: A -> constant -> ireg -> instruction) (instr2: A -> ireg -> ireg -> instruction) + (unaligned: bool) (base: ireg) ofs rx chunk v (rs: regset) m k, (forall rs m r1 cst r2, exec_instr ge fn (instr1 r1 cst r2) rs m = load1 ge chunk (inj r1) cst r2 rs m) -> @@ -813,14 +814,15 @@ Lemma accessind_load_correct: Mem.loadv chunk m (Val.offset_ptr rs#base ofs) = Some v -> base <> GPR0 -> inj rx <> PC -> exists rs', - exec_straight ge fn (accessind instr1 instr2 base ofs rx k) rs m k rs' m + exec_straight ge fn (accessind instr1 instr2 unaligned base ofs rx k) rs m k rs' m /\ rs'#(inj rx) = v /\ forall r, r <> PC -> r <> inj rx -> r <> GPR0 -> rs'#r = rs#r. Proof. intros. unfold accessind. set (ofs' := Ptrofs.to_int ofs) in *. + set (ofs_mod := unaligned || Int.eq (Int.mods ofs' (Int.repr 4)) Int.zero) in *. assert (LD: Mem.loadv chunk m (Val.add (rs base) (Vint ofs')) = Some v) by (apply loadv_offset_ptr; auto). - destruct (Int.eq (high_s ofs') Int.zero). + destruct (Int.eq (high_s ofs') Int.zero && ofs_mod). - econstructor; split. apply exec_straight_one. rewrite H. unfold load1. rewrite gpr_or_zero_not_zero by auto. simpl. rewrite LD. eauto. unfold nextinstr. repeat Simplif. @@ -862,6 +864,7 @@ Lemma accessind_store_correct: forall (A: Type) (inj: A -> preg) (instr1: A -> constant -> ireg -> instruction) (instr2: A -> ireg -> ireg -> instruction) + (unaligned: bool) (base: ireg) ofs rx chunk (rs: regset) m m' k, (forall rs m r1 cst r2, exec_instr ge fn (instr1 r1 cst r2) rs m = store1 ge chunk (inj r1) cst r2 rs m) -> @@ -870,13 +873,14 @@ Lemma accessind_store_correct: Mem.storev chunk m (Val.offset_ptr rs#base ofs) (rs (inj rx)) = Some m' -> base <> GPR0 -> inj rx <> PC -> inj rx <> GPR0 -> exists rs', - exec_straight ge fn (accessind instr1 instr2 base ofs rx k) rs m k rs' m' + exec_straight ge fn (accessind instr1 instr2 unaligned base ofs rx k) rs m k rs' m' /\ forall r, r <> PC -> r <> GPR0 -> rs'#r = rs#r. Proof. intros. unfold accessind. set (ofs' := Ptrofs.to_int ofs) in *. + set (ofs_mod := unaligned || Int.eq (Int.mods ofs' (Int.repr 4)) Int.zero) in *. assert (ST: Mem.storev chunk m (Val.add (rs base) (Vint ofs')) (rs (inj rx)) = Some m') by (apply storev_offset_ptr; auto). - destruct (Int.eq (high_s ofs') Int.zero). + destruct (Int.eq (high_s ofs') Int.zero && ofs_mod). - econstructor; split. apply exec_straight_one. rewrite H. unfold store1. rewrite gpr_or_zero_not_zero by auto. simpl. rewrite ST. eauto. unfold nextinstr. repeat Simplif. @@ -1180,7 +1184,7 @@ Local Transparent Int.repr. rewrite H2. apply Int.mkint_eq; reflexivity. rewrite Int.not_involutive in H3. congruence. - omega. + lia. Qed. Remark add_carry_ne0: @@ -1198,8 +1202,8 @@ Transparent Int.eq. rewrite Int.unsigned_zero. rewrite Int.unsigned_mone. unfold negb, Val.of_bool, Vtrue, Vfalse. destruct (zeq (Int.unsigned i) 0); decEq. - apply zlt_true. omega. - apply zlt_false. generalize (Int.unsigned_range i). omega. + apply zlt_true. lia. + apply zlt_false. generalize (Int.unsigned_range i). lia. Qed. Lemma transl_cond_op_correct: @@ -1500,18 +1504,6 @@ Opaque Val.add. - replace v with (Val.maketotal (Val.intoffloat (rs x))). TranslOpSimpl. rewrite H1; auto. - (* Ointuoffloat *) -- replace v with (Val.maketotal (Val.intuoffloat (rs x))). - TranslOpSimpl. - rewrite H1; auto. - (* Ofloatofint *) -- replace v with (Val.maketotal (Val.floatofint (rs x))). - TranslOpSimpl. - rewrite H1; auto. - (* Ofloatofintu *) -- replace v with (Val.maketotal (Val.floatofintu (rs x))). - TranslOpSimpl. - rewrite H1; auto. (* Ocmp *) - destruct (transl_cond_op_correct c0 args res k rs m c) as [rs' [A [B C]]]; auto. exists rs'; auto with asmgen. @@ -1552,8 +1544,8 @@ Qed. (** Translation of memory accesses *) Lemma transl_memory_access_correct: - forall (P: regset -> Prop) mk1 mk2 addr args temp k c (rs: regset) a m m', - transl_memory_access mk1 mk2 addr args temp k = OK c -> + forall (P: regset -> Prop) mk1 mk2 unaligned addr args temp k c (rs: regset) a m m', + transl_memory_access mk1 mk2 unaligned addr args temp k = OK c -> eval_addressing ge (rs#GPR1) addr (map rs (map preg_of args)) = Some a -> temp <> GPR0 -> (forall cst (r1: ireg) (rs1: regset) k, @@ -1571,111 +1563,178 @@ Lemma transl_memory_access_correct: Proof. intros until m'; intros TR ADDR TEMP MK1 MK2. unfold transl_memory_access in TR; destruct addr; ArgsInv; simpl in ADDR; inv ADDR. - (* Aindexed *) - case (Int.eq (high_s i) Int.zero). - (* Aindexed short *) - apply MK1. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto. - (* Aindexed long *) - set (rs1 := nextinstr (rs#temp <- (Val.add (rs x) (Vint (Int.shl (high_s i) (Int.repr 16)))))). - exploit (MK1 (Cint (low_s i)) temp rs1 k). - simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen. - unfold rs1; Simpl. rewrite Val.add_assoc. -Transparent Val.add. - simpl. rewrite low_high_s. auto. - intros; unfold rs1; Simpl. - intros [rs' [EX' AG']]. - exists rs'. split. apply exec_straight_step with rs1 m. - simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto. - auto. auto. - (* Aindexed2 *) - apply MK2. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto. - (* Aglobal *) - destruct (symbol_is_small_data i i0) eqn:SISD; [ | destruct (symbol_is_rel_data i i0) ]; inv TR. - (* Aglobal from small data *) - apply MK1. unfold const_low. rewrite small_data_area_addressing by auto. - rewrite add_zero_symbol_address. auto. - auto. - (* Aglobal from relative data *) - set (rs1 := nextinstr (rs#temp <- (Val.add Vzero (high_half ge i i0)))). - set (rs2 := nextinstr (rs1#temp <- (Genv.symbol_address ge i i0))). - exploit (MK1 (Cint Int.zero) temp rs2). - simpl. rewrite gpr_or_zero_not_zero by eauto with asmgen. - unfold rs2. Simpl. rewrite Val.add_commut. rewrite add_zero_symbol_address. auto. - intros; unfold rs2, rs1; Simpl. - intros [rs' [EX' AG']]. - exists rs'; split. apply exec_straight_step with rs1 m; auto. - apply exec_straight_step with rs2 m; auto. simpl. unfold rs2. - rewrite gpr_or_zero_not_zero by eauto with asmgen. f_equal. f_equal. f_equal. - unfold rs1; Simpl. apply low_high_half_zero. - eexact EX'. auto. - (* Aglobal from absolute data *) - set (rs1 := nextinstr (rs#temp <- (Val.add Vzero (high_half ge i i0)))). - exploit (MK1 (Csymbol_low i i0) temp rs1). - simpl. rewrite gpr_or_zero_not_zero by eauto with asmgen. - unfold rs1. Simpl. rewrite low_high_half_zero. auto. - intros; unfold rs1; Simpl. - intros [rs' [EX' AG']]. - exists rs'; split. apply exec_straight_step with rs1 m; auto. - eexact EX'. auto. - (* Abased *) + - (* Aindexed *) + unfold aindexed. + destruct (unaligned || Int.eq (Int.mods i (Int.repr 4)) Int.zero); [destruct (Int.eq (high_s i) Int.zero) |]. + + (* Aindexed 4 aligned short *) + apply MK1. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto. + (* Aindexed 4 aligned long *) + + set (rs1 := nextinstr (rs#temp <- (Val.add (rs x) (Vint (Int.shl (high_s i) (Int.repr 16)))))). + exploit (MK1 (Cint (low_s i)) temp rs1 k). + simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen. + unfold rs1; Simpl. rewrite Val.add_assoc. + Transparent Val.add. + simpl. rewrite low_high_s. auto. + intros; unfold rs1; Simpl. + intros [rs' [EX' AG']]. + exists rs'. split. apply exec_straight_step with rs1 m. + simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto. + auto. auto. + + (* Aindexed non 4 aligned *) + exploit (loadimm_correct GPR0 i (mk2 x GPR0 :: k) rs). + intros (rs' & A & B & C). + exploit (MK2 x GPR0 rs'). + rewrite gpr_or_zero_not_zero; eauto with asmgen. + rewrite B. rewrite C; eauto with asmgen. auto. + intros. destruct H as [rs'' [A1 B1]]. exists rs''. + split. eapply exec_straight_trans. exact A. exact A1. auto. + - (* Aindexed2 *) + apply MK2. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto. + - (* Aglobal *) + unfold aglobal in *. + destruct (symbol_is_small_data i i0) eqn:SISD; [ | destruct (symbol_is_rel_data i i0) ]; inv TR. + + (* Aglobal from small data 4 aligned *) + case (unaligned || symbol_ofs_word_aligned i i0). + apply MK1. unfold const_low. rewrite small_data_area_addressing by auto. + rewrite add_zero_symbol_address. auto. auto. + (* Aglobal from small data not aligned *) + set (rs1 := nextinstr (rs#temp <- (Val.add (gpr_or_zero rs GPR0) (const_low ge (Csymbol_sda i i0))))). + exploit (MK1 (Cint Int.zero) temp rs1). rewrite gpr_or_zero_not_zero; auto. + unfold const_low. unfold rs1. Simpl. + rewrite gpr_or_zero_zero. unfold const_low. + rewrite small_data_area_addressing by auto. + rewrite add_zero_symbol_address. rewrite Val.add_commut. + rewrite add_zero_symbol_address. auto. + intros. unfold rs1. Simpl. + intros. destruct H as [rs2 [A B]]. + exists rs2. split. eapply exec_straight_step. reflexivity. + reflexivity. eexact A. apply B. + + (* relative data *) + set (rs1 := nextinstr (rs#temp <- (Val.add Vzero (high_half ge i i0)))). + set (rs2 := nextinstr (rs1#temp <- (Genv.symbol_address ge i i0))). + exploit (MK1 (Cint Int.zero) temp rs2). + simpl. rewrite gpr_or_zero_not_zero by eauto with asmgen. + unfold rs2. Simpl. rewrite Val.add_commut. rewrite add_zero_symbol_address. auto. + intros; unfold rs2, rs1; Simpl. + intros [rs' [EX' AG']]. + exists rs'; split. apply exec_straight_step with rs1 m; auto. + apply exec_straight_step with rs2 m; auto. simpl. unfold rs2. + rewrite gpr_or_zero_not_zero by eauto with asmgen. f_equal. f_equal. f_equal. + unfold rs1; Simpl. apply low_high_half_zero. + eexact EX'. auto. + + (* Aglobal from absolute data *) + destruct (unaligned || symbol_ofs_word_aligned i i0). + (* Aglobal 4 aligned *) + set (rs1 := nextinstr (rs#temp <- (Val.add Vzero (high_half ge i i0)))). + exploit (MK1 (Csymbol_low i i0) temp rs1). + simpl. rewrite gpr_or_zero_not_zero by eauto with asmgen. + unfold rs1. Simpl. rewrite low_high_half_zero. auto. + intros; unfold rs1; Simpl. + intros [rs' [EX' AG']]. + exists rs'; split. apply exec_straight_step with rs1 m; auto. + eexact EX'. auto. + (* Aglobal non aligned *) + set (rs1 := nextinstr (rs#temp <- (Val.add Vzero (high_half ge i i0)))). + set (rs2 := nextinstr (rs1#temp <- (Genv.symbol_address ge i i0))). + exploit (MK1 (Cint Int.zero) temp rs2). + simpl. rewrite gpr_or_zero_not_zero by eauto with asmgen. + unfold rs2. Simpl. rewrite Val.add_commut. rewrite add_zero_symbol_address. + auto. intros; unfold rs2, rs1; Simpl. + intros [rs' [EX' AG']]. + exists rs'; split. apply exec_straight_step with rs1 m; auto. + apply exec_straight_step with rs2 m; auto. simpl. unfold rs2. + rewrite gpr_or_zero_not_zero; auto. f_equal. f_equal. f_equal. + unfold rs1; Simpl. apply low_high_half_zero. eexact EX'. auto. + - (* Abased *) + unfold abased in *. destruct (symbol_is_small_data i i0) eqn:SISD; [ | destruct (symbol_is_rel_data i i0) ]. - (* Abased from small data *) - set (rs1 := nextinstr (rs#GPR0 <- (Genv.symbol_address ge i i0))). - exploit (MK2 x GPR0 rs1 k). + + (* Abased from small data *) + set (rs1 := nextinstr (rs#GPR0 <- (Genv.symbol_address ge i i0))). + exploit (MK2 x GPR0 rs1 k). simpl. rewrite gpr_or_zero_not_zero by eauto with asmgen. unfold rs1; Simpl. rewrite Val.add_commut. auto. intros. unfold rs1; Simpl. - intros [rs' [EX' AG']]. - exists rs'; split. apply exec_straight_step with rs1 m. - unfold exec_instr. rewrite gpr_or_zero_zero. f_equal. unfold rs1. f_equal. f_equal. - unfold const_low. rewrite small_data_area_addressing; auto. - apply add_zero_symbol_address. - reflexivity. - assumption. assumption. - (* Abased from relative data *) - set (rs1 := nextinstr (rs#GPR0 <- (rs#x))). - set (rs2 := nextinstr (rs1#temp <- (Val.add Vzero (high_half ge i i0)))). - set (rs3 := nextinstr (rs2#temp <- (Genv.symbol_address ge i i0))). - exploit (MK2 temp GPR0 rs3). + intros [rs' [EX' AG']]. + exists rs'; split. apply exec_straight_step with rs1 m. + unfold exec_instr. rewrite gpr_or_zero_zero. f_equal. unfold rs1. f_equal. f_equal. + unfold const_low. rewrite small_data_area_addressing; auto. + apply add_zero_symbol_address. + reflexivity. + assumption. assumption. + + (* Abased from relative data *) + set (rs1 := nextinstr (rs#GPR0 <- (rs#x))). + set (rs2 := nextinstr (rs1#temp <- (Val.add Vzero (high_half ge i i0)))). + set (rs3 := nextinstr (rs2#temp <- (Genv.symbol_address ge i i0))). + exploit (MK2 temp GPR0 rs3). rewrite gpr_or_zero_not_zero by eauto with asmgen. f_equal. unfold rs3; Simpl. unfold rs3, rs2, rs1; Simpl. intros. unfold rs3, rs2, rs1; Simpl. - intros [rs' [EX' AG']]. - exists rs'. split. eapply exec_straight_trans with (rs2 := rs3) (m2 := m). - apply exec_straight_three with rs1 m rs2 m; auto. - simpl. unfold rs3. f_equal. f_equal. f_equal. rewrite gpr_or_zero_not_zero by auto. - unfold rs2; Simpl. apply low_high_half_zero. - eexact EX'. auto. - (* Abased absolute *) - set (rs1 := nextinstr (rs#temp <- (Val.add (rs x) (high_half ge i i0)))). - exploit (MK1 (Csymbol_low i i0) temp rs1 k). + intros [rs' [EX' AG']]. + exists rs'. split. eapply exec_straight_trans with (rs2 := rs3) (m2 := m). + apply exec_straight_three with rs1 m rs2 m; auto. + simpl. unfold rs3. f_equal. f_equal. f_equal. rewrite gpr_or_zero_not_zero by auto. + unfold rs2; Simpl. apply low_high_half_zero. + eexact EX'. auto. + + (* Abased absolute *) + destruct (unaligned || symbol_ofs_word_aligned i i0). + (* Abased absolute 4 aligned *) + set (rs1 := nextinstr (rs#temp <- (Val.add (rs x) (high_half ge i i0)))). + exploit (MK1 (Csymbol_low i i0) temp rs1 k). simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen. unfold rs1. Simpl. rewrite Val.add_assoc. rewrite low_high_half. rewrite Val.add_commut. auto. intros; unfold rs1; Simpl. - intros [rs' [EX' AG']]. - exists rs'. split. apply exec_straight_step with rs1 m. - unfold exec_instr. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto. - assumption. assumption. - (* Ainstack *) - set (ofs := Ptrofs.to_int i) in *. - assert (L: Val.lessdef (Val.offset_ptr (rs GPR1) i) (Val.add (rs GPR1) (Vint ofs))). - { destruct (rs GPR1); simpl; auto. unfold ofs; rewrite Ptrofs.of_int_to_int; auto. } - destruct (Int.eq (high_s ofs) Int.zero); inv TR. - apply MK1. simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto. - set (rs1 := nextinstr (rs#temp <- (Val.add rs#GPR1 (Vint (Int.shl (high_s ofs) (Int.repr 16)))))). - exploit (MK1 (Cint (low_s ofs)) temp rs1 k). - simpl. rewrite gpr_or_zero_not_zero; auto. - unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss. - rewrite Val.add_assoc. simpl. rewrite low_high_s. auto. - congruence. - intros. unfold rs1. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. - intros [rs' [EX' AG']]. - exists rs'. split. apply exec_straight_step with rs1 m. - unfold exec_instr. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto. - assumption. assumption. + intros [rs' [EX' AG']]. + exists rs'. split. apply exec_straight_step with rs1 m. + unfold exec_instr. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto. + assumption. assumption. + (* Abased absolute non aligned *) + set (rs1 := nextinstr (rs#GPR0 <- (rs#x))). + set (rs2 := nextinstr (rs1#temp <- (Val.add Vzero (high_half ge i i0)))). + set (rs3 := nextinstr (rs2#temp <- (Genv.symbol_address ge i i0))). + exploit (MK2 temp GPR0 rs3). + rewrite gpr_or_zero_not_zero by eauto with asmgen. + f_equal. unfold rs3; Simpl. unfold rs3, rs2, rs1; Simpl. + intros. unfold rs3, rs2, rs1; Simpl. + intros [rs' [EX' AG']]. + exists rs'. split. eapply exec_straight_trans with (rs2 := rs3) (m2 := m). + apply exec_straight_three with rs1 m rs2 m; auto. + simpl. unfold rs3. f_equal. f_equal. f_equal. rewrite gpr_or_zero_not_zero by auto. + unfold rs2; Simpl. apply low_high_half_zero. + eexact EX'. auto. + - (* Ainstack *) + unfold ainstack in *. + set (ofs := Ptrofs.to_int i) in *. + assert (L: Val.lessdef (Val.offset_ptr (rs GPR1) i) (Val.add (rs GPR1) (Vint ofs))). + { destruct (rs GPR1); simpl; auto. unfold ofs; rewrite Ptrofs.of_int_to_int; auto. } + destruct (unaligned || Int.eq (Int.mods ofs (Int.repr 4)) Int.zero); [destruct (Int.eq (high_s ofs) Int.zero)|]; inv TR. + + (* Ainstack short *) + apply MK1. simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto. + + (* Ainstack non short *) + set (rs1 := nextinstr (rs#temp <- (Val.add rs#GPR1 (Vint (Int.shl (high_s ofs) (Int.repr 16)))))). + exploit (MK1 (Cint (low_s ofs)) temp rs1 k). + simpl. rewrite gpr_or_zero_not_zero; auto. + unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss. + rewrite Val.add_assoc. simpl. rewrite low_high_s. auto. + congruence. + intros. unfold rs1. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. + intros [rs' [EX' AG']]. + exists rs'. split. apply exec_straight_step with rs1 m. + unfold exec_instr. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto. + assumption. assumption. + + (* Ainstack non aligned *) + exploit (addimm_correct temp GPR1 ofs (mk1 (Cint Int.zero) temp :: k) rs); eauto with asmgen. + intros [rs1 [A [B C]]]. + exploit (MK1 (Cint Int.zero) temp rs1 k). + rewrite gpr_or_zero_not_zero; auto. rewrite B. simpl. + destruct (rs GPR1); auto. simpl. rewrite Ptrofs.add_zero. + unfold ofs. rewrite Ptrofs.of_int_to_int. auto. auto. + intros. rewrite C; auto. intros [rs2 [EX' AG']]. + exists rs2. split; auto. + eapply exec_straight_trans. eexact A. assumption. Qed. + (** Translation of loads *) Lemma transl_load_correct: @@ -1691,8 +1750,8 @@ Proof. intros. assert (LD: forall v, Val.lessdef a v -> v = a). { intros. inv H2; auto. discriminate H1. } - assert (BASE: forall mk1 mk2 k' chunk' v', - transl_memory_access mk1 mk2 addr args GPR12 k' = OK c -> + assert (BASE: forall mk1 mk2 unaligned k' chunk' v', + transl_memory_access mk1 mk2 unaligned addr args GPR12 k' = OK c -> Mem.loadv chunk' m a = Some v' -> (forall cst (r1: ireg) (rs1: regset), exec_instr ge fn (mk1 cst r1) rs1 m = @@ -1770,8 +1829,8 @@ Local Transparent destroyed_by_store. subst src; simpl; congruence. change (IR GPR12) with (preg_of R12). red; intros; elim n. eapply preg_of_injective; eauto. - assert (BASE: forall mk1 mk2 chunk', - transl_memory_access mk1 mk2 addr args (int_temp_for src) k = OK c -> + assert (BASE: forall mk1 mk2 unaligned chunk', + transl_memory_access mk1 mk2 unaligned addr args (int_temp_for src) k = OK c -> Mem.storev chunk' m a (rs (preg_of src)) = Some m' -> (forall cst (r1: ireg) (rs1: regset), exec_instr ge fn (mk1 cst r1) rs1 m = diff --git a/powerpc/Builtins1.v b/powerpc/Builtins1.v index 9d7aadd9..b3fdebd0 100644 --- a/powerpc/Builtins1.v +++ b/powerpc/Builtins1.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/powerpc/CBuiltins.ml b/powerpc/CBuiltins.ml index e0826877..dc8aa73a 100644 --- a/powerpc/CBuiltins.ml +++ b/powerpc/CBuiltins.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/powerpc/ConstpropOpproof.v b/powerpc/ConstpropOpproof.v index 8687b056..1dd2e0e4 100644 --- a/powerpc/ConstpropOpproof.v +++ b/powerpc/ConstpropOpproof.v @@ -374,7 +374,7 @@ Proof. Int.bit_solve. destruct (zlt i0 n0). replace (Int.testbit n i0) with (negb (Int.testbit Int.zero i0)). rewrite Int.bits_zero. simpl. rewrite andb_true_r. auto. - rewrite <- EQ. rewrite Int.bits_zero_ext by omega. rewrite zlt_true by auto. + rewrite <- EQ. rewrite Int.bits_zero_ext by lia. rewrite zlt_true by auto. rewrite Int.bits_not by auto. apply negb_involutive. rewrite H6 by auto. auto. econstructor; split; eauto. auto. diff --git a/powerpc/Conventions1.v b/powerpc/Conventions1.v index 5c9cbd4f..f05e77df 100644 --- a/powerpc/Conventions1.v +++ b/powerpc/Conventions1.v @@ -268,7 +268,7 @@ Remark loc_arguments_rec_charact: forall_rpair (loc_argument_charact ofs) p. Proof. assert (X: forall ofs1 ofs2 l, loc_argument_charact ofs2 l -> ofs1 <= ofs2 -> loc_argument_charact ofs1 l). - { destruct l; simpl; intros; auto. destruct sl; auto. intuition omega. } + { destruct l; simpl; intros; auto. destruct sl; auto. intuition lia. } assert (Y: forall ofs1 ofs2 p, forall_rpair (loc_argument_charact ofs2) p -> ofs1 <= ofs2 -> forall_rpair (loc_argument_charact ofs1) p). { destruct p; simpl; intuition eauto. } Opaque list_nth_z. @@ -279,52 +279,52 @@ Opaque list_nth_z. destruct (list_nth_z int_param_regs ir) as [r|] eqn:E; destruct H. subst. left. eapply list_nth_z_in; eauto. eapply IHtyl; eauto. - subst. split. omega. apply Z.divide_1_l. - eapply Y; eauto. omega. + subst. split. lia. apply Z.divide_1_l. + eapply Y; eauto. lia. - (* float *) - assert (ofs <= align ofs 2) by (apply align_le; omega). + assert (ofs <= align ofs 2) by (apply align_le; lia). destruct (list_nth_z float_param_regs fr) as [r|] eqn:E; destruct H. subst. right. eapply list_nth_z_in; eauto. eapply IHtyl; eauto. - subst. split. omega. apply Z.divide_1_l. - eapply Y; eauto. omega. + subst. split. lia. apply Z.divide_1_l. + eapply Y; eauto. lia. - (* long *) - assert (ofs <= align ofs 2) by (apply align_le; omega). + assert (ofs <= align ofs 2) by (apply align_le; lia). set (ir' := align ir 2) in *. destruct (list_nth_z int_param_regs ir') as [r1|] eqn:E1. destruct (list_nth_z int_param_regs (ir' + 1)) as [r2|] eqn:E2. destruct H. subst; split; left; eapply list_nth_z_in; eauto. eapply IHtyl; eauto. destruct H. - subst. destruct Archi.ptr64; [split|split;split]; try omega. - apply align_divides; omega. apply Z.divide_1_l. apply Z.divide_1_l. - eapply Y; eauto. omega. + subst. destruct Archi.ptr64; [split|split;split]; try lia. + apply align_divides; lia. apply Z.divide_1_l. apply Z.divide_1_l. + eapply Y; eauto. lia. destruct H. - subst. destruct Archi.ptr64; [split|split;split]; try omega. - apply align_divides; omega. apply Z.divide_1_l. apply Z.divide_1_l. - eapply Y; eauto. omega. + subst. destruct Archi.ptr64; [split|split;split]; try lia. + apply align_divides; lia. apply Z.divide_1_l. apply Z.divide_1_l. + eapply Y; eauto. lia. - (* single *) - assert (ofs <= align ofs 1) by (apply align_le; omega). - assert (ofs <= align ofs 2) by (apply align_le; omega). + assert (ofs <= align ofs 1) by (apply align_le; lia). + assert (ofs <= align ofs 2) by (apply align_le; lia). destruct (list_nth_z float_param_regs fr) as [r|] eqn:E; destruct H. subst. right. eapply list_nth_z_in; eauto. eapply IHtyl; eauto. - subst. split. destruct Archi.single_passed_as_single; simpl; omega. + subst. split. destruct Archi.single_passed_as_single; simpl; lia. destruct Archi.single_passed_as_single; simpl; apply Z.divide_1_l. - eapply Y; eauto. destruct Archi.single_passed_as_single; simpl; omega. + eapply Y; eauto. destruct Archi.single_passed_as_single; simpl; lia. - (* any32 *) destruct (list_nth_z int_param_regs ir) as [r|] eqn:E; destruct H. subst. left. eapply list_nth_z_in; eauto. eapply IHtyl; eauto. - subst. split. omega. apply Z.divide_1_l. - eapply Y; eauto. omega. + subst. split. lia. apply Z.divide_1_l. + eapply Y; eauto. lia. - (* float *) - assert (ofs <= align ofs 2) by (apply align_le; omega). + assert (ofs <= align ofs 2) by (apply align_le; lia). destruct (list_nth_z float_param_regs fr) as [r|] eqn:E; destruct H. subst. right. eapply list_nth_z_in; eauto. eapply IHtyl; eauto. - subst. split. omega. apply Z.divide_1_l. - eapply Y; eauto. omega. + subst. split. lia. apply Z.divide_1_l. + eapply Y; eauto. lia. Qed. Lemma loc_arguments_acceptable: @@ -341,7 +341,7 @@ Proof. unfold forall_rpair; destruct p; intuition auto. Qed. -Hint Resolve loc_arguments_acceptable: locs. +Global Hint Resolve loc_arguments_acceptable: locs. Lemma loc_arguments_main: loc_arguments signature_main = nil. @@ -349,8 +349,9 @@ Proof. reflexivity. Qed. -(** ** Normalization of function results *) +(** ** Normalization of function results and parameters *) (** No normalization needed. *) Definition return_value_needs_normalization (t: rettype) := false. +Definition parameter_needs_normalization (t: rettype) := false. diff --git a/powerpc/Machregs.v b/powerpc/Machregs.v index 07622a0e..9967bbae 100644 --- a/powerpc/Machregs.v +++ b/powerpc/Machregs.v @@ -166,7 +166,7 @@ Definition destroyed_by_op (op: operation): list mreg := | Ofloatconst _ => R12 :: nil | Osingleconst _ => R12 :: nil | Olongconst _ => R12 :: nil - | Ointoffloat | Ointuoffloat => F13 :: nil + | Ointoffloat => F13 :: nil | Olongoffloat => F13 :: nil | Oaddlimm _ => R12 :: nil | Oandlimm _ => R12 :: nil diff --git a/powerpc/NeedOp.v b/powerpc/NeedOp.v index 5ea09bd8..85dd9b2e 100644 --- a/powerpc/NeedOp.v +++ b/powerpc/NeedOp.v @@ -61,7 +61,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Onegfs | Oabsfs => op1 (default nv) | Oaddfs | Osubfs | Omulfs | Odivfs => op2 (default nv) | Osingleoffloat | Ofloatofsingle => op1 (default nv) - | Ointoffloat | Ointuoffloat | Ofloatofint | Ofloatofintu => op1 (default nv) + | Ointoffloat => op1 (default nv) | Ofloatofwords | Omakelong => op2 (default nv) | Olowlong | Ohighlong => op1 (default nv) | Ocmp c => needs_of_condition c @@ -162,8 +162,8 @@ Lemma operation_is_redundant_sound: vagree v arg1' nv. Proof. intros. destruct op; simpl in *; try discriminate; inv H1; FuncInv; subst. -- apply sign_ext_redundant_sound; auto. omega. -- apply sign_ext_redundant_sound; auto. omega. +- apply sign_ext_redundant_sound; auto. lia. +- apply sign_ext_redundant_sound; auto. lia. - apply andimm_redundant_sound; auto. - apply orimm_redundant_sound; auto. - apply rolm_redundant_sound; auto. diff --git a/powerpc/Op.v b/powerpc/Op.v index 0f082c1f..a96a0439 100644 --- a/powerpc/Op.v +++ b/powerpc/Op.v @@ -105,7 +105,7 @@ Inductive operation : Type := | Osubl: operation (**r [rd = r1 - r2] *) | Onegl: operation (**r [rd = - r1] *) | Omull: operation (**r [rd = r1 * r2] *) - | Omullhs: operation (**r [rd = high part of r1 * r2, signed] *) + | Omullhs: operation (**r [rd = high part of r1 * r2, signed] *) | Omullhu: operation (**r [rd = high part of r1 * r2, unsigned] *) | Odivl: operation (**r [rd = r1 / r2] (signed) *) | Odivlu: operation (**r [rd = r1 / r2] (unsigned) *) @@ -141,9 +141,6 @@ Inductive operation : Type := | Ofloatofsingle: operation (**r [rd] is [r1] extended to double-precision float *) (*c Conversions between int and float: *) | Ointoffloat: operation (**r [rd = signed_int_of_float(r1)] *) - | Ointuoffloat: operation (**r [rd = unsigned_int_of_float(r1)] (PPC64 only) *) - | Ofloatofint: operation (**r [rd = float_of_signed_int(r1)] (PPC64 only) *) - | Ofloatofintu: operation (**r [rd = float_of_unsigned_int(r1)] (PPC64 only *) | Ofloatofwords: operation (**r [rd = float_of_words(r1,r2)] *) (*c Manipulating 64-bit integers: *) | Omakelong: operation (**r [rd = r1 << 32 | r2] *) @@ -299,9 +296,6 @@ Definition eval_operation | Osingleoffloat, v1::nil => Some(Val.singleoffloat v1) | Ofloatofsingle, v1::nil => Some(Val.floatofsingle v1) | Ointoffloat, v1::nil => Val.intoffloat v1 - | Ointuoffloat, v1::nil => Val.intuoffloat v1 - | Ofloatofint, v1::nil => Val.floatofint v1 - | Ofloatofintu, v1::nil => Val.floatofintu v1 | Ofloatofwords, v1::v2::nil => Some(Val.floatofwords v1 v2) | Omakelong, v1::v2::nil => Some(Val.longofwords v1 v2) | Olowlong, v1::nil => Some(Val.loword v1) @@ -449,9 +443,6 @@ Definition type_of_operation (op: operation) : list typ * typ := | Osingleoffloat => (Tfloat :: nil, Tsingle) | Ofloatofsingle => (Tsingle :: nil, Tfloat) | Ointoffloat => (Tfloat :: nil, Tint) - | Ointuoffloat => (Tfloat :: nil, Tint) - | Ofloatofint => (Tint :: nil, Tfloat) - | Ofloatofintu => (Tint :: nil, Tfloat) | Ofloatofwords => (Tint :: Tint :: nil, Tfloat) | Omakelong => (Tint :: Tint :: nil, Tlong) | Olowlong => (Tlong :: nil, Tint) @@ -570,9 +561,6 @@ Proof with (try exact I; try reflexivity). destruct v0... destruct v0... destruct v0; simpl in H0; inv H0. destruct (Float.to_int f); inv H2... - destruct v0; simpl in H0; inv H0. destruct (Float.to_intu f); inv H2... - destruct v0; simpl in H0; inv H0... - destruct v0; simpl in H0; inv H0... destruct v0; destruct v1... destruct v0; destruct v1... destruct v0... @@ -999,10 +987,6 @@ Proof. inv H4; simpl; auto. inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_int f0); simpl in H2; inv H2. exists (Vint i); auto. - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_intu f0); simpl in H2; inv H2. - exists (Vint i); auto. - inv H4; simpl in H1; inv H1; simpl. TrivialExists. - inv H4; simpl in H1; inv H1; simpl. TrivialExists. inv H4; inv H2; simpl; auto. inv H4; inv H2; simpl; auto. inv H4; simpl; auto. diff --git a/powerpc/SelectLongproof.v b/powerpc/SelectLongproof.v index f16c967e..ea14668f 100644 --- a/powerpc/SelectLongproof.v +++ b/powerpc/SelectLongproof.v @@ -221,15 +221,15 @@ Proof. change (Int64.unsigned Int64.iwordsize) with 64. f_equal. rewrite Int.unsigned_repr. - apply eqmod_mod_eq. omega. + apply eqmod_mod_eq. lia. apply eqmod_trans with a. apply eqmod_divides with Int.modulus. apply Int.eqm_sym. apply Int.eqm_unsigned_repr. exists (two_p (32-6)); auto. apply eqmod_divides with Int64.modulus. apply Int64.eqm_unsigned_repr. exists (two_p (64-6)); auto. - assert (0 <= Int.unsigned (Int.repr a) mod 64 < 64) by (apply Z_mod_lt; omega). + assert (0 <= Int.unsigned (Int.repr a) mod 64 < 64) by (apply Z_mod_lt; lia). assert (64 < Int.max_unsigned) by (compute; auto). - omega. + lia. - InvEval. TrivialExists. simpl. rewrite <- H. unfold Val.rolml; destruct v1; simpl; auto. unfold Int64.rolm. rewrite Int64.rol_and. rewrite Int64.and_assoc. auto. diff --git a/powerpc/SelectOp.vp b/powerpc/SelectOp.vp index ba6612e8..cd9a65df 100644 --- a/powerpc/SelectOp.vp +++ b/powerpc/SelectOp.vp @@ -468,7 +468,7 @@ Definition intoffloat (e: expr) := Eop Ointoffloat (e ::: Enil). Definition intuoffloat (e: expr) := if Archi.ppc64 then - Eop Ointuoffloat (e ::: Enil) + Eop Olowlong (Eop Olongoffloat (e ::: Enil) ::: Enil) else Elet e (Elet (Eop (Ofloatconst (Float.of_intu Float.ox8000_0000)) Enil) @@ -482,7 +482,8 @@ Nondetfunction floatofintu (e: expr) := Eop (Ofloatconst (Float.of_intu n)) Enil | _ => if Archi.ppc64 then - Eop Ofloatofintu (e ::: Enil) else + Eop Ofloatoflong (Eop Ocast32unsigned (e ::: Enil) ::: Enil) + else subf (Eop Ofloatofwords (Eop (Ointconst Float.ox4330_0000) Enil ::: e ::: Enil)) (Eop (Ofloatconst (Float.from_words Float.ox4330_0000 Int.zero)) Enil) end. @@ -493,7 +494,8 @@ Nondetfunction floatofint (e: expr) := Eop (Ofloatconst (Float.of_int n)) Enil | _ => if Archi.ppc64 then - Eop Ofloatofint (e ::: Enil) else + Eop Ofloatoflong (Eop Ocast32signed (e ::: Enil) ::: Enil) + else subf (Eop Ofloatofwords (Eop (Ointconst Float.ox4330_0000) Enil ::: addimm Float.ox8000_0000 e ::: Enil)) (Eop (Ofloatconst (Float.from_words Float.ox4330_0000 Float.ox8000_0000)) Enil) diff --git a/powerpc/SelectOpproof.v b/powerpc/SelectOpproof.v index c3eda068..adac6c34 100644 --- a/powerpc/SelectOpproof.v +++ b/powerpc/SelectOpproof.v @@ -805,7 +805,7 @@ Qed. Theorem eval_cast8unsigned: unary_constructor_sound cast8unsigned (Val.zero_ext 8). Proof. red; intros. unfold cast8unsigned. - rewrite Val.zero_ext_and. apply eval_andimm; auto. omega. + rewrite Val.zero_ext_and. apply eval_andimm; auto. lia. Qed. Theorem eval_cast16signed: unary_constructor_sound cast16signed (Val.sign_ext 16). @@ -818,7 +818,7 @@ Qed. Theorem eval_cast16unsigned: unary_constructor_sound cast16unsigned (Val.zero_ext 16). Proof. red; intros. unfold cast16unsigned. - rewrite Val.zero_ext_and. apply eval_andimm; auto. omega. + rewrite Val.zero_ext_and. apply eval_andimm; auto. lia. Qed. Theorem eval_singleoffloat: unary_constructor_sound singleoffloat Val.singleoffloat. @@ -851,8 +851,13 @@ Proof. destruct (Float.to_intu f) as [n|] eqn:?; simpl in H0; inv H0. exists (Vint n); split; auto. unfold intuoffloat. destruct Archi.ppc64. - econstructor. constructor; eauto. constructor. simpl; rewrite Heqo; auto. - set (im := Int.repr Int.half_modulus). +- apply Float.to_intu_to_long in Heqo. + econstructor. constructor. econstructor. econstructor; eauto. constructor. + simpl; rewrite Heqo; simpl; eauto. constructor. + simpl. unfold Int64.loword. rewrite Int64.unsigned_repr, Int.repr_unsigned. auto. + assert (Int.modulus < Int64.max_unsigned) by (compute; auto). + generalize (Int.unsigned_range n). lia. +- set (im := Int.repr Int.half_modulus). set (fm := Float.of_intu im). assert (eval_expr ge sp e m (Vfloat fm :: Vfloat f :: le) (Eletvar (S O)) (Vfloat f)). constructor. auto. @@ -889,11 +894,12 @@ Theorem eval_floatofint: Proof. intros until y. unfold floatofint. destruct (floatofint_match a); intros. InvEval. TrivialExists. - destruct Archi.ppc64. - TrivialExists. rename e0 into a. destruct x; simpl in H0; inv H0. exists (Vfloat (Float.of_int i)); split; auto. - set (t1 := addimm Float.ox8000_0000 a). + destruct Archi.ppc64. +- rewrite Float.of_int_of_long. + EvalOp. constructor. EvalOp. simpl; eauto. constructor. auto. +- set (t1 := addimm Float.ox8000_0000 a). set (t2 := Eop Ofloatofwords (Eop (Ointconst Float.ox4330_0000) Enil ::: t1 ::: Enil)). set (t3 := Eop (Ofloatconst (Float.from_words Float.ox4330_0000 Float.ox8000_0000)) Enil). exploit (eval_addimm Float.ox8000_0000 le a). eauto. fold t1. @@ -913,12 +919,12 @@ Theorem eval_floatofintu: Proof. intros until y. unfold floatofintu. destruct (floatofintu_match a); intros. InvEval. TrivialExists. - destruct Archi.ppc64. - TrivialExists. rename e0 into a. destruct x; simpl in H0; inv H0. exists (Vfloat (Float.of_intu i)); split; auto. - unfold floatofintu. - set (t2 := Eop Ofloatofwords (Eop (Ointconst Float.ox4330_0000) Enil ::: a ::: Enil)). + destruct Archi.ppc64. +- rewrite Float.of_intu_of_long. + EvalOp. constructor. EvalOp. simpl; eauto. constructor. auto. +- set (t2 := Eop Ofloatofwords (Eop (Ointconst Float.ox4330_0000) Enil ::: a ::: Enil)). set (t3 := Eop (Ofloatconst (Float.from_words Float.ox4330_0000 Int.zero)) Enil). exploit (eval_subf le t2). unfold t2. EvalOp. constructor. EvalOp. simpl; eauto. constructor. eauto. constructor. diff --git a/powerpc/Stacklayout.v b/powerpc/Stacklayout.v index cb3806bd..32b11ad5 100644 --- a/powerpc/Stacklayout.v +++ b/powerpc/Stacklayout.v @@ -77,11 +77,11 @@ Local Opaque Z.add Z.mul sepconj range. set (ostkdata := align oendcs 8). generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros. unfold fe_ofs_arg. - assert (8 + 4 * b.(bound_outgoing) <= ol) by (apply align_le; omega). - assert (ol <= ora) by (unfold ora; omega). - assert (ora <= ocs) by (unfold ocs; omega). + assert (8 + 4 * b.(bound_outgoing) <= ol) by (apply align_le; lia). + assert (ol <= ora) by (unfold ora; lia). + assert (ora <= ocs) by (unfold ocs; lia). assert (ocs <= oendcs) by (apply size_callee_save_area_incr). - assert (oendcs <= ostkdata) by (apply align_le; omega). + assert (oendcs <= ostkdata) by (apply align_le; lia). (* Reorder as: back link outgoing @@ -90,12 +90,12 @@ Local Opaque Z.add Z.mul sepconj range. callee-save *) rewrite sep_swap3. (* Apply range_split and range_split2 repeatedly *) - apply range_drop_right with 8. omega. - apply range_split. omega. - apply range_split_2. fold ol; omega. omega. - apply range_split. omega. - apply range_split. omega. - apply range_drop_right with ostkdata. omega. + apply range_drop_right with 8. lia. + apply range_split. lia. + apply range_split_2. fold ol; lia. lia. + apply range_split. lia. + apply range_split. lia. + apply range_drop_right with ostkdata. lia. eapply sep_drop2. eexact H. Qed. @@ -112,12 +112,12 @@ Proof. set (ostkdata := align oendcs 8). generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros. unfold fe_ofs_arg. - assert (8 + 4 * b.(bound_outgoing) <= ol) by (apply align_le; omega). - assert (ol <= ora) by (unfold ora; omega). - assert (ora <= ocs) by (unfold ocs; omega). + assert (8 + 4 * b.(bound_outgoing) <= ol) by (apply align_le; lia). + assert (ol <= ora) by (unfold ora; lia). + assert (ora <= ocs) by (unfold ocs; lia). assert (ocs <= oendcs) by (apply size_callee_save_area_incr). - assert (oendcs <= ostkdata) by (apply align_le; omega). - split. omega. apply align_le. omega. + assert (oendcs <= ostkdata) by (apply align_le; lia). + split. lia. apply align_le. lia. Qed. Lemma frame_env_aligned: @@ -136,10 +136,10 @@ Proof. set (oendcs := size_callee_save_area b ocs). set (ostkdata := align oendcs 8). split. exists (fe_ofs_arg / 8); reflexivity. - split. apply align_divides; omega. - split. apply align_divides; omega. + split. apply align_divides; lia. + split. apply align_divides; lia. split. apply Z.divide_0_r. apply Z.divide_add_r. - apply Z.divide_trans with 8. exists 2; auto. apply align_divides; omega. + apply Z.divide_trans with 8. exists 2; auto. apply align_divides; lia. apply Z.divide_factor_l. Qed. diff --git a/powerpc/TargetPrinter.ml b/powerpc/TargetPrinter.ml index 0f608d25..52d30e33 100644 --- a/powerpc/TargetPrinter.ml +++ b/powerpc/TargetPrinter.ml @@ -118,22 +118,16 @@ module Linux_System : SYSTEM = let name_of_section = function | Section_text -> ".text" | Section_data i -> - if i then - ".data" - else - common_section ~sec:".section .bss" () + variable_section ~sec:".data" ~bss:".section .bss" i | Section_small_data i -> - if i then - ".section .sdata,\"aw\",@progbits" - else - common_section ~sec:".section .sbss,\"aw\",@nobits" () + variable_section + ~sec:".section .sdata,\"aw\",@progbits" + ~bss:".section .sbss,\"aw\",@nobits" + i | Section_const i -> - if i || (not !Clflags.option_fcommon) then ".rodata" else "COMM" + variable_section ~sec:".rodata" i | Section_small_const i -> - if i || (not !Clflags.option_fcommon) then - ".section .sdata2,\"a\",@progbits" - else - "COMM" + variable_section ~sec:".section .sdata2,\"a\",@progbits" i | Section_string -> ".rodata" | Section_literal -> ".section .rodata.cst8,\"aM\",@progbits,8" | Section_jumptable -> ".text" @@ -218,8 +212,10 @@ module Diab_System : SYSTEM = let name_of_section = function | Section_text -> ".text" - | Section_data i -> if i then ".data" else common_section () - | Section_small_data i -> if i then ".sdata" else ".sbss" + | Section_data i -> + variable_section ~sec:".data" ~bss:".bss" i + | Section_small_data i -> + variable_section ~sec:".sdata" ~bss:".sbss" ~common:false i | Section_const _ -> ".text" | Section_small_const _ -> ".sdata2" | Section_string -> ".text" @@ -553,22 +549,16 @@ module Target (System : SYSTEM):TARGET = fprintf oc " fadds %a, %a, %a\n" freg r1 freg r2 freg r3 | Pfcmpu(r1, r2) -> fprintf oc " fcmpu %a, %a, %a\n" creg 0 freg r1 freg r2 - | Pfcfi(r1, r2) -> - assert false | Pfcfl(r1, r2) -> assert false | Pfcfid(r1, r2) -> fprintf oc " fcfid %a, %a\n" freg r1 freg r2 - | Pfcfiu(r1, r2) -> - assert false | Pfcti(r1, r2) -> assert false | Pfctid(r1, r2) -> assert false | Pfctidz(r1, r2) -> fprintf oc " fctidz %a, %a\n" freg r1 freg r2 - | Pfctiu(r1, r2) -> - assert false | Pfctiw(r1, r2) -> fprintf oc " fctiw %a, %a\n" freg r1 freg r2 | Pfctiwz(r1, r2) -> diff --git a/powerpc/ValueAOp.v b/powerpc/ValueAOp.v index a270d857..c81f1a6c 100644 --- a/powerpc/ValueAOp.v +++ b/powerpc/ValueAOp.v @@ -133,9 +133,6 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Osingleoffloat, v1::nil => singleoffloat v1 | Ofloatofsingle, v1::nil => floatofsingle v1 | Ointoffloat, v1::nil => intoffloat v1 - | Ointuoffloat, v1::nil => intuoffloat v1 - | Ofloatofint, v1::nil => floatofint v1 - | Ofloatofintu, v1::nil => floatofintu v1 | Ofloatofwords, v1::v2::nil => floatofwords v1 v2 | Omakelong, v1::v2::nil => longofwords v1 v2 | Olowlong, v1::nil => loword v1 diff --git a/powerpc/extractionMachdep.v b/powerpc/extractionMachdep.v index a3e945bf..202f4436 100644 --- a/powerpc/extractionMachdep.v +++ b/powerpc/extractionMachdep.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -21,6 +22,7 @@ Extract Constant Asm.high_half => "fun _ _ _ -> assert false". Extract Constant Asm.symbol_is_small_data => "C2C.atom_is_small_data". Extract Constant Asm.small_data_area_offset => "fun _ _ _ -> assert false". Extract Constant Asm.symbol_is_rel_data => "C2C.atom_is_rel_data". +Extract Constant Asm.symbol_is_aligned => "C2C.atom_is_aligned". (* Suppression of stupidly big equality functions *) Extract Constant Asm.ireg_eq => "fun (x: ireg) (y: ireg) -> x = y". diff --git a/riscV/Archi.v b/riscV/Archi.v index 1b24e732..9e561ca8 100644 --- a/riscV/Archi.v +++ b/riscV/Archi.v @@ -7,10 +7,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/riscV/Asm.v b/riscV/Asm.v index dc410a3b..a47573a2 100644 --- a/riscV/Asm.v +++ b/riscV/Asm.v @@ -256,7 +256,9 @@ Inductive instruction : Type := (* floating point register move *) | Pfmv (rd: freg) (rs: freg) (**r move *) | Pfmvxs (rd: ireg) (rs: freg) (**r move FP single to integer register *) + | Pfmvsx (rd: freg) (rs: ireg) (**r move integer register to FP single *) | Pfmvxd (rd: ireg) (rs: freg) (**r move FP double to integer register *) + | Pfmvdx (rd: freg) (rs: ireg) (**r move integer register to FP double *) (* 32-bit (single-precision) floating point *) | Pfls (rd: freg) (ra: ireg) (ofs: offset) (**r load float *) @@ -969,7 +971,9 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pfence | Pfmvxs _ _ + | Pfmvsx _ _ | Pfmvxd _ _ + | Pfmvdx _ _ | Pfmins _ _ _ | Pfmaxs _ _ _ @@ -1076,7 +1080,7 @@ Inductive step: state -> trace -> state -> Prop := rs' = nextinstr (set_res res vres (undef_regs (map preg_of (destroyed_by_builtin ef)) - (rs#X31 <- Vundef))) -> + (rs #X1 <- Vundef #X31 <- Vundef))) -> step (State rs m) t (State rs' m') | exec_step_external: forall b ef args res rs m t rs' m', @@ -1157,7 +1161,7 @@ Ltac Equalities := split. auto. intros. destruct B; auto. subst. auto. - (* trace length *) red; intros. inv H; simpl. - omega. + lia. eapply external_call_trace_length; eauto. eapply external_call_trace_length; eauto. - (* initial states *) diff --git a/riscV/Asmexpand.ml b/riscV/Asmexpand.ml index 810514a3..dc0ec184 100644 --- a/riscV/Asmexpand.ml +++ b/riscV/Asmexpand.ml @@ -24,6 +24,7 @@ open Asmexpandaux open AST open Camlcoq open! Integers +open Locations exception Error of string @@ -50,6 +51,86 @@ let expand_addptrofs dst src n = let expand_storeind_ptr src base ofs = List.iter emit (Asmgen.storeind_ptr src base ofs []) +(* Fix-up code around function calls and function entry. + Some floating-point arguments residing in FP registers need to be + moved to integer registers or register pairs. + Symmetrically, some floating-point parameter passed in integer + registers or register pairs need to be moved to FP registers. *) + +let int_param_regs = [| X10; X11; X12; X13; X14; X15; X16; X17 |] + +let move_single_arg fr i = + emit (Pfmvxs(int_param_regs.(i), fr)) + +let move_double_arg fr i = + if Archi.ptr64 then begin + emit (Pfmvxd(int_param_regs.(i), fr)) + end else begin + emit (Paddiw(X2, X X2, Integers.Int.neg _16)); + emit (Pfsd(fr, X2, Ofsimm _0)); + emit (Plw(int_param_regs.(i), X2, Ofsimm _0)); + if i < 7 then begin + emit (Plw(int_param_regs.(i + 1), X2, Ofsimm _4)) + end else begin + emit (Plw(X31, X2, Ofsimm _4)); + emit (Psw(X31, X2, Ofsimm _16)) + end; + emit (Paddiw(X2, X X2, _16)) + end + +let move_single_param fr i = + emit (Pfmvsx(fr, int_param_regs.(i))) + +let move_double_param fr i = + if Archi.ptr64 then begin + emit (Pfmvdx(fr, int_param_regs.(i))) + end else begin + emit (Paddiw(X2, X X2, Integers.Int.neg _16)); + emit (Psw(int_param_regs.(i), X2, Ofsimm _0)); + if i < 7 then begin + emit (Psw(int_param_regs.(i + 1), X2, Ofsimm _4)) + end else begin + emit (Plw(X31, X2, Ofsimm _16)); + emit (Psw(X31, X2, Ofsimm _4)) + end; + emit (Pfld(fr, X2, Ofsimm _0)); + emit (Paddiw(X2, X X2, _16)) + end + +let float_extra_index = function + | Machregs.F0 -> Some (F0, 0) + | Machregs.F1 -> Some (F1, 1) + | Machregs.F2 -> Some (F2, 2) + | Machregs.F3 -> Some (F3, 3) + | Machregs.F4 -> Some (F4, 4) + | Machregs.F5 -> Some (F5, 5) + | Machregs.F6 -> Some (F6, 6) + | Machregs.F7 -> Some (F7, 7) + | _ -> None + +let fixup_gen single double sg = + let fixup ty loc = + match ty, loc with + | Tsingle, One (R r) -> + begin match float_extra_index r with + | Some(r, i) -> single r i + | None -> () + end + | (Tfloat | Tany64), One (R r) -> + begin match float_extra_index r with + | Some(r, i) -> double r i + | None -> () + end + | _, _ -> () + in + List.iter2 fixup sg.sig_args (Conventions1.loc_arguments sg) + +let fixup_call sg = + fixup_gen move_single_arg move_double_arg sg + +let fixup_function_entry sg = + fixup_gen move_single_param move_double_param sg + (* Built-ins. They come in two flavors: - annotation statements: take their arguments in registers or stack locations; generate no code; @@ -57,51 +138,6 @@ let expand_storeind_ptr src base ofs = registers. *) -(* Fix-up code around calls to variadic functions. Floating-point arguments - residing in FP registers need to be moved to integer registers. *) - -let int_param_regs = [| X10; X11; X12; X13; X14; X15; X16; X17 |] -let float_param_regs = [| F10; F11; F12; F13; F14; F15; F16; F17 |] - -let rec fixup_variadic_call ri rf tyl = - if ri < 8 then - match tyl with - | [] -> - () - | (Tint | Tany32) :: tyl -> - fixup_variadic_call (ri + 1) rf tyl - | Tsingle :: tyl -> - let rs = float_param_regs.(rf) - and rd = int_param_regs.(ri) in - emit (Pfmvxs(rd, rs)); - fixup_variadic_call (ri + 1) (rf + 1) tyl - | Tlong :: tyl -> - let ri' = if Archi.ptr64 then ri + 1 else align ri 2 + 2 in - fixup_variadic_call ri' rf tyl - | (Tfloat | Tany64) :: tyl -> - if Archi.ptr64 then begin - let rs = float_param_regs.(rf) - and rd = int_param_regs.(ri) in - emit (Pfmvxd(rd, rs)); - fixup_variadic_call (ri + 1) (rf + 1) tyl - end else begin - let ri = align ri 2 in - if ri < 8 then begin - let rs = float_param_regs.(rf) - and rd1 = int_param_regs.(ri) - and rd2 = int_param_regs.(ri + 1) in - emit (Paddiw(X2, X X2, Integers.Int.neg _16)); - emit (Pfsd(rs, X2, Ofsimm _0)); - emit (Plw(rd1, X2, Ofsimm _0)); - emit (Plw(rd2, X2, Ofsimm _4)); - emit (Paddiw(X2, X X2, _16)); - fixup_variadic_call (ri + 2) (rf + 1) tyl - end - end - -let fixup_call sg = - if sg.sig_cc.cc_vararg then fixup_variadic_call 0 0 sg.sig_args - (* Handling of annotations *) let expand_annot_val kind txt targ args res = @@ -305,18 +341,53 @@ let expand_builtin_vstore chunk args = (* Handling of varargs *) -(* Size in words of the arguments to a function. This includes both - arguments passed in registers and arguments passed on stack. *) +(* Number of integer registers, FP registers, and stack words + used to pass the (fixed) arguments to a function. *) + +let arg_int_size ri rf ofs k = + if ri < 8 + then k (ri + 1) rf ofs + else k ri rf (ofs + 1) + +let arg_single_size ri rf ofs k = + if rf < 8 + then k ri (rf + 1) ofs + else arg_int_size ri rf ofs k + +let arg_long_size ri rf ofs k = + if Archi.ptr64 then + if ri < 8 + then k (ri + 1) rf ofs + else k ri rf (ofs + 1) + else + if ri < 7 then k (ri + 2) rf ofs + else if ri = 7 then k (ri + 1) rf (ofs + 1) + else k ri rf (align ofs 2 + 2) + +let arg_double_size ri rf ofs k = + if rf < 8 + then k ri (rf + 1) ofs + else arg_long_size ri rf ofs k + +let rec args_size l ri rf ofs = + match l with + | [] -> (ri, rf, ofs) + | (Tint | Tany32) :: l -> + arg_int_size ri rf ofs (args_size l) + | Tsingle :: l -> + arg_single_size ri rf ofs (args_size l) + | Tlong :: l -> + arg_long_size ri rf ofs (args_size l) + | (Tfloat | Tany64) :: l -> + arg_double_size ri rf ofs (args_size l) -let rec args_size sz = function - | [] -> sz - | (Tint | Tsingle | Tany32) :: l -> - args_size (sz + 1) l - | (Tlong | Tfloat | Tany64) :: l -> - args_size (if Archi.ptr64 then sz + 1 else align sz 2 + 2) l +(* Size in words of the arguments to a function. This includes both + arguments passed in integer registers and arguments passed on stack, + but not arguments passed in FP registers. *) let arguments_size sg = - args_size 0 sg.sig_args + let (ri, _, ofs) = args_size sg.sig_args 0 0 0 in + ri + ofs let save_arguments first_reg base_ofs = for i = first_reg to 7 do @@ -575,8 +646,12 @@ let expand_builtin_inline name args res = (fun rl -> emit (Pmulw (rl, X a, X b)); emit (Pmulhuw (rh, X a, X b))) + (* No operation *) | "__builtin_nop", [], _ -> emit Pnop + (* Optimization hint *) + | "__builtin_unreachable", [], _ -> + () (* Catch-all *) | _ -> raise (Error ("unrecognized builtin " ^ name)) @@ -588,7 +663,7 @@ let expand_instruction instr = | Pallocframe (sz, ofs) -> let sg = get_current_function_sig() in emit (Pmv (X30, X2)); - if sg.sig_cc.cc_vararg then begin + if (sg.sig_cc.cc_vararg <> None) then begin let n = arguments_size sg in let extra_sz = if n >= 8 then 0 else align ((8 - n) * wordsize) 16 in let full_sz = Z.add sz (Z.of_uint extra_sz) in @@ -606,7 +681,7 @@ let expand_instruction instr = | Pfreeframe (sz, ofs) -> let sg = get_current_function_sig() in let extra_sz = - if sg.sig_cc.cc_vararg then begin + if (sg.sig_cc.cc_vararg <> None) then begin let n = arguments_size sg in if n >= 8 then 0 else align ((8 - n) * wordsize) 16 end else 0 in @@ -706,6 +781,7 @@ let preg_to_dwarf = function let expand_function id fn = try set_current_function fn; + fixup_function_entry fn.fn_sig; expand id (* sp= *) 2 preg_to_dwarf expand_instruction fn.fn_code; Errors.OK (get_current_function ()) with Error s -> diff --git a/riscV/Asmgenproof.v b/riscV/Asmgenproof.v index 5ec57886..798dad9f 100644 --- a/riscV/Asmgenproof.v +++ b/riscV/Asmgenproof.v @@ -67,7 +67,7 @@ Lemma transf_function_no_overflow: transf_function f = OK tf -> list_length_z tf.(fn_code) <= Ptrofs.max_unsigned. Proof. intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. - omega. + lia. Qed. Lemma exec_straight_exec: @@ -432,8 +432,8 @@ Proof. split. unfold goto_label. rewrite P. rewrite H1. auto. split. rewrite Pregmap.gss. constructor; auto. rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. - auto. omega. - generalize (transf_function_no_overflow _ _ H0). omega. + auto. lia. + generalize (transf_function_no_overflow _ _ H0). lia. intros. apply Pregmap.gso; auto. Qed. @@ -835,13 +835,15 @@ Local Transparent destroyed_by_op. econstructor; eauto. instantiate (2 := tf); instantiate (1 := x). unfold nextinstr. rewrite Pregmap.gss. - rewrite set_res_other. rewrite undef_regs_other_2. rewrite Pregmap.gso by congruence. + rewrite set_res_other. rewrite undef_regs_other_2. + rewrite ! Pregmap.gso by congruence. rewrite <- H1. simpl. econstructor; eauto. eapply code_tail_next_int; eauto. rewrite preg_notin_charact. intros. auto with asmgen. auto with asmgen. apply agree_nextinstr. eapply agree_set_res; auto. - eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto. apply Pregmap.gso; auto with asmgen. + eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto. + rewrite ! Pregmap.gso; auto with asmgen. congruence. - (* Mgoto *) @@ -948,10 +950,10 @@ Local Transparent destroyed_by_op. rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. rewrite F. reflexivity. reflexivity. eexact U. } - exploit exec_straight_steps_2; eauto using functions_transl. omega. constructor. + exploit exec_straight_steps_2; eauto using functions_transl. lia. constructor. intros (ofs' & X & Y). left; exists (State rs3 m3'); split. - eapply exec_straight_steps_1; eauto. omega. constructor. + eapply exec_straight_steps_1; eauto. lia. constructor. econstructor; eauto. rewrite X; econstructor; eauto. apply agree_exten with rs2; eauto with asmgen. @@ -980,7 +982,7 @@ Local Transparent destroyed_at_function_entry. - (* return *) inv STACKS. simpl in *. - right. split. omega. split. auto. + right. split. lia. split. auto. rewrite <- ATPC in H5. econstructor; eauto. congruence. Qed. diff --git a/riscV/Asmgenproof1.v b/riscV/Asmgenproof1.v index c20c4e49..af53754e 100644 --- a/riscV/Asmgenproof1.v +++ b/riscV/Asmgenproof1.v @@ -35,7 +35,7 @@ Proof. - set (m := Int.sub n lo). assert (A: eqmod (two_p 12) (Int.unsigned lo) (Int.unsigned n)) by (apply Int.eqmod_sign_ext'; compute; auto). assert (B: eqmod (two_p 12) (Int.unsigned n - Int.unsigned lo) 0). - { replace 0 with (Int.unsigned n - Int.unsigned n) by omega. + { replace 0 with (Int.unsigned n - Int.unsigned n) by lia. auto using eqmod_sub, eqmod_refl. } assert (C: eqmod (two_p 12) (Int.unsigned m) 0). { apply eqmod_trans with (Int.unsigned n - Int.unsigned lo); auto. @@ -45,7 +45,7 @@ Proof. { apply eqmod_mod_eq in C. unfold Int.modu. change (Int.unsigned (Int.repr 4096)) with (two_p 12). rewrite C. reflexivity. - apply two_p_gt_ZERO; omega. } + apply two_p_gt_ZERO; lia. } rewrite <- (Int.divu_pow2 m (Int.repr 4096) (Int.repr 12)) by auto. rewrite Int.shl_mul_two_p. change (two_p (Int.unsigned (Int.repr 12))) with 4096. @@ -88,7 +88,7 @@ Proof. intros. apply ireg_of_not_X31 in H. congruence. Qed. -Hint Resolve ireg_of_not_X31 ireg_of_not_X31': asmgen. +Global Hint Resolve ireg_of_not_X31 ireg_of_not_X31': asmgen. (** Useful simplification tactic *) @@ -684,18 +684,18 @@ Proof. unfold Val.cmp; destruct (rs#r1); simpl; auto. rewrite B1. unfold Int.lt. rewrite zlt_false. auto. change (Int.signed (Int.repr Int.max_signed)) with Int.max_signed. - generalize (Int.signed_range i); omega. + generalize (Int.signed_range i); lia. * exploit (opimm32_correct Psltw Psltiw (Val.cmp Clt)); eauto. intros (rs1 & A1 & B1 & C1). exists rs1; split. eexact A1. split; auto. rewrite B1. unfold Val.cmp; simpl; destruct (rs#r1); simpl; auto. unfold Int.lt. replace (Int.signed (Int.add n Int.one)) with (Int.signed n + 1). destruct (zlt (Int.signed n) (Int.signed i)). - rewrite zlt_false by omega. auto. - rewrite zlt_true by omega. auto. + rewrite zlt_false by lia. auto. + rewrite zlt_true by lia. auto. rewrite Int.add_signed. symmetry; apply Int.signed_repr. assert (Int.signed n <> Int.max_signed). { red; intros E. elim H1. rewrite <- (Int.repr_signed n). rewrite E. auto. } - generalize (Int.signed_range n); omega. + generalize (Int.signed_range n); lia. + apply DFL. + apply DFL. Qed. @@ -782,18 +782,18 @@ Proof. unfold Val.cmpl; destruct (rs#r1); simpl; auto. rewrite B1. unfold Int64.lt. rewrite zlt_false. auto. change (Int64.signed (Int64.repr Int64.max_signed)) with Int64.max_signed. - generalize (Int64.signed_range i); omega. + generalize (Int64.signed_range i); lia. * exploit (opimm64_correct Psltl Psltil (fun v1 v2 => Val.maketotal (Val.cmpl Clt v1 v2))); eauto. intros (rs1 & A1 & B1 & C1). exists rs1; split. eexact A1. split; auto. rewrite B1. unfold Val.cmpl; simpl; destruct (rs#r1); simpl; auto. unfold Int64.lt. replace (Int64.signed (Int64.add n Int64.one)) with (Int64.signed n + 1). destruct (zlt (Int64.signed n) (Int64.signed i)). - rewrite zlt_false by omega. auto. - rewrite zlt_true by omega. auto. + rewrite zlt_false by lia. auto. + rewrite zlt_true by lia. auto. rewrite Int64.add_signed. symmetry; apply Int64.signed_repr. assert (Int64.signed n <> Int64.max_signed). { red; intros E. elim H1. rewrite <- (Int64.repr_signed n). rewrite E. auto. } - generalize (Int64.signed_range n); omega. + generalize (Int64.signed_range n); lia. + apply DFL. + apply DFL. Qed. @@ -1010,14 +1010,14 @@ Opaque Int.eq. split; intros; Simpl. assert (A: Int.ltu (Int.repr 24) Int.iwordsize = true) by auto. destruct (rs x0); auto; simpl. rewrite A; simpl. rewrite A. - apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. + apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. compute; intuition congruence. - (* cast16signed *) econstructor; split. eapply exec_straight_two. simpl;eauto. simpl;eauto. auto. auto. split; intros; Simpl. assert (A: Int.ltu (Int.repr 16) Int.iwordsize = true) by auto. destruct (rs x0); auto; simpl. rewrite A; simpl. rewrite A. - apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. + apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. compute; intuition congruence. - (* addimm *) exploit (opimm32_correct Paddw Paddiw Val.add); auto. instantiate (1 := x0); eauto with asmgen. intros (rs' & A & B & C). diff --git a/riscV/Builtins1.v b/riscV/Builtins1.v index 53c83d7e..cd6f8cc4 100644 --- a/riscV/Builtins1.v +++ b/riscV/Builtins1.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/riscV/CBuiltins.ml b/riscV/CBuiltins.ml index a2087cb7..9ff4e029 100644 --- a/riscV/CBuiltins.ml +++ b/riscV/CBuiltins.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/riscV/ConstpropOpproof.v b/riscV/ConstpropOpproof.v index 765aa035..8445e55f 100644 --- a/riscV/ConstpropOpproof.v +++ b/riscV/ConstpropOpproof.v @@ -333,7 +333,7 @@ Proof. Int.bit_solve. destruct (zlt i0 n0). replace (Int.testbit n i0) with (negb (Int.testbit Int.zero i0)). rewrite Int.bits_zero. simpl. rewrite andb_true_r. auto. - rewrite <- EQ. rewrite Int.bits_zero_ext by omega. rewrite zlt_true by auto. + rewrite <- EQ. rewrite Int.bits_zero_ext by lia. rewrite zlt_true by auto. rewrite Int.bits_not by auto. apply negb_involutive. rewrite H6 by auto. auto. econstructor; split; eauto. auto. diff --git a/riscV/Conventions1.v b/riscV/Conventions1.v index 17326139..eeaae3c4 100644 --- a/riscV/Conventions1.v +++ b/riscV/Conventions1.v @@ -172,25 +172,29 @@ Qed. (** ** Location of function arguments *) (** The RISC-V ABI states the following conventions for passing arguments - to a function: + to a function. First for non-variadic functions: -- RV64, not variadic: pass the first 8 integer arguments in - integer registers (a1...a8: int_param_regs), the first 8 FP arguments - in FP registers (fa1...fa8: float_param_regs), and the remaining - arguments on the stack, in 8-byte slots. +- RV64: pass the first 8 integer arguments in integer registers + (a1...a8: int_param_regs), the first 8 FP arguments in FP registers + (fa1...fa8: float_param_regs) then in integer registers (a1...a8), + and the remaining arguments on the stack, in 8-byte slots. -- RV32, not variadic: same, but arguments of 64-bit integer type - are passed in two consecutive integer registers (a(i), a(i+1)) - or in a(8) and on a 32-bit word on the stack. Stack-allocated - arguments are aligned to their natural alignment. +- RV32: same, but arguments of size 64 bits that must be passed in + integer registers are passed in two consecutive integer registers + (a(i), a(i+1)), or in a(8) and on a 32-bit word on the stack. + Stack-allocated arguments are aligned to their natural alignment. -- RV64, variadic: pass the first 8 arguments in integer registers - (a1...a8), including FP arguments; pass the remaining arguments on - the stack, in 8-byte slots. +For variadic functions, the fixed arguments are passed as described +above, then the variadic arguments receive special treatment: -- RV32, variadic: same, but arguments of 64-bit types (integers as well +- RV64: FP registers are not used for passing variadic arguments. + All variadic arguments, including FP arguments, are passed in the + remaining integer registers (a1...a8), then on the stack, in 8-byte + slots. + +- RV32: likewise, but arguments of 64-bit types (integers as well as floats) are passed in two consecutive aligned integer registers - (a(2i), a(2i+1)). + (a(2i), a(2i+1)), or on the stack, in aligned 8-byte slots. The passing of FP arguments to variadic functions in integer registers doesn't quite fit CompCert's model. We do our best by passing the FP @@ -204,6 +208,15 @@ Definition int_param_regs := Definition float_param_regs := F10 :: F11 :: F12 :: F13 :: F14 :: F15 :: F16 :: F17 :: nil. +(** To evaluate FP arguments that must be passed in integer registers, + we can use any FP caller-save register that is not already used to pass + a fixed FP argument. Since there are 8 integer registers for argument + passing, we need at most 8 extra more FP registers for these FP + arguments. *) + +Definition float_extra_param_regs := + F0 :: F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: nil. + Definition int_arg (ri rf ofs: Z) (ty: typ) (rec: Z -> Z -> Z -> list (rpair loc)) := match list_nth_z int_param_regs ri with @@ -217,26 +230,27 @@ Definition int_arg (ri rf ofs: Z) (ty: typ) Definition float_arg (va: bool) (ri rf ofs: Z) (ty: typ) (rec: Z -> Z -> Z -> list (rpair loc)) := - match list_nth_z float_param_regs rf with + match list_nth_z (if va then nil else float_param_regs) rf with | Some r => - if va then - (let ri' := (* reserve 1 or 2 aligned integer registers *) - if Archi.ptr64 || zeq (typesize ty) 1 then ri + 1 else align ri 2 + 2 in - if zle ri' 8 then - (* we have enough integer registers, put argument in FP reg - and fixup code will put it in one or two integer regs *) - One (R r) :: rec ri' (rf + 1) ofs - else - (* we are out of integer registers, pass argument on stack *) + One (R r) :: rec ri (rf + 1) ofs + | None => + (* We are out of FP registers, or cannot use them because vararg, + so try to put the argument in an extra FP register while + reserving an integer register or register pair into which + fixup code will move the extra FP register. *) + let regpair := negb Archi.ptr64 && zeq (typesize ty) 2 in + let ri' := if va && regpair then align ri 2 else ri in + match list_nth_z float_extra_param_regs ri' with + | Some r => + let ri'' := ri' + (if Archi.ptr64 then 1 else typesize ty) in + let ofs'' := if regpair && zeq ri' 7 then ofs + 1 else ofs in + One (R r) :: rec ri'' rf ofs'' + | None => + (* We are out of integer registers, pass argument on stack *) let ofs := align ofs (typesize ty) in One(S Outgoing ofs ty) - :: rec ri' rf (ofs + (if Archi.ptr64 then 2 else typesize ty))) - else - One (R r) :: rec ri (rf + 1) ofs - | None => - let ofs := align ofs (typesize ty) in - One(S Outgoing ofs ty) - :: rec ri rf (ofs + (if Archi.ptr64 then 2 else typesize ty)) + :: rec ri' rf (ofs + (if Archi.ptr64 then 2 else typesize ty)) + end end. Definition split_long_arg (va: bool) (ri rf ofs: Z) @@ -253,35 +267,43 @@ Definition split_long_arg (va: bool) (ri rf ofs: Z) rec ri rf (ofs + 2) end. -Fixpoint loc_arguments_rec (va: bool) - (tyl: list typ) (ri rf ofs: Z) {struct tyl} : list (rpair loc) := +Fixpoint loc_arguments_rec + (tyl: list typ) (fixed ri rf ofs: Z) {struct tyl} : list (rpair loc) := match tyl with | nil => nil | (Tint | Tany32) as ty :: tys => (* pass in one integer register or on stack *) - int_arg ri rf ofs ty (loc_arguments_rec va tys) + int_arg ri rf ofs ty (loc_arguments_rec tys (fixed - 1)) | Tsingle as ty :: tys => (* pass in one FP register or on stack. If vararg, reserve 1 integer register. *) - float_arg va ri rf ofs ty (loc_arguments_rec va tys) + float_arg (zle fixed 0) ri rf ofs ty (loc_arguments_rec tys (fixed - 1)) | Tlong as ty :: tys => if Archi.ptr64 then (* pass in one integer register or on stack *) - int_arg ri rf ofs ty (loc_arguments_rec va tys) + int_arg ri rf ofs ty (loc_arguments_rec tys (fixed - 1)) else (* pass in register pair or on stack; align register pair if vararg *) - split_long_arg va ri rf ofs(loc_arguments_rec va tys) + split_long_arg (zle fixed 0) ri rf ofs(loc_arguments_rec tys (fixed - 1)) | (Tfloat | Tany64) as ty :: tys => (* pass in one FP register or on stack. If vararg, reserve 1 or 2 integer registers. *) - float_arg va ri rf ofs ty (loc_arguments_rec va tys) + float_arg (zle fixed 0) ri rf ofs ty (loc_arguments_rec tys (fixed - 1)) + end. + +(** Number of fixed arguments for a function with signature [s]. *) + +Definition fixed_arguments (s: signature) : Z := + match s.(sig_cc).(cc_vararg) with + | Some n => n + | None => list_length_z s.(sig_args) end. (** [loc_arguments s] returns the list of locations where to store arguments when calling a function with signature [s]. *) Definition loc_arguments (s: signature) : list (rpair loc) := - loc_arguments_rec s.(sig_cc).(cc_vararg) s.(sig_args) 0 0 0. + loc_arguments_rec s.(sig_args) (fixed_arguments s) 0 0 0. (** Argument locations are either non-temporary registers or [Outgoing] stack slots at nonnegative offsets. *) @@ -306,17 +328,19 @@ Proof. { decide_goal. } assert (CSF: forall r, In r float_param_regs -> is_callee_save r = false). { decide_goal. } + assert (CSFX: forall r, In r float_extra_param_regs -> is_callee_save r = false). + { decide_goal. } assert (AL: forall ofs ty, ofs >= 0 -> align ofs (typesize ty) >= 0). { intros. assert (ofs <= align ofs (typesize ty)) by (apply align_le; apply typesize_pos). - omega. } + lia. } assert (ALD: forall ofs ty, ofs >= 0 -> (typealign ty | align ofs (typesize ty))). { intros. eapply Z.divide_trans. apply typealign_typesize. apply align_divides. apply typesize_pos. } assert (SK: (if Archi.ptr64 then 2 else 1) > 0). - { destruct Archi.ptr64; omega. } + { destruct Archi.ptr64; lia. } assert (SKK: forall ty, (if Archi.ptr64 then 2 else typesize ty) > 0). - { intros. destruct Archi.ptr64. omega. apply typesize_pos. } + { intros. destruct Archi.ptr64. lia. apply typesize_pos. } assert (A: forall ri rf ofs ty f, OKF f -> ofs >= 0 -> OK (int_arg ri rf ofs ty f)). { intros until f; intros OF OO; red; unfold int_arg; intros. @@ -325,23 +349,22 @@ Proof. - eapply OF; eauto. - subst p; simpl. auto using align_divides, typealign_pos. - eapply OF; [idtac|eauto]. - generalize (AL ofs ty OO) (SKK ty); omega. + generalize (AL ofs ty OO) (SKK ty); lia. } assert (B: forall va ri rf ofs ty f, OKF f -> ofs >= 0 -> OK (float_arg va ri rf ofs ty f)). { intros until f; intros OF OO; red; unfold float_arg; intros. - destruct (list_nth_z float_param_regs rf) as [r|] eqn:NTH. - - set (ri' := if Archi.ptr64 || zeq (typesize ty) 1 then ri + 1 else align ri 2 + 2) in *. - destruct va; [destruct (zle ri' 8)|idtac]; destruct H. - + subst p; simpl. apply CSF. eapply list_nth_z_in; eauto. - + eapply OF; eauto. - + subst p; repeat split; auto. - + eapply OF; [idtac|eauto]. generalize (AL ofs ty OO) (SKK ty); omega. - + subst p; simpl. apply CSF. eapply list_nth_z_in; eauto. - + eapply OF; eauto. + destruct (list_nth_z (if va then nil else float_param_regs) rf) as [r|] eqn:NTH. - destruct H. - + subst p; repeat split; auto. - + eapply OF; [idtac|eauto]. generalize (AL ofs ty OO) (SKK ty); omega. + + subst p; simpl. apply CSF. destruct va. simpl in NTH; discriminate. eapply list_nth_z_in; eauto. + + eapply OF; eauto. + - set (regpair := negb Archi.ptr64 && zeq (typesize ty) 2) in *. + set (ri' := if va && regpair then align ri 2 else ri) in *. + destruct (list_nth_z float_extra_param_regs ri') as [r|] eqn:NTH'; destruct H. + + subst p; simpl. apply CSFX. eapply list_nth_z_in; eauto. + + eapply OF; [|eauto]. destruct (regpair && zeq ri' 7); lia. + + subst p; simpl. auto. + + eapply OF; [|eauto]. generalize (AL ofs ty OO) (SKK ty); lia. } assert (C: forall va ri rf ofs f, OKF f -> ofs >= 0 -> OK (split_long_arg va ri rf ofs f)). @@ -353,35 +376,35 @@ Proof. [destruct (list_nth_z int_param_regs (ri'+1)) as [r2|] eqn:NTH2 | idtac]. - red; simpl; intros; destruct H. + subst p; split; apply CSI; eauto using list_nth_z_in. - + eapply OF; [idtac|eauto]. omega. + + eapply OF; [idtac|eauto]. lia. - red; simpl; intros; destruct H. + subst p; split. split; auto using Z.divide_1_l. apply CSI; eauto using list_nth_z_in. - + eapply OF; [idtac|eauto]. omega. + + eapply OF; [idtac|eauto]. lia. - red; simpl; intros; destruct H. - + subst p; repeat split; auto using Z.divide_1_l. omega. - + eapply OF; [idtac|eauto]. omega. + + subst p; repeat split; auto using Z.divide_1_l. lia. + + eapply OF; [idtac|eauto]. lia. } - cut (forall va tyl ri rf ofs, ofs >= 0 -> OK (loc_arguments_rec va tyl ri rf ofs)). + cut (forall tyl fixed ri rf ofs, ofs >= 0 -> OK (loc_arguments_rec tyl fixed ri rf ofs)). unfold OK. eauto. induction tyl as [ | ty1 tyl]; intros until ofs; intros OO; simpl. - red; simpl; tauto. - destruct ty1. -+ (* int *) apply A; auto. -+ (* float *) apply B; auto. ++ (* int *) apply A; unfold OKF; auto. ++ (* float *) apply B; unfold OKF; auto. + (* long *) destruct Archi.ptr64. - apply A; auto. - apply C; auto. -+ (* single *) apply B; auto. -+ (* any32 *) apply A; auto. -+ (* any64 *) apply B; auto. + apply A; unfold OKF; auto. + apply C; unfold OKF; auto. ++ (* single *) apply B; unfold OKF; auto. ++ (* any32 *) apply A; unfold OKF; auto. ++ (* any64 *) apply B; unfold OKF; auto. Qed. Lemma loc_arguments_acceptable: forall (s: signature) (p: rpair loc), In p (loc_arguments s) -> forall_rpair loc_argument_acceptable p. Proof. - unfold loc_arguments; intros. eapply loc_arguments_rec_charact; eauto. omega. + unfold loc_arguments; intros. eapply loc_arguments_rec_charact; eauto. lia. Qed. Lemma loc_arguments_main: @@ -390,8 +413,9 @@ Proof. reflexivity. Qed. -(** ** Normalization of function results *) +(** ** Normalization of function results and parameters *) (** No normalization needed. *) Definition return_value_needs_normalization (t: rettype) := false. +Definition parameter_needs_normalization (t: rettype) := false. diff --git a/riscV/NeedOp.v b/riscV/NeedOp.v index 117bbcb4..4070431a 100644 --- a/riscV/NeedOp.v +++ b/riscV/NeedOp.v @@ -164,8 +164,8 @@ Lemma operation_is_redundant_sound: vagree v arg1' nv. Proof. intros. destruct op; simpl in *; try discriminate; inv H1; FuncInv; subst. -- apply sign_ext_redundant_sound; auto. omega. -- apply sign_ext_redundant_sound; auto. omega. +- apply sign_ext_redundant_sound; auto. lia. +- apply sign_ext_redundant_sound; auto. lia. - apply andimm_redundant_sound; auto. - apply orimm_redundant_sound; auto. Qed. diff --git a/riscV/SelectLongproof.v b/riscV/SelectLongproof.v index 78a1935d..3794e050 100644 --- a/riscV/SelectLongproof.v +++ b/riscV/SelectLongproof.v @@ -502,8 +502,8 @@ Proof. assert (LTU2: Int.ltu (Int.sub Int64.iwordsize' n) Int64.iwordsize' = true). { unfold Int.ltu; apply zlt_true. unfold Int.sub. change (Int.unsigned Int64.iwordsize') with 64. - rewrite Int.unsigned_repr. omega. - assert (64 < Int.max_unsigned) by reflexivity. omega. } + rewrite Int.unsigned_repr. lia. + assert (64 < Int.max_unsigned) by reflexivity. lia. } assert (X: eval_expr ge sp e m le (Eop (Oshrlimm (Int.repr (Int64.zwordsize - 1))) (a ::: Enil)) (Vlong (Int64.shr' i (Int.repr (Int64.zwordsize - 1))))). @@ -514,7 +514,7 @@ Proof. TrivialExists. constructor. EvalOp. simpl; eauto. constructor. simpl. unfold Int.ltu; rewrite zlt_true. rewrite Int64.shrx'_shr_2 by auto. reflexivity. - change (Int.unsigned Int64.iwordsize') with 64; omega. + change (Int.unsigned Int64.iwordsize') with 64; lia. *) Qed. diff --git a/riscV/SelectOpproof.v b/riscV/SelectOpproof.v index 593be1ed..b0b4b794 100644 --- a/riscV/SelectOpproof.v +++ b/riscV/SelectOpproof.v @@ -365,20 +365,20 @@ Proof. change (Int.ltu (Int.repr 32) Int64.iwordsize') with true; simpl. apply Val.lessdef_same. f_equal. transitivity (Int.repr (Z.shiftr (Int.signed i * Int.signed i0) 32)). - unfold Int.mulhs; f_equal. rewrite Zshiftr_div_two_p by omega. reflexivity. + unfold Int.mulhs; f_equal. rewrite Zshiftr_div_two_p by lia. reflexivity. apply Int.same_bits_eq; intros n N. change Int.zwordsize with 32 in *. - assert (N1: 0 <= n < 64) by omega. + assert (N1: 0 <= n < 64) by lia. rewrite Int64.bits_loword by auto. rewrite Int64.bits_shr' by auto. change (Int.unsigned (Int.repr 32)) with 32. change Int64.zwordsize with 64. - rewrite zlt_true by omega. + rewrite zlt_true by lia. rewrite Int.testbit_repr by auto. - unfold Int64.mul. rewrite Int64.testbit_repr by (change Int64.zwordsize with 64; omega). + unfold Int64.mul. rewrite Int64.testbit_repr by (change Int64.zwordsize with 64; lia). transitivity (Z.testbit (Int.signed i * Int.signed i0) (n + 32)). - rewrite Z.shiftr_spec by omega. auto. + rewrite Z.shiftr_spec by lia. auto. apply Int64.same_bits_eqm. apply Int64.eqm_mult; apply Int64.eqm_unsigned_repr. - change Int64.zwordsize with 64; omega. + change Int64.zwordsize with 64; lia. - TrivialExists. Qed. @@ -393,20 +393,20 @@ Proof. change (Int.ltu (Int.repr 32) Int64.iwordsize') with true; simpl. apply Val.lessdef_same. f_equal. transitivity (Int.repr (Z.shiftr (Int.unsigned i * Int.unsigned i0) 32)). - unfold Int.mulhu; f_equal. rewrite Zshiftr_div_two_p by omega. reflexivity. + unfold Int.mulhu; f_equal. rewrite Zshiftr_div_two_p by lia. reflexivity. apply Int.same_bits_eq; intros n N. change Int.zwordsize with 32 in *. - assert (N1: 0 <= n < 64) by omega. + assert (N1: 0 <= n < 64) by lia. rewrite Int64.bits_loword by auto. rewrite Int64.bits_shru' by auto. change (Int.unsigned (Int.repr 32)) with 32. change Int64.zwordsize with 64. - rewrite zlt_true by omega. + rewrite zlt_true by lia. rewrite Int.testbit_repr by auto. - unfold Int64.mul. rewrite Int64.testbit_repr by (change Int64.zwordsize with 64; omega). + unfold Int64.mul. rewrite Int64.testbit_repr by (change Int64.zwordsize with 64; lia). transitivity (Z.testbit (Int.unsigned i * Int.unsigned i0) (n + 32)). - rewrite Z.shiftr_spec by omega. auto. + rewrite Z.shiftr_spec by lia. auto. apply Int64.same_bits_eqm. apply Int64.eqm_mult; apply Int64.eqm_unsigned_repr. - change Int64.zwordsize with 64; omega. + change Int64.zwordsize with 64; lia. - TrivialExists. Qed. @@ -563,8 +563,8 @@ Proof. assert (LTU2: Int.ltu (Int.sub Int.iwordsize n) Int.iwordsize = true). { unfold Int.ltu; apply zlt_true. unfold Int.sub. change (Int.unsigned Int.iwordsize) with 32. - rewrite Int.unsigned_repr. omega. - assert (32 < Int.max_unsigned) by reflexivity. omega. } + rewrite Int.unsigned_repr. lia. + assert (32 < Int.max_unsigned) by reflexivity. lia. } assert (X: eval_expr ge sp e m le (Eop (Oshrimm (Int.repr (Int.zwordsize - 1))) (a ::: Enil)) (Vint (Int.shr i (Int.repr (Int.zwordsize - 1))))). @@ -575,7 +575,7 @@ Proof. TrivialExists. constructor. EvalOp. simpl; eauto. constructor. simpl. unfold Int.ltu; rewrite zlt_true. rewrite Int.shrx_shr_2 by auto. reflexivity. - change (Int.unsigned Int.iwordsize) with 32; omega. + change (Int.unsigned Int.iwordsize) with 32; lia. *) Qed. @@ -763,7 +763,7 @@ Qed. Theorem eval_cast8unsigned: unary_constructor_sound cast8unsigned (Val.zero_ext 8). Proof. red; intros until x. unfold cast8unsigned. - rewrite Val.zero_ext_and. apply eval_andimm. omega. + rewrite Val.zero_ext_and. apply eval_andimm. lia. Qed. Theorem eval_cast16signed: unary_constructor_sound cast16signed (Val.sign_ext 16). @@ -776,7 +776,7 @@ Qed. Theorem eval_cast16unsigned: unary_constructor_sound cast16unsigned (Val.zero_ext 16). Proof. red; intros until x. unfold cast8unsigned. - rewrite Val.zero_ext_and. apply eval_andimm. omega. + rewrite Val.zero_ext_and. apply eval_andimm. lia. Qed. Theorem eval_intoffloat: diff --git a/riscV/Stacklayout.v b/riscV/Stacklayout.v index d0c6a526..25f02aab 100644 --- a/riscV/Stacklayout.v +++ b/riscV/Stacklayout.v @@ -68,15 +68,15 @@ Local Opaque Z.add Z.mul sepconj range. set (ol := align (size_callee_save_area b ocs) 8). set (ostkdata := align (ol + 4 * b.(bound_local)) 8). replace (size_chunk Mptr) with w by (rewrite size_chunk_Mptr; auto). - assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). + assert (0 < w) by (unfold w; destruct Archi.ptr64; lia). generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros. - assert (0 <= 4 * b.(bound_outgoing)) by omega. - assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; omega). - assert (olink + w <= oretaddr) by (unfold oretaddr; omega). - assert (oretaddr + w <= ocs) by (unfold ocs; omega). + assert (0 <= 4 * b.(bound_outgoing)) by lia. + assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; lia). + assert (olink + w <= oretaddr) by (unfold oretaddr; lia). + assert (oretaddr + w <= ocs) by (unfold ocs; lia). assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr). - assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega). - assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega). + assert (size_callee_save_area b ocs <= ol) by (apply align_le; lia). + assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; lia). (* Reorder as: outgoing back link @@ -89,11 +89,11 @@ Local Opaque Z.add Z.mul sepconj range. rewrite sep_swap45. (* Apply range_split and range_split2 repeatedly *) unfold fe_ofs_arg. - apply range_split_2. fold olink; omega. omega. - apply range_split. omega. - apply range_split. omega. - apply range_split_2. fold ol. omega. omega. - apply range_drop_right with ostkdata. omega. + apply range_split_2. fold olink; lia. lia. + apply range_split. lia. + apply range_split. lia. + apply range_split_2. fold ol. lia. lia. + apply range_drop_right with ostkdata. lia. eapply sep_drop2. eexact H. Qed. @@ -109,16 +109,16 @@ Proof. set (ocs := oretaddr + w). set (ol := align (size_callee_save_area b ocs) 8). set (ostkdata := align (ol + 4 * b.(bound_local)) 8). - assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). + assert (0 < w) by (unfold w; destruct Archi.ptr64; lia). generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros. - assert (0 <= 4 * b.(bound_outgoing)) by omega. - assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; omega). - assert (olink + w <= oretaddr) by (unfold oretaddr; omega). - assert (oretaddr + w <= ocs) by (unfold ocs; omega). + assert (0 <= 4 * b.(bound_outgoing)) by lia. + assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; lia). + assert (olink + w <= oretaddr) by (unfold oretaddr; lia). + assert (oretaddr + w <= ocs) by (unfold ocs; lia). assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr). - assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega). - assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega). - split. omega. apply align_le. omega. + assert (size_callee_save_area b ocs <= ol) by (apply align_le; lia). + assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; lia). + split. lia. apply align_le. lia. Qed. Lemma frame_env_aligned: @@ -137,11 +137,11 @@ Proof. set (ocs := oretaddr + w). set (ol := align (size_callee_save_area b ocs) 8). set (ostkdata := align (ol + 4 * b.(bound_local)) 8). - assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). + assert (0 < w) by (unfold w; destruct Archi.ptr64; lia). replace (align_chunk Mptr) with w by (rewrite align_chunk_Mptr; auto). split. apply Z.divide_0_r. - split. apply align_divides; omega. - split. apply align_divides; omega. - split. apply align_divides; omega. - apply Z.divide_add_r. apply align_divides; omega. apply Z.divide_refl. + split. apply align_divides; lia. + split. apply align_divides; lia. + split. apply align_divides; lia. + apply Z.divide_add_r. apply align_divides; lia. apply Z.divide_refl. Qed. diff --git a/riscV/TargetPrinter.ml b/riscV/TargetPrinter.ml index 64bcea4c..d8137f84 100644 --- a/riscV/TargetPrinter.ml +++ b/riscV/TargetPrinter.ml @@ -108,9 +108,9 @@ module Target : TARGET = let name_of_section = function | Section_text -> ".text" | Section_data i | Section_small_data i -> - if i then ".data" else common_section () + variable_section ~sec:".data" ~bss:".bss" i | Section_const i | Section_small_const i -> - if i || (not !Clflags.option_fcommon) then ".section .rodata" else "COMM" + variable_section ~sec:".section .rodata" i | Section_string -> ".section .rodata" | Section_literal -> ".section .rodata" | Section_jumptable -> ".section .rodata" @@ -392,8 +392,12 @@ module Target : TARGET = fprintf oc " fmv.d %a, %a\n" freg fd freg fs | Pfmvxs (rd,fs) -> fprintf oc " fmv.x.s %a, %a\n" ireg rd freg fs + | Pfmvsx (fd,rs) -> + fprintf oc " fmv.s.x %a, %a\n" freg fd ireg rs | Pfmvxd (rd,fs) -> fprintf oc " fmv.x.d %a, %a\n" ireg rd freg fs + | Pfmvdx (fd,rs) -> + fprintf oc " fmv.d.x %a, %a\n" freg fd ireg rs (* 32-bit (single-precision) floating point *) | Pfls (fd, ra, ofs) -> diff --git a/riscV/extractionMachdep.v b/riscV/extractionMachdep.v index c9a1040a..890735ba 100644 --- a/riscV/extractionMachdep.v +++ b/riscV/extractionMachdep.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/runtime/Makefile b/runtime/Makefile index 6777995d..beb105a6 100644 --- a/runtime/Makefile +++ b/runtime/Makefile @@ -48,7 +48,7 @@ endif $(LIB): $(OBJS) rm -f $(LIB) - ar rcs $(LIB) $(OBJS) + $(ARCHIVER) $(LIB) $(OBJS) %.o: %.s $(CASMRUNTIME) -o $@ $^ diff --git a/runtime/aarch64/sysdeps.h b/runtime/aarch64/sysdeps.h index 0cee9ae3..b098cf1c 100644 --- a/runtime/aarch64/sysdeps.h +++ b/runtime/aarch64/sysdeps.h @@ -34,6 +34,25 @@ // System dependencies +#if defined(SYS_macos) + +#define GLOB(x) _##x + +#define FUNCTION(f) FUNCTION f + +.macro FUNCTION name + .text + .globl _\name + .align 4 +_\name: +.endm + +#define ENDFUNCTION(f) + +#else + +#define GLOB(x) x + #define FUNCTION(f) \ .text; \ .balign 16; \ @@ -43,3 +62,4 @@ f: #define ENDFUNCTION(f) \ .type f, @function; .size f, . - f +#endif diff --git a/runtime/aarch64/vararg.S b/runtime/aarch64/vararg.S index b7347d65..488d3459 100644 --- a/runtime/aarch64/vararg.S +++ b/runtime/aarch64/vararg.S @@ -36,7 +36,8 @@ #include "sysdeps.h" -// typedef struct __va_list { +// For the standard ABI: +// struct __va_list { // void *__stack; // next stack parameter // void *__gr_top; // top of the save area for int regs // void *__vr_top; // top of the save area for float regs @@ -44,10 +45,18 @@ // int__vr_offs; // offset from gr_top to next FP reg // } // typedef struct __va_list va_list; // struct passed by reference + +// For the Apple ABI: +// typedef char * va_list; // a single pointer passed by reference +// // points to the next parameter, always on stack + +// In both cases: // unsigned int __compcert_va_int32(va_list * ap); // unsigned long long __compcert_va_int64(va_list * ap); // double __compcert_va_float64(va_list * ap); +#ifdef ABI_standard + FUNCTION(__compcert_va_int32) ldr w1, [x0, #24] // w1 = gr_offs cbz w1, 1f @@ -72,14 +81,14 @@ FUNCTION(__compcert_va_int64) cbz w1, 1f // gr_offs is not zero: load from int save area and update gr_offs ldr x2, [x0, #8] // x2 = gr_top - ldr x2, [x2, w1, sxtw] // w2 = the next long integer + ldr x2, [x2, w1, sxtw] // x2 = the next long integer add w1, w1, #8 str w1, [x0, #24] // update gr_offs mov x0, x2 ret // gr_offs is zero: load from stack save area and update stack pointer 1: ldr x1, [x0, #0] // x1 = stack - ldr x2, [x1, #0] // w2 = the next long integer + ldr x2, [x1, #0] // x2 = the next long integer add x1, x1, #8 str x1, [x0, #0] // update stack mov x0, x2 @@ -103,7 +112,40 @@ FUNCTION(__compcert_va_float64) ret ENDFUNCTION(__compcert_va_float64) +#endif + +#ifdef ABI_apple + +FUNCTION(__compcert_va_int32) + ldr x1, [x0, #0] // x1 = stack pointer + ldr w2, [x1, #0] // w2 = the next integer + add x1, x1, #8 + str x1, [x0, #0] // update stack + mov w0, w2 + ret +ENDFUNCTION(__compcert_va_int32) + +FUNCTION(__compcert_va_int64) + ldr x1, [x0, #0] // x1 = stack pointer + ldr x2, [x1, #0] // x2 = the next long integer + add x1, x1, #8 + str x1, [x0, #0] // update stack + mov x0, x2 + ret +ENDFUNCTION(__compcert_va_int64) + +FUNCTION(__compcert_va_float64) + ldr x1, [x0, #0] // x1 = stack pointer + ldr d0, [x1, #0] // d0 = the next float + add x1, x1, #8 + str x1, [x0, #0] // update stack + ret +ENDFUNCTION(__compcert_va_float64) + +#endif + // Right now we pass structs by reference. This is not ABI conformant. FUNCTION(__compcert_va_composite) - b __compcert_va_int64 + b GLOB(__compcert_va_int64) ENDFUNCTION(__compcert_va_composite) + diff --git a/runtime/x86_32/sysdeps.h b/runtime/x86_32/sysdeps.h index 9d957a88..973bbe2f 100644 --- a/runtime/x86_32/sysdeps.h +++ b/runtime/x86_32/sysdeps.h @@ -48,7 +48,7 @@ f: #endif -#if defined(SYS_macosx) +#if defined(SYS_macos) #define GLOB(x) _##x #define FUNCTION(f) \ diff --git a/runtime/x86_64/sysdeps.h b/runtime/x86_64/sysdeps.h index aacef8f0..9031d5d0 100644 --- a/runtime/x86_64/sysdeps.h +++ b/runtime/x86_64/sysdeps.h @@ -48,7 +48,7 @@ f: #endif -#if defined(SYS_macosx) +#if defined(SYS_macos) #define GLOB(x) _##x #define FUNCTION(f) \ diff --git a/runtime/x86_64/vararg.S b/runtime/x86_64/vararg.S index c5225b34..d3634e4d 100644 --- a/runtime/x86_64/vararg.S +++ b/runtime/x86_64/vararg.S @@ -38,7 +38,7 @@ // ELF ABI -#if defined(SYS_linux) || defined(SYS_bsd) || defined(SYS_macosx) +#if defined(SYS_linux) || defined(SYS_bsd) || defined(SYS_macos) // typedef struct { // unsigned int gp_offset; diff --git a/test/Makefile b/test/Makefile index 504e4c53..fa1fef30 100644 --- a/test/Makefile +++ b/test/Makefile @@ -1,6 +1,6 @@ include ../Makefile.config -DIRS=c compression raytracer spass regression +DIRS=c compression raytracer spass regression abi ifeq ($(CLIGHTGEN),true) DIRS+=clightgen endif diff --git a/test/abi/.gitignore b/test/abi/.gitignore new file mode 100644 index 00000000..5aa03c7c --- /dev/null +++ b/test/abi/.gitignore @@ -0,0 +1,11 @@ +*.exe +*.c +*.h +*.compcert +*.cc +*.cc2compcert +*.compcert2cc +*.light.c +*.s +!layout.c +!staticlayout.c diff --git a/test/abi/Makefile b/test/abi/Makefile new file mode 100644 index 00000000..ef354e06 --- /dev/null +++ b/test/abi/Makefile @@ -0,0 +1,111 @@ +include ../../Makefile.config + +CCOMP=../../ccomp -stdlib ../../runtime +CCOMPFLAGS= +CFLAGS=-O -Wno-overflow -Wno-constant-conversion + +TESTS=fixed.compcert fixed.cc2compcert fixed.compcert2cc \ + vararg.compcert vararg.cc2compcert vararg.compcert2cc \ + struct.compcert struct.cc2compcert struct.compcert2cc + +DIFFTESTS=layout.compcert layout.cc \ + staticlayout.compcert staticlayout.cc + +all: $(TESTS) $(DIFFTESTS) + +all_s: fixed_def_compcert.s fixed_use_compcert.s \ + vararg_def_compcert.s vararg_use_compcert.s \ + struct_def_compcert.s struct_use_compcert.s + +test: + @set -e; for t in $(TESTS); do \ + SIMU='$(SIMU)' ARCH=$(ARCH) MODEL=$(MODEL) ABI=$(ABI) SYSTEM=$(SYSTEM) ./Runtest $$t; \ + done + @set -e; for t in layout staticlayout; do \ + $(SIMU) ./$$t.compcert > _compcert.log; \ + $(SIMU) ./$$t.cc > _cc.log; \ + if diff -a -u _cc.log _compcert.log; \ + then echo "$$t: CompCert and $CC agree"; rm _*.log; \ + else echo "$$t: CompCert and $CC DISAGREE"; exit 2; fi; \ + done + +generator.exe: generator.ml + ocamlopt -g -o $@ generator.ml + +genlayout.exe: genlayout.ml + ocamlopt -g -o $@ genlayout.ml + +clean:: + rm -f generator.exe genlayout.exe *.cm[iox] + +fixed_decl.h: generator.exe + ./generator.exe -rnd 500 -o fixed + +fixed_def.c fixed_use.c: fixed_decl.h + +clean:: + rm -f fixed_decl.h fixed_def.c fixed_use.c + +vararg_decl.h: generator.exe + ./generator.exe -vararg -rnd 500 -o vararg + +vararg_def.c vararg_use.c: vararg_decl.h + +clean:: + rm -f vararg_decl.h vararg_def.c vararg_use.c + +struct_decl.h: generator.exe + ./generator.exe -structs -o struct + +struct_def.c struct_use.c: struct_decl.h + +clean:: + rm -f struct_decl.h struct_def.c struct_use.c + +ifeq ($(ARCH),arm) +GENLAYOUT_OPTIONS += -stable +endif +ifeq ($(ARCH),aarch64) +GENLAYOUT_OPTIONS += -stable +endif + +layout.h: genlayout.exe + ./genlayout.exe $(GENLAYOUT_OPTIONS) > layout.h + +struct%.o: CCOMPFLAGS += -fstruct-passing -dclight + +%_compcert.o: %.c + $(CCOMP) $(CCOMPFLAGS) -c -o $@ $*.c +%_cc.o: %.c + $(CC) $(CFLAGS) -c -o $@ $*.c + +%_compcert.s: %.c + $(CCOMP) -S -o $@ $*.c +%_cc.s: %.c + $(CC) $(CFLAGS) -S -o $@ $*.c + +layout.compcert: layout.c layout.h + $(CCOMP) $(CCOMPFLAGS) -o $@ layout.c +layout.cc: layout.c layout.h + $(CC) $(CFLAGS) -o $@ layout.c + +staticlayout.compcert: staticlayout.c layout.h + $(CCOMP) $(CCOMPFLAGS) -o $@ staticlayout.c +staticlayout.cc: staticlayout.c layout.h + $(CC) $(CFLAGS) -o $@ staticlayout.c + +%.compcert: %_def_compcert.o %_use_compcert.o + $(CCOMP) -o $@ $*_def_compcert.o $*_use_compcert.o + +%.compcert: %_def_compcert.o %_use_compcert.o + $(CCOMP) -o $@ $*_def_compcert.o $*_use_compcert.o + +%.cc2compcert: %_def_compcert.o %_use_cc.o + $(CCOMP) -o $@ $*_def_compcert.o $*_use_cc.o + +%.compcert2cc: %_def_cc.o %_use_compcert.o + $(CCOMP) -o $@ $*_def_cc.o $*_use_compcert.o + +clean:: + rm -f *.[os] *.compcert *.cc2compcert *.compcert2cc *.light.c + diff --git a/test/abi/Runtest b/test/abi/Runtest new file mode 100755 index 00000000..7ec63188 --- /dev/null +++ b/test/abi/Runtest @@ -0,0 +1,41 @@ +#!/bin/sh + +# The name of the test +name="$1" + +# Skip the test if known to fail + +skip () { + echo "$name: skipped" + exit 0 +} + +case "$name" in + fixed.cc2compcert|fixed.compcert2cc) + if [ $ARCH = arm ] && [ $ABI = hardfloat ] ; then skip; fi + ;; + struct.cc2compcert|struct.compcert2cc) + if [ $ARCH = x86 ] && [ $MODEL = 32sse2 ] ; then + # works except on Cygwin + if [ $SYSTEM = cygwin ] ; then skip; fi + elif [ $ARCH = powerpc ] && [ $ABI = linux ] ; then + # works + : + else + skip + fi + ;; +esac + +# Administer the test + +if $SIMU ./$name +then + echo "$name: passed" + exit 0 +else + echo "$name: FAILED" + exit 2 +fi + + diff --git a/test/abi/generator.ml b/test/abi/generator.ml new file mode 100644 index 00000000..529352e0 --- /dev/null +++ b/test/abi/generator.ml @@ -0,0 +1,458 @@ +open Printf + +type ty = + | Int8u | Int8s + | Int16u | Int16s + | Int32 + | Int64 + | Float32 + | Float64 + | String + | Struct of int * (string * ty) list + +type funsig = { + args: ty list; + varargs: ty list; (* empty list if fixed-argument function *) + res: ty option + } + +type value = + | VInt of int + | VInt32 of int32 + | VInt64 of int64 + | VFloat of float + | VString of string + | VStruct of value list + +(* Print a value. If [norm] is true, re-normalize values of + small numerical types. *) + +let zero_ext n k = + n land ((1 lsl k) - 1) + +let sign_ext n k = + (n lsl (Sys.int_size - k)) asr (Sys.int_size - k) + +let normalize_float32 n = + Int32.float_of_bits (Int32.bits_of_float n) + +let rec print_value ~norm oc (ty, v) = + match (ty, v) with + | (Int8u, VInt n) -> + fprintf oc "%d" (if norm then zero_ext n 8 else n) + | (Int8s, VInt n) -> + fprintf oc "%d" (if norm then sign_ext n 8 else n) + | (Int16u, VInt n) -> + fprintf oc "%d" (if norm then zero_ext n 16 else n) + | (Int16s, VInt n) -> + fprintf oc "%d" (if norm then sign_ext n 16 else n) + | (Int32, VInt32 n) -> + fprintf oc "%ld" n + | (Int64, VInt64 n) -> + fprintf oc "%Ld" n + | (Float32, VFloat f) -> + if norm + then fprintf oc "%hF" (normalize_float32 f) + else fprintf oc "%h" f + | (Float64, VFloat f) -> + fprintf oc "%h" f + | (String, VString s) -> + fprintf oc "%S" s + | (Struct(id, (fld1, ty1) :: members), VStruct (v1 :: vl)) -> + fprintf oc "(struct s%d){" id; + print_value ~norm oc (ty1, v1); + List.iter2 + (fun (fld, ty) v -> fprintf oc ", %a" (print_value ~norm) (ty, v)) + members vl; + fprintf oc "}" + | _, _ -> + assert false + +(* Generate random values of the given type *) + +let random_char () = Char.chr (Char.code 'a' + Random.int 26) + +let random_string () = + let len = Random.int 3 in + String.init len (fun _ -> random_char ()) + +let random_int () = + Random.bits() - (1 lsl 29) + +let random_int32 () = + Int32.(logxor (of_int (Random.bits())) + (shift_left (of_int (Random.bits())) 30)) + +let random_int64 () = + Int64.(logxor (of_int (Random.bits())) + (logxor (shift_left (of_int (Random.bits())) 30) + (shift_left (of_int (Random.bits())) 60))) + +let random_float64 () = + Random.float 100.0 -. 50.0 + +(* Returns a random value. Small numerical types are not normalized. *) + +let rec random_value = function + | Int8u | Int8s | Int16u | Int16s -> + VInt (random_int()) + | Int32 -> + VInt32 (random_int32()) + | Int64 -> + VInt64 (random_int64()) + | Float32 | Float64 -> + VFloat (random_float64()) + | String -> + VString (random_string()) + | Struct(id, members) -> + VStruct (List.map (fun (fld, ty) -> random_value ty) members) + +let random_retvalue = function + | None -> VInt 0 (* meaningless *) + | Some ty -> random_value ty + +(* Generate function declaration, definition, and call *) + +let string_of_ty = function + | Int8u -> "unsigned char" + | Int8s -> "signed char" + | Int16u -> "unsigned short" + | Int16s -> "short" + | Int32 -> "int" + | Int64 -> "long long" + | Float32 -> "float" + | Float64 -> "double" + | String -> "char *" + | Struct(id, _) -> sprintf "struct s%d" id + +let string_of_optty = function + | None -> "void" + | Some t -> string_of_ty t + +let declare_struct oc id members = + fprintf oc "struct s%d {\n" id; + List.iter + (fun (fld, ty) -> fprintf oc " %s %s;\n" (string_of_ty ty) fld) + members; + fprintf oc "};\n" + +let declare_function oc name sg = + fprintf oc "%s %s(" (string_of_optty sg.res) name; + begin match sg.args with + | [] -> fprintf oc "void" + | t0 :: tl -> + fprintf oc "%s x0" (string_of_ty t0); + List.iteri (fun n t -> fprintf oc ", %s x%d" (string_of_ty t) (n + 1)) tl; + if sg.varargs <> [] then fprintf oc ", ..." + end; + fprintf oc ")" + +let rec compare_value oc variable value ty = + match ty with + | Struct(id, members) -> + begin match value with + | VStruct vl -> + List.iter2 + (fun (fld, ty) v -> + compare_value oc (sprintf "%s.%s" variable fld) v ty) + members vl + | _ -> + assert false + end + | String -> + fprintf oc " check (strcmp(%s, %a) == 0);\n" + variable (print_value ~norm:true) (ty, value) + | _ -> + fprintf oc " check (%s == %a);\n" + variable (print_value ~norm:true) (ty, value) + +let define_function oc name sg vargs vres = + declare_function oc name sg; + fprintf oc "\n{\n"; + if sg.varargs <> [] then begin + fprintf oc " va_list l;\n"; + fprintf oc " va_start(l, x%d);\n" (List.length sg.args - 1); + List.iteri + (fun n t -> + fprintf oc " %s x%d = va_arg(l, %s);\n" + (string_of_ty t) (n + List.length sg.args) (string_of_ty t)) + sg.varargs; + fprintf oc " va_end(l);\n"; + end; + List.iteri + (fun n (t, v) -> compare_value oc (sprintf "x%d" n) v t) + (List.combine (sg.args @ sg.varargs) vargs); + begin match sg.res with + | None -> () + | Some tres -> + fprintf oc " return %a;\n" (print_value ~norm:false) (tres, vres) + end; + fprintf oc "}\n\n" + +let call_function oc name sg vargs vres = + fprintf oc "void call_%s(void)\n" name; + fprintf oc "{\n"; + begin match sg.res with + | None -> fprintf oc " %s(" name + | Some t -> fprintf oc " %s r = %s(" (string_of_ty t) name + end; + begin match (sg.args @ sg.varargs), vargs with + | [], [] -> () + | ty1 :: tyl, v1 :: vl -> + print_value ~norm:false oc (ty1, v1); + List.iter2 + (fun ty v -> fprintf oc ", %a" (print_value ~norm:false) (ty, v)) + tyl vl + | _, _ -> + assert false + end; + fprintf oc ");\n"; + begin match sg.res with + | None -> () + | Some tyres -> compare_value oc "r" vres tyres + end; + fprintf oc "}\n\n" + +let function_counter = ref 0 + +let generate_one_test oc0 oc1 oc2 sg = + incr function_counter; + let num = !function_counter in + let vargs = List.map random_value (sg.args @ sg.varargs) in + let vres = random_retvalue sg.res in + let name = "f" ^ string_of_int num in + fprintf oc0 "extern "; + declare_function oc0 name sg; + fprintf oc0 ";\n"; + define_function oc1 name sg vargs vres; + call_function oc2 name sg vargs vres + +let call_all_test oc = + fprintf oc "int main(void)\n"; + fprintf oc "{\n"; + fprintf oc " alarm(60);\n"; + for i = 1 to !function_counter do + fprintf oc " call_f%d();\n" i + done; + fprintf oc " return failed;\n"; + fprintf oc "}\n" + +(* Generate interesting function signatures *) + +let all_ty = + [| Int8u; Int8s; Int16u; Int16s; Int32; Int64; Float32; Float64; String |] + +let base_ty = + [| Int32; Int64; Float32; Float64 |] + +let makerun pat len = + let rec make i l = + if l <= 0 + then [] + else pat.(i) :: make ((i + 1) mod (Array.length pat)) (l - 1) + in make 0 len + +let gen_fixed_sigs f = + (* All possible return types *) + Array.iter + (fun ty -> f { args = []; varargs = []; res = Some ty }) + all_ty; + (* All possible argument types *) + Array.iter + (fun ty -> f { args = [ty]; varargs = []; res = None }) + all_ty; + (* 2 arguments of base types *) + Array.iter + (fun ty1 -> + Array.iter + (fun ty2 -> f { args = [ty1; ty2]; varargs = []; res = None }) + base_ty) + base_ty; + (* 3 arguments of base types *) + Array.iter + (fun ty1 -> + Array.iter + (fun ty2 -> + Array.iter + (fun ty3 -> f { args = [ty1; ty2; ty3]; varargs = []; res = None }) + base_ty) + base_ty) + base_ty; + (* 4 arguments of base types *) + Array.iter + (fun ty1 -> + Array.iter + (fun ty2 -> + Array.iter + (fun ty3 -> + Array.iter + (fun ty4 -> + f { args = [ty1; ty2; ty3; ty4]; varargs = []; res = None }) + base_ty) + base_ty) + base_ty) + base_ty; + (* Runs of 6, 8, 10, 12, 16, 32 arguments of various patterns *) + Array.iter + (fun pat -> + Array.iter + (fun len -> + f { args = makerun pat len; varargs = []; res = None }) + [| 6;8;10;12;16;32 |]) + [| [|Int32|]; [|Int64|]; [|Float32|]; [|Float64|]; + [|Int32;Int64|]; [|Int32;Float32|]; [|Int32;Float64|]; + [|Int64;Float32|]; [|Int64;Float64|]; [|Float32;Float64|]; + [|Int32;Int64;Float32;Float64|] + |] + +let split_list l n = + let rec split l n accu = + if n <= 0 then (List.rev accu, l) else + match l with + | [] -> assert false + | h :: t -> split t (n - 1) (h :: accu) + in split l n [] + +let is_vararg_type = function + | Int32 | Int64 | Float64 | String -> true + | _ -> false + +let gen_vararg_sigs f = + let make_vararg sg n = + if List.length sg.args > n then begin + let (fixed, varia) = split_list sg.args n in + if List.for_all is_vararg_type varia + && is_vararg_type (List.nth fixed (n - 1)) then + f { args = fixed; varargs = varia; res = sg.res } + end + in + gen_fixed_sigs + (fun sg -> make_vararg sg 2; make_vararg sg 6; make_vararg sg 14) + +(* Generate interesting struct types *) + +let struct_counter = ref 0 + +let mkstruct oc members = + incr struct_counter; + let id = !struct_counter in + declare_struct oc id members; + Struct(id, members) + +let member_ty = + [| Int8u; Int16u; Int32; Int64; Float32; Float64 |] + +let gen_structs oc f = + (* One field of any type *) + Array.iter + (fun ty -> f (mkstruct oc [("a", ty)])) + all_ty; + (* Two fields of interesting types *) + Array.iter + (fun ty1 -> + Array.iter + (fun ty2 -> f (mkstruct oc [("a", ty1); ("b", ty2)])) + member_ty) + member_ty; + (* 3, 4, 6, 8 fields of identical interesting type *) + Array.iter + (fun ty -> + f (mkstruct oc [("a", ty); ("b", ty); ("c", ty)]); + f (mkstruct oc [("a", ty); ("b", ty); ("c", ty); ("d", ty)]); + f (mkstruct oc [("a", ty); ("b", ty); ("c", ty); ("d", ty); + ("e", ty); ("f", ty)]); + f (mkstruct oc [("a", ty); ("b", ty); ("c", ty); ("d", ty); + ("e", ty); ("f", ty); ("g", ty); ("h", ty)])) + member_ty + +let gen_struct_sigs oc f = + let make ty = + (* Struct return *) + f { args = []; varargs = []; res = Some ty }; + (* Struct passing (once, twice) *) + f { args = [ty]; varargs = []; res = None }; + f { args = [ty;ty]; varargs = []; res = None }; + (* Struct passing mixed with scalar arguments *) + f { args = [Int32;ty]; varargs = []; res = None }; + f { args = [Float64;ty]; varargs = []; res = None } + in + gen_structs oc make + +(* Random generation *) + +let pick arr = + arr.(Random.int (Array.length arr)) + +let big_ty = [| Int32; Int64; Float32; Float64; String |] + +let vararg_ty = [| Int32; Int64; Float64; String |] + +let random_funsig vararg = + let res = if Random.bool() then Some (pick all_ty) else None in + let numargs = Random.int 12 in + let args = List.init numargs (fun _ -> pick big_ty) in + let numvarargs = + if vararg && numargs > 0 && is_vararg_type (List.nth args (numargs - 1)) + then 1 + Random.int 12 + else 0 in + let varargs = List.init numvarargs (fun _ -> pick vararg_ty) in + { args; varargs; res } + +let header = +{|#include <stdarg.h> +#include <stdio.h> +#include <string.h> +#include <unistd.h> +|} + +let checking_code = {| +extern int failed; + +static void failure(const char * assertion, const char * file, + int line, const char * fn) +{ + fprintf(stderr, "%s:%d:%s: assertion %s failed\n", file, line, fn, assertion); + failed = 1; +} + +#define check(expr) ((expr) ? (void)0 : failure(#expr,__FILE__,__LINE__,__func__)) +|} + +let output_prefix = ref "abifuzz" +let gen_vararg = ref false +let gen_struct = ref false +let num_random = ref 0 + +let _ = + Arg.parse [ + "-plain", Arg.Unit (fun () -> gen_vararg := false; gen_struct := false), + " generate fixed-argument functions without structs"; + "-vararg", Arg.Set gen_vararg, + " generate variable-argument functions"; + "-structs", Arg.Set gen_struct, + " generate functions that exchange structs"; + "-o", Arg.String (fun s -> output_prefix := s), + " <prefix> produce <prefix>.h, <prefix>def.c and <prefix>use.c files"; + "-rnd", Arg.Int (fun n -> num_random := n), + " <num> produce <num> extra functions with random signatures"; + "-seed", Arg.Int Random.init, + " <seed> use the given seed for randomization" + ] + (fun s -> raise (Arg.Bad ("don't know what to do with " ^ s))) + "Usage: generator [options]\n\nOptions are:"; + let oc0 = open_out (!output_prefix ^ "_decl.h") + and oc1 = open_out (!output_prefix ^ "_def.c") + and oc2 = open_out (!output_prefix ^ "_use.c") in + fprintf oc0 "%s\n%s\n" header checking_code; + fprintf oc1 "%s#include \"%s_decl.h\"\n\n" header !output_prefix; + fprintf oc2 "%s#include \"%s_decl.h\"\n\nint failed = 0;\n\n" + header !output_prefix; + let cont = generate_one_test oc0 oc1 oc2 in + if !gen_vararg then gen_vararg_sigs cont + else if !gen_struct then gen_struct_sigs oc0 cont + else gen_fixed_sigs cont; + for i = 1 to !num_random do + cont (random_funsig !gen_vararg) + done; + call_all_test oc2; + close_out oc0; close_out oc1; close_out oc2 diff --git a/test/abi/genlayout.ml b/test/abi/genlayout.ml new file mode 100644 index 00000000..5c26ca35 --- /dev/null +++ b/test/abi/genlayout.ml @@ -0,0 +1,158 @@ +open Printf + +type typ = Bool | Char | Short | Int + +type field = + | Plain of typ + | Bitfield of typ * int + | Padding of typ * int + +type struct_ = field list + +(* Concise description of a struct *) + +let print_typ oc = function + | Bool -> fprintf oc "b" + | Char -> fprintf oc "c" + | Short -> fprintf oc "s" + | Int -> fprintf oc "i" + +let print_padding_typ oc = function + | Bool -> fprintf oc "B" + | Char -> fprintf oc "C" + | Short -> fprintf oc "S" + | Int -> fprintf oc "I" + +let print_field oc = function + | Plain t -> print_typ oc t + | Bitfield(t, w) -> fprintf oc "%a%d" print_typ t w + | Padding(t, w) -> fprintf oc "%a%d" print_padding_typ t w + +let rec print_struct oc = function + | [] -> () + | f :: s -> print_field oc f; print_struct oc s + +(* Printing a struct in C syntax *) + +let c_typ oc = function + | Bool -> fprintf oc "_Bool" + | Char -> fprintf oc "char" + | Short -> fprintf oc "short" + | Int -> fprintf oc "int" + +let c_name oc n = fprintf oc "%c" (Char.chr (Char.code 'a' + n)) + +let c_field oc n = function + | Plain t -> + fprintf oc " %a %a;\n" c_typ t c_name n; + n + 1 + | Bitfield(t, w) -> + fprintf oc " %a %a:%d;\n" c_typ t c_name n w; + n + 1 + | Padding(t, w) -> + fprintf oc " %a :%d;\n" c_typ t w; + n + +let c_struct oc s = + fprintf oc "struct %a {\n" print_struct s; + let rec c_str n = function + | [] -> () + | f :: s -> let n' = c_field oc n f in c_str n' s in + c_str 0 s; + fprintf oc "};\n" + +(* Random generation of structs *) + +let random_1_8 () = + let n1 = Random.bits() in + let n2 = n1 lsr 2 in + match n1 land 3 with + | 0 -> 1 + | 1 -> 2 + (n2 land 1) (* 2-3 *) + | 2 -> 4 + (n2 land 1) (* 4-5 *) + | 3 -> 6 + (n2 mod 3) (* 6-8 *) + | _ -> assert false + +let random_1_16 () = + let n1 = Random.bits() in + let n2 = n1 lsr 2 in + match n1 land 3 with + | 0 -> 1 + (n2 land 1) (* 1-2 *) + | 1 -> 3 + (n2 mod 3) (* 3-4-5 *) + | 2 -> 6 + (n2 land 3) (* 6-7-8-9 *) + | 3 -> 10 + (n2 mod 7) (* 10-16 *) + | _ -> assert false + +let random_1_32 () = + let n1 = Random.bits() in + let n2 = n1 lsr 2 in + match n1 land 3 with + | 0 -> 1 + (n2 land 1) (* 1-2 *) + | 1 -> 3 + (n2 mod 5) (* 3-4-5-6-7 *) + | 2 -> 8 + (n2 mod 8) (* 8-15 *) + | 3 -> 16 + (n2 mod 17) (* 16-32 *) + | _ -> assert false + +let random_field () = + let (t, w) = + match Random.int 9 with + | 0 -> (Bool, 1) + | 1|2 -> (Char, random_1_8()) + | 3|4 -> (Short, random_1_16()) + | _ -> (Int, random_1_32()) in + match Random.int 10 with + | 0 -> Padding(t, (if Random.int 3 = 0 then 0 else w)) + | 1 | 2 -> Plain t + | _ -> Bitfield(t, w) + +let rec random_struct len = + if len <= 0 then [] else begin + let f = random_field () in + f :: random_struct (match f with Padding _ -> len | _ -> len - 1) + end + +(* Optional filtering of structs where padding fields can increase alignment. + ELF says that padding fields are ignored to determine struct alignment, + but ARM does otherwise. *) + +let alignof = function Bool -> 1 | Char -> 1 | Short -> 2 | Int -> 4 + +let unstable_alignment str = + let rec alignments al_data al_padding = function + | [] -> + al_padding > al_data + | (Plain t | Bitfield(t, _)) :: l -> + alignments (max (alignof t) al_data) al_padding l + | Padding(t, _) :: l -> + alignments al_data (max (alignof t) al_padding) l + in + alignments 1 1 str + +(* Random testing *) + +let structsize = ref 4 +let ntests = ref 1000 +let stable = ref false + +let _ = + Arg.parse [ + "-size", Arg.Int (fun n -> structsize := n), + " <sz> produce structs with <sz> members (default: 4)"; + "-n", Arg.Int (fun n -> ntests := n), + " <num> produce <num> random structs"; + "-seed", Arg.Int Random.init, + " <seed> use the given seed for randomization"; + "-stable", Arg.Set stable, + " don't generate padding fields that could cause differences in alignment" + ] + (fun s -> raise (Arg.Bad ("don't know what to do with " ^ s))) + "Usage: genlayout [options]\n\nOptions are:"; + for _i = 1 to !ntests do + let s = random_struct !structsize in + if not (!stable && unstable_alignment s) then begin + printf "{\n"; + c_struct stdout s; + printf "TEST%d(%a)\n" !structsize print_struct s; + printf "}\n" + end + done diff --git a/test/abi/layout.c b/test/abi/layout.c new file mode 100644 index 00000000..ebc6a2b2 --- /dev/null +++ b/test/abi/layout.c @@ -0,0 +1,59 @@ +#include <stdio.h> +#include <stdlib.h> +#include <assert.h> +#include <string.h> +#include "../endian.h" + +static inline int bit(void * p, unsigned bitno) +{ + unsigned byteno = bitno / 8; +#ifdef ARCH_BIG_ENDIAN + unsigned bit_in_byte = 7 - (bitno & 7); +#else + unsigned bit_in_byte = bitno & 7; +#endif + return (((unsigned char *) p)[byteno] >> bit_in_byte) & 1; +} + +void print_prologue(char * name, size_t al, size_t sz) +{ + printf("%s: align %d, sizeof %d, layout", name, (int)al, (int)sz); +} + +void print_next_field(_Bool first, size_t sz, void * p) +{ + static unsigned pos; + + if (first) pos = 0; + /* Find first bit set, starting with [pos] */ + while (1) { + assert (pos < 8 * sz); + if (bit(p, pos)) break; + pos += 1; + } + /* Print this position */ + printf(" %u", pos); + /* Skip over one bits */ + while (pos < 8 * sz && bit(p, pos)) pos++; +} + +void print_epilogue(void) +{ + printf("\n"); +} + +#define TEST4(s) \ + struct s x; \ + memset(&x, 0, sizeof(x)); \ + print_prologue(#s, _Alignof(struct s), sizeof(x)); \ + x.a = -1; print_next_field(1, sizeof(x), &x); \ + x.b = -1; print_next_field(0, sizeof(x), &x); \ + x.c = -1; print_next_field(0, sizeof(x), &x); \ + x.d = -1; print_next_field(0, sizeof(x), &x); \ + print_epilogue(); + +int main() +{ +#include "layout.h" + return 0; +} diff --git a/test/abi/staticlayout.c b/test/abi/staticlayout.c new file mode 100644 index 00000000..8a655afc --- /dev/null +++ b/test/abi/staticlayout.c @@ -0,0 +1,76 @@ +#include <stdio.h> +#include "../endian.h" + +static inline int bit(void * p, unsigned bitno) +{ + unsigned byteno = bitno / 8; +#ifdef ARCH_BIG_ENDIAN + unsigned bit_in_byte = 7 - (bitno & 7); +#else + unsigned bit_in_byte = bitno & 7; +#endif + return (((unsigned char *) p)[byteno] >> bit_in_byte) & 1; +} + +void print_prologue(char * name, size_t al, size_t sz) +{ + printf("%s: align %d, sizeof %d, layout", name, (int)al, (int)sz); +} + +#if 0 +void print_contents(size_t sz, void * p) +{ + int last, lastpos; + printf(" - "); + last = 0; lastpos = 0; + for (int i = 0; i < sz; i++) { + for (int b = 0; b < 8; b++) { + int curr = bit((char *) p + i, b); + int currpos = i * 8 + b; + if (curr != last) { + if (currpos > lastpos) { + printf("%d(%d)", last, currpos - lastpos); + } + last = curr; lastpos = currpos; + } + } + } + { int currpos = sz * 8; + if (currpos > lastpos) { + printf("%d(%d)", last, currpos - lastpos); + } + } +} +#else +void print_contents(size_t sz, void * p) +{ + printf(" - "); + for (int i = 0; i < sz; i++) { + printf("%02x", ((unsigned char *)p)[i]); + } +} +#endif + +void print_epilogue (void) +{ + printf("\n"); +} + + +#define TEST4(s) \ + static struct s x1 = {-1, 0, 0, 0}; \ + static struct s x2 = {-1, -1, 0, 0}; \ + static struct s x3 = {-1, 0, -1, 0}; \ + static struct s x4 = {-1, -1, -1, -1}; \ + print_prologue(#s, _Alignof(struct s), sizeof(x1)); \ + print_contents(sizeof(x1), &x1); \ + print_contents(sizeof(x2), &x2); \ + print_contents(sizeof(x3), &x3); \ + print_contents(sizeof(x4), &x4); \ + print_epilogue(); + +int main() +{ +#include "layout.h" + return 0; +} diff --git a/test/clightgen/annotations.c b/test/clightgen/annotations.c index e91c7fbc..993fa7d0 100644 --- a/test/clightgen/annotations.c +++ b/test/clightgen/annotations.c @@ -1,6 +1,6 @@ int f(int x, long y) { -#if !defined(SYSTEM_macosx) && !defined(SYSTEM_cygwin) +#if !defined(SYSTEM_macos) && !defined(SYSTEM_cygwin) __builtin_ais_annot("x is %e1, y is %e2", x, y); #endif __builtin_annot("x is %1, y is %2", x, y); diff --git a/test/clightgen/bitfields.c b/test/clightgen/bitfields.c new file mode 100644 index 00000000..34f6a686 --- /dev/null +++ b/test/clightgen/bitfields.c @@ -0,0 +1,13 @@ +struct s { + int a: 10; + char : 6; + _Bool b : 1; + int : 0; + short c: 7; +}; + +int f(void) +{ + struct s x = { -1, 1, 2 }; + return x.a + x.b + x.c; +} diff --git a/test/regression/Makefile b/test/regression/Makefile index 28439ed5..33a9f993 100644 --- a/test/regression/Makefile +++ b/test/regression/Makefile @@ -15,13 +15,13 @@ TESTS=int32 int64 floats floats-basics floats-lit \ volatile1 volatile2 volatile3 volatile4 \ funct3 expr5 struct7 struct8 struct11 struct12 casts1 casts2 char1 \ sizeof1 sizeof2 binops bool for1 for2 switch switch2 compound \ - decl1 interop1 bitfields9 ptrs3 \ + decl1 bitfields9 ptrs3 \ parsing krfun ifconv # Can run, but only in compiled mode, and have reference output in Results TESTS_COMP=attribs1 bitfields1 bitfields2 bitfields3 bitfields4 \ - bitfields5 bitfields6 bitfields7 bitfields8 \ + bitfields5 bitfields6 bitfields7 bitfields8 bitfields_uint_t bitfields10 \ builtins-common builtins-$(ARCH) packedstruct1 packedstruct2 alignas \ varargs1 varargs2 varargs3 sections alias aligned @@ -44,13 +44,6 @@ all: $(TESTS:%=%.compcert) $(TESTS_COMP:%=%.compcert) $(TESTS_DIFF:%=%.compcert) all_s: $(TESTS:%=%.s) $(TESTS_COMP:%=%.s) $(TESTS_DIFF:%=%.s) $(EXTRAS:%=%.s) -interop1.compcert: interop1.c - $(CC) -DCC_SIDE -c -o interop1n.o interop1.c - $(CCOMP) $(CCOMPFLAGS) -DCOMPCERT_SIDE -o interop1.compcert interop1.c interop1n.o $(LIBS) - -interop1.s: interop1.c - $(CCOMP) $(CCOMPFLAGS) -S interop1.c - %.compcert: %.c $(CCOMP) $(CCOMPFLAGS) -o $*.compcert $*.c $(LIBS) diff --git a/test/regression/Results/bitfields10 b/test/regression/Results/bitfields10 new file mode 100644 index 00000000..9dc00daf --- /dev/null +++ b/test/regression/Results/bitfields10 @@ -0,0 +1,14 @@ +loc_s = { a = 11, b = 2 } +loc_t = { c = 11, d = 1, e = 2 } +loc_u_u = { u = -5 } +loc_u_v = { v = 3 } +compound_s = { a = 2, b = 3 } +compound_t = { c = 2, d = 1, e = -11 } +compound_u = { u = 2 } +loc_s = { a = 7, b = 2 } +loc_t = { c = 7, d = 1, e = 50 } +loc_u_u = { u = 7 } +loc_u_v = { v = 2 } +compound_s = { a = -14, b = 3 } +compound_t = { c = 50, d = 1, e = -7 } +compound_u = { u = 2 } diff --git a/test/regression/Results/bitfields9 b/test/regression/Results/bitfields9 index e35c2414..ec35fc08 100644 --- a/test/regression/Results/bitfields9 +++ b/test/regression/Results/bitfields9 @@ -2,17 +2,7 @@ glob_s = { a = -12, b = 1 } glob_t = { c = 123, d = 1, e = -45 } glob_u_u = { u = -3 } glob_u_v = { v = 6 } -loc_s = { a = 11, b = 2 } -loc_t = { c = 11, d = 1, e = 2 } -loc_u_u = { u = -5 } -loc_u_v = { v = 3 } -compound_s = { a = 2, b = 3 } -compound_t = { c = 2, d = 1, e = -11 } -compound_u = { u = 2 } -loc_s = { a = 7, b = 2 } -loc_t = { c = 7, d = 1, e = 50 } -loc_u_u = { u = 7 } -loc_u_v = { v = 2 } -compound_s = { a = -14, b = 3 } -compound_t = { c = 50, d = 1, e = -7 } -compound_u = { u = 2 } +loc_s = { a = -12, b = 1 } +loc_t = { c = 123, d = 1, e = -45 } +loc_u_u = { u = -3 } +loc_u_v = { v = 6 } diff --git a/test/regression/Results/bitfields_uint_t b/test/regression/Results/bitfields_uint_t new file mode 100644 index 00000000..f55071d0 --- /dev/null +++ b/test/regression/Results/bitfields_uint_t @@ -0,0 +1 @@ +x = { a = 1, b = 2, c = 3, d = 4 } diff --git a/test/regression/Results/interop1 b/test/regression/Results/interop1 deleted file mode 100644 index 6e32c1cb..00000000 --- a/test/regression/Results/interop1 +++ /dev/null @@ -1,98 +0,0 @@ ---- CompCert calling native: -si8u: 177 -si8s: -79 -si16u: 64305 -si16s: -1231 -s1: { a = 'a' } -s2: { a = 'a', b = 'b' } -s3: { a = 'a', b = 'b', c = ' c' } -s4: { a = 'a', b = 'b', c = ' c', d = 'd' } -s5: { a = 'a', b = 'b', c = ' c', d = 'd', e = 'e' } -s6: { a = 'a', b = 'b', c = ' c', d = 'd', e = 'e', f = 'f' } -s7: { a = 'a', b = 'b', c = ' c', d = 'd', e = 'e', f = 'f', g = 'g' } -s8: "Hello world!" -t1: { a = 123 } -t2: { a = 123, b = 456 } -t3: { a = 123, b = 456, c = 789 } -t4: { a = 123, b = 456, c = 789, d = -111 } -t5: { a = 123, b = 456, c = 789, d = -999, e = 'x' } -u1: { a = 12 } -u2: { a = 12, b = -34 } -u3: { a = 12, b = 34, c = -56 } -u4: { a = 12, b = 34, c = 56, d = -78 } -u5: { a = 1234, b = 'u' } -u6: { a = 55555, b = 666 } -u7: { a = -10001, b = -789, c = 'z' } -u8: { a = 'x', b = 12345 } -after ms4, x = { 's', 'a', 'm', 'e' } -after mu4, x = { a = { 11, 22, 33, 44 } } -rs1: { a = 'a' } -rs2: { a = 'a', b = 'b' } -rs3: { a = 'a', b = 'b', c = ' c' } -rs4: { a = 'a', b = 'b', c = ' c', d = 'd' } -rs5: { a = 'a', b = 'b', c = ' c', d = 'd', e = 'e' } -rs6: { a = 'a', b = 'b', c = ' c', d = 'd', e = 'e', f = 'f' } -rs7: { a = 'a', b = 'b', c = ' c', d = 'd', e = 'e', f = 'f', g = 'g' } -rs8: "Hello world!" -rt1: { a = 123 } -rt2: { a = 123, b = 456 } -rt3: { a = 123, b = 456, c = 789 } -rt4: { a = 123, b = 456, c = 789, d = -111 } -rt5: { a = 123, b = 456, c = 789, d = -999, e = 'x' } -ru1: { a = 12 } -ru2: { a = 12, b = -34 } -ru3: { a = 12, b = 34, c = -56 } -ru4: { a = 12, b = 34, c = 56, d = -78 } -ru5: { a = 1234, b = 'u' } -ru6: { a = 55555, b = 666 } -ru7: { a = -10001, b = -789, c = 'z' } -ru8: { a = 'x', b = 12345 } ---- native calling CompCert: -si8u: 177 -si8s: -79 -si16u: 64305 -si16s: -1231 -s1: { a = 'a' } -s2: { a = 'a', b = 'b' } -s3: { a = 'a', b = 'b', c = ' c' } -s4: { a = 'a', b = 'b', c = ' c', d = 'd' } -s5: { a = 'a', b = 'b', c = ' c', d = 'd', e = 'e' } -s6: { a = 'a', b = 'b', c = ' c', d = 'd', e = 'e', f = 'f' } -s7: { a = 'a', b = 'b', c = ' c', d = 'd', e = 'e', f = 'f', g = 'g' } -s8: "Hello world!" -t1: { a = 123 } -t2: { a = 123, b = 456 } -t3: { a = 123, b = 456, c = 789 } -t4: { a = 123, b = 456, c = 789, d = -111 } -t5: { a = 123, b = 456, c = 789, d = -999, e = 'x' } -u1: { a = 12 } -u2: { a = 12, b = -34 } -u3: { a = 12, b = 34, c = -56 } -u4: { a = 12, b = 34, c = 56, d = -78 } -u5: { a = 1234, b = 'u' } -u6: { a = 55555, b = 666 } -u7: { a = -10001, b = -789, c = 'z' } -u8: { a = 'x', b = 12345 } -after ms4, x = { 's', 'a', 'm', 'e' } -after mu4, x = { a = { 11, 22, 33, 44 } } -rs1: { a = 'a' } -rs2: { a = 'a', b = 'b' } -rs3: { a = 'a', b = 'b', c = ' c' } -rs4: { a = 'a', b = 'b', c = ' c', d = 'd' } -rs5: { a = 'a', b = 'b', c = ' c', d = 'd', e = 'e' } -rs6: { a = 'a', b = 'b', c = ' c', d = 'd', e = 'e', f = 'f' } -rs7: { a = 'a', b = 'b', c = ' c', d = 'd', e = 'e', f = 'f', g = 'g' } -rs8: "Hello world!" -rt1: { a = 123 } -rt2: { a = 123, b = 456 } -rt3: { a = 123, b = 456, c = 789 } -rt4: { a = 123, b = 456, c = 789, d = -111 } -rt5: { a = 123, b = 456, c = 789, d = -999, e = 'x' } -ru1: { a = 12 } -ru2: { a = 12, b = -34 } -ru3: { a = 12, b = 34, c = -56 } -ru4: { a = 12, b = 34, c = 56, d = -78 } -ru5: { a = 1234, b = 'u' } -ru6: { a = 55555, b = 666 } -ru7: { a = -10001, b = -789, c = 'z' } -ru8: { a = 'x', b = 12345 } diff --git a/test/regression/Results/varargs2 b/test/regression/Results/varargs2 index 96ee9d63..9e77da1b 100644 --- a/test/regression/Results/varargs2 +++ b/test/regression/Results/varargs2 @@ -10,4 +10,5 @@ Twice: -1 1.23 With va_copy: -1 1.23 With va_copy: -1 1.23 With extra args: x & Hello, world! & 42 & 123456789012345 & 3.141592654 & 2.718281746 +With extra FP args: 3.141592654 & 2.718281746 & 1 & 2 & 3 & 4 & 5 & 6 & 7 & 8 & 42 va_list compatibility: x & Hello, world! & 42 & 123456789012345 & 3.141592654 & 2.718281746 diff --git a/test/regression/Runtest b/test/regression/Runtest index f693219a..600ae045 100755 --- a/test/regression/Runtest +++ b/test/regression/Runtest @@ -51,7 +51,7 @@ then exit 0 else echo "$name: WRONG OUTPUT (diff follows)" - diff -u "$ref" "$out" + diff -a -u "$ref" "$out" exit 2 fi else diff --git a/test/regression/bitfields10.c b/test/regression/bitfields10.c new file mode 100644 index 00000000..0f022664 --- /dev/null +++ b/test/regression/bitfields10.c @@ -0,0 +1,66 @@ +#include <stdio.h> + +/* Dynamic initialization of bit-fields */ +/* Known not to work with the reference interpreter */ + +struct s { + signed char a: 6; + unsigned int b: 2; +}; + +struct t { + unsigned int c: 16; + _Bool d: 1; + short e: 8; + int : 10; +}; + +union u { + int u: 4; + unsigned int v: 3; +}; + +void print_s(char * msg, struct s p) +{ + printf("%s = { a = %d, b = %d }\n", msg, p.a, p.b); +} + +void print_t(char * msg, struct t p) +{ + printf("%s = { c = %d, d = %d, e = %d }\n", msg, p.c, p.d, p.e); +} + +void print_u_u(char * msg, union u p) +{ + printf("%s = { u = %d }\n", msg, p.u); +} + +void print_u_v(char * msg, union u p) +{ + printf("%s = { v = %u }\n", msg, p.v); +} + +/* Local, non-static initialization */ +void f(int x, int y, int z) +{ + struct s loc_s = { x, y }; + struct t loc_t = { x, z, y }; + union u loc_u_u = { .u = x }; + union u loc_u_v = { .v = z }; + print_s("loc_s", loc_s); + print_t("loc_t", loc_t); + print_u_u("loc_u_u", loc_u_u); + print_u_v("loc_u_v", loc_u_v); + print_s("compound_s", (struct s) { y, x }); + print_t("compound_t", (struct t) { y, ~z, -x }); + print_u_u("compound_u", (union u) { y }); +} + +int main() +{ + f(11, 2, 3); + f(7, 50, 2); + return 0; +} + + diff --git a/test/regression/bitfields9.c b/test/regression/bitfields9.c index eef20168..025216fa 100644 --- a/test/regression/bitfields9.c +++ b/test/regression/bitfields9.c @@ -1,6 +1,6 @@ #include <stdio.h> -/* Initialization of bit-fields */ +/* Static initialization of bit-fields */ struct s { signed char a: 6; @@ -39,27 +39,23 @@ void print_u_v(char * msg, union u p) printf("%s = { v = %u }\n", msg, p.v); } - /* Global initialization */ struct s glob_s = { -12, 1 }; struct t glob_t = { 123, 2, -45 }; union u glob_u_u = { -3 }; union u glob_u_v = { .v = 6 }; -/* Local initialization */ -void f(int x, int y, int z) +/* Local, static initialization */ +void f(void) { - struct s loc_s = { x, y }; - struct t loc_t = { x, z, y }; - union u loc_u_u = { .u = x }; - union u loc_u_v = { .v = z }; + static struct s loc_s = { -12, 1 }; + static struct t loc_t = { 123, 2, -45 }; + static union u loc_u_u = { -3 }; + static union u loc_u_v = { .v = 6 }; print_s("loc_s", loc_s); print_t("loc_t", loc_t); print_u_u("loc_u_u", loc_u_u); print_u_v("loc_u_v", loc_u_v); - print_s("compound_s", (struct s) { y, x }); - print_t("compound_t", (struct t) { y, ~z, -x }); - print_u_u("compound_u", (union u) { y }); } int main() @@ -68,8 +64,7 @@ int main() print_t("glob_t", glob_t); print_u_u("glob_u_u", glob_u_u); print_u_v("glob_u_v", glob_u_v); - f(11, 2, 3); - f(7, 50, 2); + f(); return 0; } diff --git a/test/regression/bitfields_uint_t.c b/test/regression/bitfields_uint_t.c new file mode 100644 index 00000000..3d7fb4e7 --- /dev/null +++ b/test/regression/bitfields_uint_t.c @@ -0,0 +1,22 @@ +#include <stdio.h> +#include <stdint.h> + +/* Test that uint32 type synonym works. + This previously failed for standard headers where uint32 is defined + as a (32-bit) unsigned long. */ + +struct s { + uint32_t a: 1; + uint32_t b: 2; + uint32_t c: 9; + uint32_t d: 20; +}; + +struct s x = { 1, 2, 3, 4 }; + +int main() +{ + printf("x = { a = %d, b = %d, c = %d, d = %d }\n", x.a, x.b, x.c, x.d); +} + + diff --git a/test/regression/interop1.c b/test/regression/interop1.c deleted file mode 100644 index 6836b89e..00000000 --- a/test/regression/interop1.c +++ /dev/null @@ -1,301 +0,0 @@ -#if defined(COMPCERT_SIDE) -#define US(x) compcert_##x -#define THEM(x) native_##x -#elif defined(CC_SIDE) -#define US(x) native_##x -#define THEM(x) compcert_##x -#else -#define US(x) x -#define THEM(x) x -#endif - -#include <stdio.h> - -/* Alignment 1 */ - -struct S1 { char a; }; -static struct S1 init_S1 = { 'a' }; -#define print_S1(x) printf("{ a = '%c' }\n", x.a) - -struct S2 { char a, b; }; -static struct S2 init_S2 = { 'a', 'b' }; -#define print_S2(x) printf("{ a = '%c', b = '%c' }\n", x.a, x.b) - -struct S3 { char a, b, c; }; -static struct S3 init_S3 = { 'a', 'b', 'c' }; -#define print_S3(x) \ - printf("{ a = '%c', b = '%c', c = ' %c' }\n", x.a, x.b, x.c) - -struct S4 { char a, b, c, d; }; -static struct S4 init_S4 = { 'a', 'b', 'c', 'd' }; -#define print_S4(x) \ - printf("{ a = '%c', b = '%c', c = ' %c', d = '%c' }\n", \ - x.a, x.b, x.c, x.d); - -struct S5 { char a, b, c, d, e; }; -static struct S5 init_S5 = { 'a', 'b', 'c', 'd', 'e' }; -#define print_S5(x) \ - printf("{ a = '%c', b = '%c', c = ' %c', d = '%c', e = '%c' }\n", \ - x.a, x.b, x.c, x.d, x.e) - -struct S6 { char a, b, c, d, e, f; }; -static struct S6 init_S6 = { 'a', 'b', 'c', 'd', 'e', 'f' }; -#define print_S6(x) \ - printf("{ a = '%c', b = '%c', c = ' %c', d = '%c', e = '%c', f = '%c' }\n", \ - x.a, x.b, x.c, x.d, x.e, x.f) - -struct S7 { char a, b, c, d, e, f, g; }; -static struct S7 init_S7 = { 'a', 'b', 'c', 'd', 'e', 'f', 'g' }; -#define print_S7(x) \ - printf("{ a = '%c', b = '%c', c = ' %c', d = '%c', e = '%c', f = '%c', g = '%c' }\n", \ - x.a, x.b, x.c, x.d, x.e, x.f, x.g) - -struct S8 { char a[32]; }; -static struct S8 init_S8 = { "Hello world!" }; -/* Do not use printf("%s") to avoid undefined behavior in the - reference interpreter */ -#define print_S8(x) \ - { char * p; \ - printf("\""); \ - for (p = x.a; *p != 0; p++) printf("%c", *p); \ - printf("\"\n"); \ - } - -/* Alignment 2 */ - -struct T1 { short a; }; -static struct T1 init_T1 = { 123 }; -#define print_T1(x) printf("{ a = %d }\n", x.a) - -struct T2 { short a, b; }; -static struct T2 init_T2 = { 123, 456 }; -#define print_T2(x) printf("{ a = %d, b = %d }\n", x.a, x.b) - -struct T3 { short a, b, c; }; -static struct T3 init_T3 = { 123, 456, 789 }; -#define print_T3(x) printf("{ a = %d, b = %d, c = %d }\n", x.a, x.b, x.c) - -struct T4 { short a, b, c, d; }; -static struct T4 init_T4 = { 123, 456, 789, -111 }; -#define print_T4(x) \ - printf("{ a = %d, b = %d, c = %d, d = %d }\n", x.a, x.b, x.c, x.d) - -struct T5 { short a, b, c, d; char e; }; -static struct T5 init_T5 = { 123, 456, 789, -999, 'x' }; -#define print_T5(x) \ - printf("{ a = %d, b = %d, c = %d, d = %d, e = '%c' }\n", \ - x.a, x.b, x.c, x.d, x.e) - -/* Alignment >= 4 */ - -struct U1 { int a; }; -static struct U1 init_U1 = { 12 }; -#define print_U1(x) printf("{ a = %d }\n", x.a) - -struct U2 { int a, b; }; -static struct U2 init_U2 = { 12, -34 }; -#define print_U2(x) printf("{ a = %d, b = %d }\n", x.a, x.b) - -struct U3 { int a, b, c; }; -static struct U3 init_U3 = { 12, 34, -56}; -#define print_U3(x) printf("{ a = %d, b = %d, c = %d }\n", x.a, x.b, x.c) - -struct U4 { int a, b, c, d; }; -static struct U4 init_U4 = { 12, 34, 56, -78 }; -#define print_U4(x) \ - printf("{ a = %d, b = %d, c = %d, d = %d }\n", x.a, x.b, x.c, x.d) - -struct U5 { int a; char b; }; -static struct U5 init_U5 = { 1234, 'u' }; -#define print_U5(x) \ - printf("{ a = %d, b = '%c' }\n", x.a, x.b) - -struct U6 { int a; short b; }; -static struct U6 init_U6 = { 55555, 666 }; -#define print_U6(x) \ - printf("{ a = %d, b = %d }\n", x.a, x.b) - -struct U7 { int a; short b; char c; }; -static struct U7 init_U7 = { -10001, -789, 'z' }; -#define print_U7(x) \ - printf("{ a = %d, b = %d, c = '%c' }\n", x.a, x.b, x.c) - -struct U8 { char a; int b; }; -static struct U8 init_U8 = { 'x', 12345 }; -#define print_U8(x) \ - printf("{ a = '%c', b = %d }\n", x.a, x.b) - -/* Struct passing */ - -#define PRINT(name,ty,print) \ -extern void THEM(name) (struct ty x); \ -void US(name) (struct ty x) { print(x); } - -PRINT(s1,S1,print_S1) -PRINT(s2,S2,print_S2) -PRINT(s3,S3,print_S3) -PRINT(s4,S4,print_S4) -PRINT(s5,S5,print_S5) -PRINT(s6,S6,print_S6) -PRINT(s7,S7,print_S7) -PRINT(s8,S8,print_S8) -PRINT(t1,T1,print_T1) -PRINT(t2,T2,print_T2) -PRINT(t3,T3,print_T3) -PRINT(t4,T4,print_T4) -PRINT(t5,T5,print_T5) -PRINT(u1,U1,print_U1) -PRINT(u2,U2,print_U2) -PRINT(u3,U3,print_U3) -PRINT(u4,U4,print_U4) -PRINT(u5,U5,print_U5) -PRINT(u6,U6,print_U6) -PRINT(u7,U7,print_U7) -PRINT(u8,U8,print_U8) - -/* Struct passing with modification in the callee */ - -extern void THEM (ms4) (struct S4 x); -void US (ms4) (struct S4 x) -{ - x.a += 1; x.d -= 1; -} - -extern void THEM (mu4) (struct U4 x); -void US (mu4) (struct U4 x) -{ - x.a = 1; x.b = 2; -} - -/* Struct return */ - -#define RETURN(name,ty,init) \ -extern struct ty THEM(name)(void); \ -struct ty US(name)(void) { return init; } - -RETURN(rs1,S1,init_S1) -RETURN(rs2,S2,init_S2) -RETURN(rs3,S3,init_S3) -RETURN(rs4,S4,init_S4) -RETURN(rs5,S5,init_S5) -RETURN(rs6,S6,init_S6) -RETURN(rs7,S7,init_S7) -RETURN(rs8,S8,init_S8) -RETURN(rt1,T1,init_T1) -RETURN(rt2,T2,init_T2) -RETURN(rt3,T3,init_T3) -RETURN(rt4,T4,init_T4) -RETURN(rt5,T5,init_T5) -RETURN(ru1,U1,init_U1) -RETURN(ru2,U2,init_U2) -RETURN(ru3,U3,init_U3) -RETURN(ru4,U4,init_U4) -RETURN(ru5,U5,init_U5) -RETURN(ru6,U6,init_U6) -RETURN(ru7,U7,init_U7) -RETURN(ru8,U8,init_U8) - -/* Returning small integers */ - -#define SMALLINT(name,ty) \ -extern ty THEM(name)(int); \ -ty US(name)(int x) { return x * x; } - -SMALLINT(si8u, unsigned char) -SMALLINT(si8s, signed char) -SMALLINT(si16u, unsigned short) -SMALLINT(si16s, signed short) - -/* Test function, calling the functions compiled by the other compiler */ - -#define CALLPRINT(name,ty,init) \ - printf(#name": "); THEM(name)(init); - -#define CALLRETURN(name,ty,print) \ - { struct ty x = THEM(name)(); \ - printf(#name": "); print(x); } - -extern void THEM(test) (void); -void US(test) (void) -{ - printf("si8u: %d\n", THEM(si8u)(12345)); - printf("si8s: %d\n", THEM(si8s)(12345)); - printf("si16u: %d\n", THEM(si16u)(1234567)); - printf("si16s: %d\n", THEM(si16s)(1234567)); - CALLPRINT(s1,S1,init_S1) - CALLPRINT(s2,S2,init_S2) - CALLPRINT(s3,S3,init_S3) - CALLPRINT(s4,S4,init_S4) - CALLPRINT(s5,S5,init_S5) - CALLPRINT(s6,S6,init_S6) - CALLPRINT(s7,S7,init_S7) - CALLPRINT(s8,S8,init_S8) - CALLPRINT(t1,T1,init_T1) - CALLPRINT(t2,T2,init_T2) - CALLPRINT(t3,T3,init_T3) - CALLPRINT(t4,T4,init_T4) - CALLPRINT(t5,T5,init_T5) - CALLPRINT(u1,U1,init_U1) - CALLPRINT(u2,U2,init_U2) - CALLPRINT(u3,U3,init_U3) - CALLPRINT(u4,U4,init_U4) - CALLPRINT(u5,U5,init_U5) - CALLPRINT(u6,U6,init_U6) - CALLPRINT(u7,U7,init_U7) - CALLPRINT(u8,U8,init_U8) - - { struct S4 x = { 's', 'a', 'm', 'e' }; - THEM(ms4)(x); - printf("after ms4, x = { '%c', '%c', '%c', '%c' }\n", x.a, x.b, x.c, x.d); } - { struct U4 x = { 11, 22, 33, 44 }; - THEM(mu4)(x); - printf("after mu4, x = { a = { %d, %d, %d, %d } }\n", x.a, x.b, x.c, x.d); } - - CALLRETURN(rs1,S1,print_S1) - CALLRETURN(rs2,S2,print_S2) - CALLRETURN(rs3,S3,print_S3) - CALLRETURN(rs4,S4,print_S4) - CALLRETURN(rs5,S5,print_S5) - CALLRETURN(rs6,S6,print_S6) - CALLRETURN(rs7,S7,print_S7) - CALLRETURN(rs8,S8,print_S8) - CALLRETURN(rt1,T1,print_T1) - CALLRETURN(rt2,T2,print_T2) - CALLRETURN(rt3,T3,print_T3) - CALLRETURN(rt4,T4,print_T4) - CALLRETURN(rt5,T5,print_T5) - CALLRETURN(ru1,U1,print_U1) - CALLRETURN(ru2,U2,print_U2) - CALLRETURN(ru3,U3,print_U3) - CALLRETURN(ru4,U4,print_U4) - CALLRETURN(ru5,U5,print_U5) - CALLRETURN(ru6,U6,print_U6) - CALLRETURN(ru7,U7,print_U7) - CALLRETURN(ru8,U8,print_U8) -} - -#if defined(COMPCERT_SIDE) - -int main() -{ - printf("--- CompCert calling native:\n"); - compcert_test(); - printf("--- native calling CompCert:\n"); - native_test(); - return 0; -} - -#elif !defined(CC_SIDE) - -int main() -{ - printf("--- CompCert calling native:\n"); - test(); - printf("--- native calling CompCert:\n"); - test(); - return 0; -} - -#endif - - diff --git a/test/regression/interop1.cond b/test/regression/interop1.cond deleted file mode 100644 index 77904189..00000000 --- a/test/regression/interop1.cond +++ /dev/null @@ -1,10 +0,0 @@ -#!/bin/sh -arch=`sed -n -e 's/^ARCH=//p' ../../Makefile.config` -model=`sed -n -e 's/^MODEL=//p' ../../Makefile.config` -system=`sed -n -e 's/^SYSTEM=//p' ../../Makefile.config` - -case "$arch,$model,$system" in - *,*,cygwin) exit $SKIP;; - x86,32sse2,*|arm,*,*|powerpc,*,*) exit $RUN;; - *) exit $SKIP;; -esac diff --git a/test/regression/sizeof1.c b/test/regression/sizeof1.c index ca494622..5bd4d739 100644 --- a/test/regression/sizeof1.c +++ b/test/regression/sizeof1.c @@ -17,8 +17,8 @@ char tbl[sizeof(struct s)]; */ struct bits1 { - unsigned a: 1; - unsigned b: 6; + unsigned char a: 1; + unsigned char b: 6; }; char b1[sizeof(struct bits1)]; /* should be 1 */ diff --git a/test/regression/varargs2.c b/test/regression/varargs2.c index b96d1940..d64509e5 100644 --- a/test/regression/varargs2.c +++ b/test/regression/varargs2.c @@ -104,6 +104,17 @@ void miniprintf_extra(int i1, int i2, int i3, int i4, va_end(va); } +/* Add a few dummy FP arguments to test passing of variadic FP arguments + in integer registers (mostly relevant for RISC-V) */ + +void miniprintf_float(double f1, double f2, const char * fmt, ...) +{ + va_list va; + va_start(va, fmt); + minivprintf(fmt, va); + va_end(va); +} + /* Test va_list compatibility with the C library */ void printf_compat(const char * fmt, ...) @@ -143,6 +154,11 @@ int main() 123456789012345LL, 3.141592654, 2.71828182); + miniprintf_float(0.0, 0.5, + "With extra FP args: %e & %f & %e & %e & %e & %e & %e & %e & %e & %e & %d\n", + 3.141592654, + 2.71828182, + 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 8.0, 42); printf_compat("va_list compatibility: %c & %s & %d & %lld & %.10g & %.10g\n", 'x', "Hello, world!", diff --git a/tools/modorder.ml b/tools/modorder.ml index 7ca6a9e9..b72ae762 100644 --- a/tools/modorder.ml +++ b/tools/modorder.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/tools/ndfun.ml b/tools/ndfun.ml index b6a87ede..3e3daad2 100644 --- a/tools/ndfun.ml +++ b/tools/ndfun.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/tools/xtime.ml b/tools/xtime.ml index fbb25a49..3480f229 100644 --- a/tools/xtime.ml +++ b/tools/xtime.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/verilog/Asm.v b/verilog/Asm.v index 58e28c40..64ae1c32 100644 --- a/verilog/Asm.v +++ b/verilog/Asm.v @@ -1191,7 +1191,7 @@ Ltac Equalities := split. auto. intros. destruct B; auto. subst. auto. - (* trace length *) red; intros; inv H; simpl. - omega. + lia. eapply external_call_trace_length; eauto. eapply external_call_trace_length; eauto. - (* initial states *) diff --git a/verilog/Asmexpand.ml b/verilog/Asmexpand.ml index caa9775a..1b3961e0 100644 --- a/verilog/Asmexpand.ml +++ b/verilog/Asmexpand.ml @@ -39,12 +39,7 @@ let _16z = Z.of_sint 16 let stack_alignment () = 16 -(* Pseudo instructions for 32/64 bit compatibility *) - -let _Plea (r, addr) = - if Archi.ptr64 then Pleaq (r, addr) else Pleal (r, addr) - -(* SP adjustment to allocate or free a stack frame *) +(* SP adjustment to allocate or free a stack frame. *) let align n a = if n >= 0 then (n + a - 1) land (-a) else n land (-a) @@ -56,7 +51,7 @@ let sp_adjustment_32 sz = (* The top 4 bytes have already been allocated by the "call" instruction. *) sz - 4 -let sp_adjustment_64 sz = +let sp_adjustment_elf64 sz = let sz = Z.to_int sz in if is_current_function_variadic() then begin (* If variadic, add room for register save area, which must be 16-aligned *) @@ -73,6 +68,13 @@ let sp_adjustment_64 sz = (sz - 8, -1) end +let sp_adjustment_win64 sz = + let sz = Z.to_int sz in + (* Preserve proper alignment of the stack *) + let sz = align sz 16 in + (* The top 8 bytes have already been allocated by the "call" instruction. *) + sz - 8 + (* Built-ins. They come in two flavors: - annotation statements: take their arguments in registers or stack locations; generate no code; @@ -102,6 +104,21 @@ let offset_addressing (Addrmode(base, ofs, cst)) delta = let linear_addr reg ofs = Addrmode(Some reg, None, Coq_inl ofs) let global_addr id ofs = Addrmode(None, None, Coq_inr(id, ofs)) +(* A "leaq" instruction that does not overflow *) + +let emit_leaq r addr = + match Asmgen.normalize_addrmode_64 addr with + | (addr, None) -> + emit (Pleaq (r, addr)) + | (addr, Some delta) -> + emit (Pleaq (r, addr)); + emit (Paddq_ri (r, delta)) + +(* Pseudo "lea" instruction for 32/64 bit compatibility *) + +let emit_lea r addr = + if Archi.ptr64 then emit_leaq r addr else emit (Pleal (r, addr)) + (* Translate a builtin argument into an addressing mode *) let addressing_of_builtin_arg = function @@ -143,8 +160,8 @@ let expand_builtin_memcpy_small sz al src dst = copy (addressing_of_builtin_arg src) (addressing_of_builtin_arg dst) sz let expand_builtin_memcpy_big sz al src dst = - if src <> BA (IR RSI) then emit (_Plea (RSI, addressing_of_builtin_arg src)); - if dst <> BA (IR RDI) then emit (_Plea (RDI, addressing_of_builtin_arg dst)); + if src <> BA (IR RSI) then emit_lea RSI (addressing_of_builtin_arg src); + if dst <> BA (IR RDI) then emit_lea RDI (addressing_of_builtin_arg dst); (* TODO: movsq? *) emit (Pmovl_ri (RCX,coqint_of_camlint (Int32.of_int (sz / 4)))); emit Prep_movsl; @@ -256,7 +273,7 @@ let expand_builtin_va_start_32 r = emit (Pleal (RAX, linear_addr RSP (Z.of_uint32 ofs))); emit (Pmovl_mr (linear_addr r _0z, RAX)) -let expand_builtin_va_start_64 r = +let expand_builtin_va_start_elf64 r = if not (is_current_function_variadic ()) then invalid_arg "Fatal error: va_start used in non-vararg function"; let (ir, fr, ofs) = @@ -282,11 +299,22 @@ let expand_builtin_va_start_64 r = emit (Pmovl_mr (linear_addr r _0z, RAX)); emit (Pmovl_ri (RAX, coqint_of_camlint fp_offset)); emit (Pmovl_mr (linear_addr r _4z, RAX)); - emit (Pleaq (RAX, linear_addr RSP (Z.of_uint64 overflow_arg_area))); + emit_leaq RAX (linear_addr RSP (Z.of_uint64 overflow_arg_area)); emit (Pmovq_mr (linear_addr r _8z, RAX)); - emit (Pleaq (RAX, linear_addr RSP (Z.of_uint64 reg_save_area))); + emit_leaq RAX (linear_addr RSP (Z.of_uint64 reg_save_area)); emit (Pmovq_mr (linear_addr r _16z, RAX)) +let expand_builtin_va_start_win64 r = + if not (is_current_function_variadic ()) then + invalid_arg "Fatal error: va_start used in non-vararg function"; + let num_args = + List.length (get_current_function_args()) in + let ofs = + Int64.(add !current_function_stacksize + (mul 8L (of_int num_args))) in + emit_leaq RAX (linear_addr RSP (Z.of_uint64 ofs)); + emit (Pmovq_mr (linear_addr r _0z, RAX)) + (* FMA operations *) (* vfmadd<i><j><k> r1, r2, r3 performs r1 := ri * rj + rk @@ -463,44 +491,63 @@ let expand_builtin_inline name args res = (* Vararg stuff *) | "__builtin_va_start", [BA(IR a)], _ -> assert (a = RDX); - if Archi.ptr64 - then expand_builtin_va_start_64 a + if Archi.ptr64 then expand_builtin_va_start_elf64 a else expand_builtin_va_start_32 a (* Synchronization *) | "__builtin_membar", [], _ -> () - (* no operation *) + (* No operation *) | "__builtin_nop", [], _ -> emit Pnop + (* Optimization hint *) + | "__builtin_unreachable", [], _ -> + () (* Catch-all *) | _ -> raise (Error ("unrecognized builtin " ^ name)) -(* Calls to variadic functions for x86-64: register AL must contain +(* Calls to variadic functions for x86-64 ELF: register AL must contain the number of XMM registers used for parameter passing. To be on - the safe side. do the same if the called function is + the safe side, do the same if the called function is unprototyped. *) -let set_al sg = - if Archi.ptr64 && (sg.sig_cc.cc_vararg || sg.sig_cc.cc_unproto) then begin +let fixup_funcall_elf64 sg = + if sg.sig_cc.cc_vararg <> None || sg.sig_cc.cc_unproto then begin let (ir, fr, ofs) = next_arg_locations 0 0 0 sg.sig_args in emit (Pmovl_ri (RAX, coqint_of_camlint (Int32.of_int fr))) end +(* Calls to variadic functions for x86-64 Windows: + FP arguments passed in FP registers must also be passed in integer + registers. +*) + +let copy_fregs_to_iregs args fr ir = + () + +let fixup_funcall_win64 sg = + if sg.sig_cc.cc_vararg <> None then + copy_fregs_to_iregs sg.sig_args [XMM0; XMM1; XMM2; XMM3] [RCX; RDX; R8; R9] + +let fixup_funcall sg = + if Archi.ptr64 then + fixup_funcall_elf64 sg + else () + (* Expansion of instructions *) let expand_instruction instr = match instr with | Pallocframe (sz, ofs_ra, ofs_link) -> - if Archi.ptr64 then begin - let (sz, save_regs) = sp_adjustment_64 sz in + if Archi.ptr64 then begin + let (sz, save_regs) = sp_adjustment_elf64 sz in (* Allocate frame *) let sz' = Z.of_uint sz in emit (Psubq_ri (RSP, sz')); emit (Pcfi_adjust sz'); if save_regs >= 0 then begin (* Save the registers *) - emit (Pleaq (R10, linear_addr RSP (Z.of_uint save_regs))); + emit_leaq R10 (linear_addr RSP (Z.of_uint save_regs)); emit (Pcall_s (intern_string "__compcert_va_saveregs", {sig_args = []; sig_res = Tvoid; sig_cc = cc_default})) end; @@ -508,7 +555,7 @@ let expand_instruction instr = let fullsz = sz + 8 in let addr1 = linear_addr RSP (Z.of_uint fullsz) in let addr2 = linear_addr RSP ofs_link in - emit (Pleaq (RAX, addr1)); + emit_leaq RAX addr1; emit (Pmovq_mr (addr2, RAX)); current_function_stacksize := Int64.of_int fullsz end else begin @@ -525,15 +572,15 @@ let expand_instruction instr = PrintAsmaux.current_function_stacksize := Int32.of_int sz end | Pfreeframe(sz, ofs_ra, ofs_link) -> - if Archi.ptr64 then begin - let (sz, _) = sp_adjustment_64 sz in + if Archi.ptr64 then begin + let (sz, _) = sp_adjustment_elf64 sz in emit (Paddq_ri (RSP, Z.of_uint sz)) end else begin let sz = sp_adjustment_32 sz in emit (Paddl_ri (RSP, Z.of_uint sz)) end | Pjmp_s(_, sg) | Pjmp_r(_, sg) | Pcall_s(_, sg) | Pcall_r(_, sg) -> - set_al sg; + fixup_funcall sg; emit instr | Pbuiltin (ef,args, res) -> begin diff --git a/verilog/Asmgenproof.v b/verilog/Asmgenproof.v index f1fd41e3..67c42b2b 100644 --- a/verilog/Asmgenproof.v +++ b/verilog/Asmgenproof.v @@ -67,7 +67,7 @@ Lemma transf_function_no_overflow: transf_function f = OK tf -> list_length_z (fn_code tf) <= Ptrofs.max_unsigned. Proof. intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z (fn_code x))); monadInv EQ0. - omega. + lia. Qed. Lemma exec_straight_exec: @@ -332,8 +332,8 @@ Proof. split. unfold goto_label. rewrite P. rewrite H1. auto. split. rewrite Pregmap.gss. constructor; auto. rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. - auto. omega. - generalize (transf_function_no_overflow _ _ H0). omega. + auto. lia. + generalize (transf_function_no_overflow _ _ H0). lia. intros. apply Pregmap.gso; auto. Qed. @@ -852,7 +852,7 @@ Transparent destroyed_by_jumptable. econstructor; eauto. unfold nextinstr. rewrite Pregmap.gss. repeat rewrite Pregmap.gso; auto with asmgen. rewrite ATPC. simpl. constructor; eauto. - unfold fn_code. eapply code_tail_next_int. simpl in g. omega. + unfold fn_code. eapply code_tail_next_int. simpl in g. lia. constructor. apply agree_nextinstr. eapply agree_change_sp; eauto. Transparent destroyed_at_function_entry. @@ -877,7 +877,7 @@ Transparent destroyed_at_function_entry. - (* return *) inv STACKS. simpl in *. - right. split. omega. split. auto. + right. split. lia. split. auto. econstructor; eauto. rewrite ATPC; eauto. congruence. Qed. diff --git a/verilog/ConstpropOpproof.v b/verilog/ConstpropOpproof.v index 6d2df9c1..c0bdaa76 100644 --- a/verilog/ConstpropOpproof.v +++ b/verilog/ConstpropOpproof.v @@ -532,7 +532,7 @@ Proof. Int.bit_solve. destruct (zlt i0 n0). replace (Int.testbit n i0) with (negb (Int.testbit Int.zero i0)). rewrite Int.bits_zero. simpl. rewrite andb_true_r. auto. - rewrite <- EQ. rewrite Int.bits_zero_ext by omega. rewrite zlt_true by auto. + rewrite <- EQ. rewrite Int.bits_zero_ext by lia. rewrite zlt_true by auto. rewrite Int.bits_not by auto. apply negb_involutive. rewrite H6 by auto. auto. econstructor; split; eauto. auto. diff --git a/verilog/Conventions1.v b/verilog/Conventions1.v index fdd94239..592acd72 100644 --- a/verilog/Conventions1.v +++ b/verilog/Conventions1.v @@ -248,14 +248,14 @@ Remark loc_arguments_32_charact: In p (loc_arguments_32 tyl ofs) -> forall_rpair (loc_argument_32_charact ofs) p. Proof. assert (X: forall ofs1 ofs2 l, loc_argument_32_charact ofs2 l -> ofs1 <= ofs2 -> loc_argument_32_charact ofs1 l). - { destruct l; simpl; intros; auto. destruct sl; auto. intuition omega. } + { destruct l; simpl; intros; auto. destruct sl; auto. intuition lia. } induction tyl as [ | ty tyl]; simpl loc_arguments_32; intros. - contradiction. - destruct H. -+ destruct ty; subst p; simpl; omega. ++ destruct ty; subst p; simpl; lia. + apply IHtyl in H. generalize (typesize_pos ty); intros. destruct p; simpl in *. -* eapply X; eauto; omega. -* destruct H; split; eapply X; eauto; omega. +* eapply X; eauto; lia. +* destruct H; split; eapply X; eauto; lia. Qed. Remark loc_arguments_64_charact: @@ -263,7 +263,7 @@ Remark loc_arguments_64_charact: In p (loc_arguments_64 tyl ir fr ofs) -> (2 | ofs) -> forall_rpair (loc_argument_64_charact ofs) p. Proof. assert (X: forall ofs1 ofs2 l, loc_argument_64_charact ofs2 l -> ofs1 <= ofs2 -> loc_argument_64_charact ofs1 l). - { destruct l; simpl; intros; auto. destruct sl; auto. intuition omega. } + { destruct l; simpl; intros; auto. destruct sl; auto. intuition lia. } assert (Y: forall ofs1 ofs2 p, forall_rpair (loc_argument_64_charact ofs2) p -> ofs1 <= ofs2 -> forall_rpair (loc_argument_64_charact ofs1) p). { destruct p; simpl; intuition eauto. } assert (Z: forall ofs, (2 | ofs) -> (2 | ofs + 2)). @@ -280,8 +280,8 @@ Opaque list_nth_z. { intros. destruct (list_nth_z int_param_regs ir) as [r|] eqn:E; destruct H1. subst. left. eapply list_nth_z_in; eauto. eapply IHtyl; eauto. - subst. split. omega. assumption. - eapply Y; eauto. omega. } + subst. split. lia. assumption. + eapply Y; eauto. lia. } assert (B: forall ty, In p match list_nth_z float_param_regs fr with | Some ireg => One (R ireg) :: loc_arguments_64 tyl ir (fr + 1) ofs @@ -291,8 +291,8 @@ Opaque list_nth_z. { intros. destruct (list_nth_z float_param_regs fr) as [r|] eqn:E; destruct H1. subst. right. eapply list_nth_z_in; eauto. eapply IHtyl; eauto. - subst. split. omega. assumption. - eapply Y; eauto. omega. } + subst. split. lia. assumption. + eapply Y; eauto. lia. } destruct a; eauto. Qed. @@ -340,3 +340,8 @@ Definition return_value_needs_normalization (t: rettype) : bool := | Tint8signed | Tint8unsigned | Tint16signed | Tint16unsigned => true | _ => false end. + +(** Function parameters are passed in normalized form and do not need + to be re-normalized at function entry. *) + +Definition parameter_needs_normalization (t: rettype) := false. diff --git a/verilog/NeedOp.v b/verilog/NeedOp.v index d9a58fbb..775a23db 100644 --- a/verilog/NeedOp.v +++ b/verilog/NeedOp.v @@ -206,9 +206,9 @@ Proof. unfold needs_of_operation; intros; destruct op; try (eapply default_needs_of_operation_sound; eauto; fail); simpl in *; FuncInv; InvAgree; TrivialExists. - apply sign_ext_sound; auto. compute; auto. -- apply zero_ext_sound; auto. omega. +- apply zero_ext_sound; auto. lia. - apply sign_ext_sound; auto. compute; auto. -- apply zero_ext_sound; auto. omega. +- apply zero_ext_sound; auto. lia. - apply neg_sound; auto. - apply mul_sound; auto. - apply mul_sound; auto with na. @@ -246,10 +246,10 @@ Lemma operation_is_redundant_sound: vagree v arg1' nv. Proof. intros. destruct op; simpl in *; try discriminate; inv H1; FuncInv; subst. -- apply sign_ext_redundant_sound; auto. omega. -- apply zero_ext_redundant_sound; auto. omega. -- apply sign_ext_redundant_sound; auto. omega. -- apply zero_ext_redundant_sound; auto. omega. +- apply sign_ext_redundant_sound; auto. lia. +- apply zero_ext_redundant_sound; auto. lia. +- apply sign_ext_redundant_sound; auto. lia. +- apply zero_ext_redundant_sound; auto. lia. - apply andimm_redundant_sound; auto. - apply orimm_redundant_sound; auto. Qed. diff --git a/verilog/SelectOpproof.v b/verilog/SelectOpproof.v index 961f602c..d8ab32a4 100644 --- a/verilog/SelectOpproof.v +++ b/verilog/SelectOpproof.v @@ -381,9 +381,9 @@ Proof. - TrivialExists. simpl. rewrite Int.and_commut; auto. - TrivialExists. simpl. rewrite Val.and_assoc. rewrite Int.and_commut. auto. - rewrite Val.zero_ext_and. TrivialExists. rewrite Val.and_assoc. - rewrite Int.and_commut. auto. omega. + rewrite Int.and_commut. auto. lia. - rewrite Val.zero_ext_and. TrivialExists. rewrite Val.and_assoc. - rewrite Int.and_commut. auto. omega. + rewrite Int.and_commut. auto. lia. - TrivialExists. Qed. @@ -743,7 +743,7 @@ Proof. red; intros until x. unfold cast8unsigned. destruct (cast8unsigned_match a); intros; InvEval. TrivialExists. subst. rewrite Val.zero_ext_and. rewrite Val.and_assoc. - rewrite Int.and_commut. apply eval_andimm; auto. omega. + rewrite Int.and_commut. apply eval_andimm; auto. lia. TrivialExists. Qed. @@ -759,7 +759,7 @@ Proof. red; intros until x. unfold cast16unsigned. destruct (cast16unsigned_match a); intros; InvEval. TrivialExists. subst. rewrite Val.zero_ext_and. rewrite Val.and_assoc. - rewrite Int.and_commut. apply eval_andimm; auto. omega. + rewrite Int.and_commut. apply eval_andimm; auto. lia. TrivialExists. Qed. @@ -860,7 +860,7 @@ Proof. simpl. rewrite Heqo; reflexivity. simpl. unfold Int64.loword. rewrite Int64.unsigned_repr, Int.repr_unsigned; auto. assert (Int.modulus < Int64.max_unsigned) by reflexivity. - generalize (Int.unsigned_range n); omega. + generalize (Int.unsigned_range n); lia. Qed. Theorem eval_floatofintu: diff --git a/verilog/Stacklayout.v b/verilog/Stacklayout.v index d375febf..de2a6f10 100644 --- a/verilog/Stacklayout.v +++ b/verilog/Stacklayout.v @@ -67,15 +67,15 @@ Local Opaque Z.add Z.mul sepconj range. set (ostkdata := align (ol + 4 * b.(bound_local)) 8). set (oretaddr := align (ostkdata + b.(bound_stack_data)) w). replace (size_chunk Mptr) with w by (rewrite size_chunk_Mptr; auto). - assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). + assert (0 < w) by (unfold w; destruct Archi.ptr64; lia). generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros. - assert (0 <= 4 * b.(bound_outgoing)) by omega. - assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; omega). - assert (olink + w <= ocs) by (unfold ocs; omega). + assert (0 <= 4 * b.(bound_outgoing)) by lia. + assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; lia). + assert (olink + w <= ocs) by (unfold ocs; lia). assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr). - assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega). - assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega). - assert (ostkdata + bound_stack_data b <= oretaddr) by (apply align_le; omega). + assert (size_callee_save_area b ocs <= ol) by (apply align_le; lia). + assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; lia). + assert (ostkdata + bound_stack_data b <= oretaddr) by (apply align_le; lia). (* Reorder as: outgoing back link @@ -88,12 +88,12 @@ Local Opaque Z.add Z.mul sepconj range. rewrite sep_swap34. (* Apply range_split and range_split2 repeatedly *) unfold fe_ofs_arg. - apply range_split_2. fold olink. omega. omega. - apply range_split. omega. - apply range_split_2. fold ol. omega. omega. - apply range_drop_right with ostkdata. omega. + apply range_split_2. fold olink. lia. lia. + apply range_split. lia. + apply range_split_2. fold ol. lia. lia. + apply range_drop_right with ostkdata. lia. rewrite sep_swap. - apply range_drop_left with (ostkdata + bound_stack_data b). omega. + apply range_drop_left with (ostkdata + bound_stack_data b). lia. rewrite sep_swap. exact H. Qed. @@ -110,16 +110,16 @@ Proof. set (ol := align (size_callee_save_area b ocs) 8). set (ostkdata := align (ol + 4 * b.(bound_local)) 8). set (oretaddr := align (ostkdata + b.(bound_stack_data)) w). - assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). + assert (0 < w) by (unfold w; destruct Archi.ptr64; lia). generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros. - assert (0 <= 4 * b.(bound_outgoing)) by omega. - assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; omega). - assert (olink + w <= ocs) by (unfold ocs; omega). + assert (0 <= 4 * b.(bound_outgoing)) by lia. + assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; lia). + assert (olink + w <= ocs) by (unfold ocs; lia). assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr). - assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega). - assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega). - assert (ostkdata + bound_stack_data b <= oretaddr) by (apply align_le; omega). - split. omega. omega. + assert (size_callee_save_area b ocs <= ol) by (apply align_le; lia). + assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; lia). + assert (ostkdata + bound_stack_data b <= oretaddr) by (apply align_le; lia). + split. lia. lia. Qed. Lemma frame_env_aligned: @@ -138,11 +138,11 @@ Proof. set (ol := align (size_callee_save_area b ocs) 8). set (ostkdata := align (ol + 4 * b.(bound_local)) 8). set (oretaddr := align (ostkdata + b.(bound_stack_data)) w). - assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). + assert (0 < w) by (unfold w; destruct Archi.ptr64; lia). replace (align_chunk Mptr) with w by (rewrite align_chunk_Mptr; auto). split. apply Z.divide_0_r. - split. apply align_divides; omega. - split. apply align_divides; omega. - split. apply align_divides; omega. - apply align_divides; omega. + split. apply align_divides; lia. + split. apply align_divides; lia. + split. apply align_divides; lia. + apply align_divides; lia. Qed. diff --git a/verilog/TargetPrinter.ml b/verilog/TargetPrinter.ml index f0a54506..8950b8ca 100644 --- a/verilog/TargetPrinter.ml +++ b/verilog/TargetPrinter.ml @@ -131,25 +131,7 @@ module ELF_System : SYSTEM = let label = elf_label - let name_of_section = function - | Section_text -> ".text" - | Section_data i | Section_small_data i -> - if i then ".data" else common_section () - | Section_const i | Section_small_const i -> - if i || (not !Clflags.option_fcommon) then ".section .rodata" else "COMM" - | Section_string -> ".section .rodata" - | Section_literal -> ".section .rodata.cst8,\"aM\",@progbits,8" - | Section_jumptable -> ".text" - | Section_user(s, wr, ex) -> - sprintf ".section \"%s\",\"a%s%s\",@progbits" - s (if wr then "w" else "") (if ex then "x" else "") - | Section_debug_info _ -> ".section .debug_info,\"\",@progbits" - | Section_debug_loc -> ".section .debug_loc,\"\",@progbits" - | Section_debug_line _ -> ".section .debug_line,\"\",@progbits" - | Section_debug_abbrev -> ".section .debug_abbrev,\"\",@progbits" - | Section_debug_ranges -> ".section .debug_ranges,\"\",@progbits" - | Section_debug_str -> ".section .debug_str,\"MS\",@progbits,1" - | Section_ais_annotation -> sprintf ".section \"__compcert_ais_annotations\",\"\",@note" + let name_of_section = fun _ -> assert false let stack_alignment = 16 @@ -189,26 +171,7 @@ module MacOS_System : SYSTEM = let label oc lbl = fprintf oc "L%d" lbl - let name_of_section = function - | Section_text -> ".text" - | Section_data i | Section_small_data i -> - if i || (not !Clflags.option_fcommon) then ".data" else "COMM" - | Section_const i | Section_small_const i -> - if i || (not !Clflags.option_fcommon) then ".const" else "COMM" - | Section_string -> ".const" - | Section_literal -> ".literal8" - | Section_jumptable -> ".text" - | Section_user(s, wr, ex) -> - sprintf ".section \"%s\", %s, %s" - (if wr then "__DATA" else "__TEXT") s - (if ex then "regular, pure_instructions" else "regular") - | Section_debug_info _ -> ".section __DWARF,__debug_info,regular,debug" - | Section_debug_loc -> ".section __DWARF,__debug_loc,regular,debug" - | Section_debug_line _ -> ".section __DWARF,__debug_line,regular,debug" - | Section_debug_str -> ".section __DWARF,__debug_str,regular,debug" - | Section_debug_ranges -> ".section __DWARF,__debug_ranges,regular,debug" - | Section_debug_abbrev -> ".section __DWARF,__debug_abbrev,regular,debug" - | Section_ais_annotation -> assert false (* Not supported under MacOS *) + let name_of_section = fun _ -> assert false let stack_alignment = 16 (* mandatory *) @@ -248,25 +211,7 @@ module Cygwin_System : SYSTEM = let label oc lbl = fprintf oc "L%d" lbl - let name_of_section = function - | Section_text -> ".text" - | Section_data i | Section_small_data i -> - if i then ".data" else common_section () - | Section_const i | Section_small_const i -> - if i || (not !Clflags.option_fcommon) then ".section .rdata,\"dr\"" else "COMM" - | Section_string -> ".section .rdata,\"dr\"" - | Section_literal -> ".section .rdata,\"dr\"" - | Section_jumptable -> ".text" - | Section_user(s, wr, ex) -> - sprintf ".section %s, \"%s\"\n" - s (if ex then "xr" else if wr then "d" else "dr") - | Section_debug_info _ -> ".section .debug_info,\"dr\"" - | Section_debug_loc -> ".section .debug_loc,\"dr\"" - | Section_debug_line _ -> ".section .debug_line,\"dr\"" - | Section_debug_abbrev -> ".section .debug_abbrev,\"dr\"" - | Section_debug_ranges -> ".section .debug_ranges,\"dr\"" - | Section_debug_str-> assert false (* Should not be used *) - | Section_ais_annotation -> assert false (* Not supported for coff binaries *) + let name_of_section = fun _ -> assert false let stack_alignment = 8 (* minimum is 4, 8 is better for perfs *) @@ -887,24 +832,7 @@ module Target(System: SYSTEM):TARGET = end let print_epilogue oc = - if !need_masks then begin - section oc (Section_const true); - (* not Section_literal because not 8-bytes *) - print_align oc 16; - fprintf oc "%a: .quad 0x8000000000000000, 0\n" - raw_symbol "__negd_mask"; - fprintf oc "%a: .quad 0x7FFFFFFFFFFFFFFF, 0xFFFFFFFFFFFFFFFF\n" - raw_symbol "__absd_mask"; - fprintf oc "%a: .long 0x80000000, 0, 0, 0\n" - raw_symbol "__negs_mask"; - fprintf oc "%a: .long 0x7FFFFFFF, 0xFFFFFFFF, 0xFFFFFFFF, 0xFFFFFFFF\n" - raw_symbol "__abss_mask" - end; - System.print_epilogue oc; - if !Clflags.option_g then begin - Debug.compute_gnu_file_enum (fun f -> ignore (print_file oc f)); - section oc Section_text; - end + assert false let comment = comment @@ -1193,7 +1193,7 @@ Ltac Equalities := split. auto. intros. destruct B; auto. subst. auto. - (* trace length *) red; intros; inv H; simpl. - omega. + lia. eapply external_call_trace_length; eauto. eapply external_call_trace_length; eauto. - (* initial states *) diff --git a/x86/Asmexpand.ml b/x86/Asmexpand.ml index 73efc3c5..a1c24f2d 100644 --- a/x86/Asmexpand.ml +++ b/x86/Asmexpand.ml @@ -39,11 +39,6 @@ let _16z = Z.of_sint 16 let stack_alignment () = 16 -(* Pseudo instructions for 32/64 bit compatibility *) - -let _Plea (r, addr) = - if Archi.ptr64 then Pleaq (r, addr) else Pleal (r, addr) - (* SP adjustment to allocate or free a stack frame. *) let align n a = @@ -109,6 +104,21 @@ let offset_addressing (Addrmode(base, ofs, cst)) delta = let linear_addr reg ofs = Addrmode(Some reg, None, Coq_inl ofs) let global_addr id ofs = Addrmode(None, None, Coq_inr(id, ofs)) +(* A "leaq" instruction that does not overflow *) + +let emit_leaq r addr = + match Asmgen.normalize_addrmode_64 addr with + | (addr, None) -> + emit (Pleaq (r, addr)) + | (addr, Some delta) -> + emit (Pleaq (r, addr)); + emit (Paddq_ri (r, delta)) + +(* Pseudo "lea" instruction for 32/64 bit compatibility *) + +let emit_lea r addr = + if Archi.ptr64 then emit_leaq r addr else emit (Pleal (r, addr)) + (* Translate a builtin argument into an addressing mode *) let addressing_of_builtin_arg = function @@ -150,8 +160,8 @@ let expand_builtin_memcpy_small sz al src dst = copy (addressing_of_builtin_arg src) (addressing_of_builtin_arg dst) sz let expand_builtin_memcpy_big sz al src dst = - if src <> BA (IR RSI) then emit (_Plea (RSI, addressing_of_builtin_arg src)); - if dst <> BA (IR RDI) then emit (_Plea (RDI, addressing_of_builtin_arg dst)); + if src <> BA (IR RSI) then emit_lea RSI (addressing_of_builtin_arg src); + if dst <> BA (IR RDI) then emit_lea RDI (addressing_of_builtin_arg dst); (* TODO: movsq? *) emit (Pmovl_ri (RCX,coqint_of_camlint (Int32.of_int (sz / 4)))); emit Prep_movsl; @@ -289,9 +299,9 @@ let expand_builtin_va_start_elf64 r = emit (Pmovl_mr (linear_addr r _0z, RAX)); emit (Pmovl_ri (RAX, coqint_of_camlint fp_offset)); emit (Pmovl_mr (linear_addr r _4z, RAX)); - emit (Pleaq (RAX, linear_addr RSP (Z.of_uint64 overflow_arg_area))); + emit_leaq RAX (linear_addr RSP (Z.of_uint64 overflow_arg_area)); emit (Pmovq_mr (linear_addr r _8z, RAX)); - emit (Pleaq (RAX, linear_addr RSP (Z.of_uint64 reg_save_area))); + emit_leaq RAX (linear_addr RSP (Z.of_uint64 reg_save_area)); emit (Pmovq_mr (linear_addr r _16z, RAX)) let expand_builtin_va_start_win64 r = @@ -302,7 +312,7 @@ let expand_builtin_va_start_win64 r = let ofs = Int64.(add !current_function_stacksize (mul 8L (of_int num_args))) in - emit (Pleaq (RAX, linear_addr RSP (Z.of_uint64 ofs))); + emit_leaq RAX (linear_addr RSP (Z.of_uint64 ofs)); emit (Pmovq_mr (linear_addr r _0z, RAX)) (* FMA operations *) @@ -487,9 +497,12 @@ let expand_builtin_inline name args res = (* Synchronization *) | "__builtin_membar", [], _ -> () - (* no operation *) + (* No operation *) | "__builtin_nop", [], _ -> emit Pnop + (* Optimization hint *) + | "__builtin_unreachable", [], _ -> + () (* Catch-all *) | _ -> raise (Error ("unrecognized builtin " ^ name)) @@ -500,7 +513,7 @@ let expand_builtin_inline name args res = unprototyped. *) let fixup_funcall_elf64 sg = - if sg.sig_cc.cc_vararg || sg.sig_cc.cc_unproto then begin + if sg.sig_cc.cc_vararg <> None || sg.sig_cc.cc_unproto then begin let (ir, fr, ofs) = next_arg_locations 0 0 0 sg.sig_args in emit (Pmovl_ri (RAX, coqint_of_camlint (Int32.of_int fr))) end @@ -521,7 +534,7 @@ let rec copy_fregs_to_iregs args fr ir = () let fixup_funcall_win64 sg = - if sg.sig_cc.cc_vararg then + if sg.sig_cc.cc_vararg <> None then copy_fregs_to_iregs sg.sig_args [XMM0; XMM1; XMM2; XMM3] [RCX; RDX; R8; R9] let fixup_funcall sg = @@ -549,7 +562,7 @@ let expand_instruction instr = (* Stack chaining *) let addr1 = linear_addr RSP (Z.of_uint (sz + 8)) in let addr2 = linear_addr RSP ofs_link in - emit (Pleaq (RAX,addr1)); + emit_leaq RAX addr1; emit (Pmovq_mr (addr2, RAX)); current_function_stacksize := Int64.of_int (sz + 8) end else if Archi.ptr64 then begin @@ -560,7 +573,7 @@ let expand_instruction instr = emit (Pcfi_adjust sz'); if save_regs >= 0 then begin (* Save the registers *) - emit (Pleaq (R10, linear_addr RSP (Z.of_uint save_regs))); + emit_leaq R10 (linear_addr RSP (Z.of_uint save_regs)); emit (Pcall_s (intern_string "__compcert_va_saveregs", {sig_args = []; sig_res = Tvoid; sig_cc = cc_default})) end; @@ -568,7 +581,7 @@ let expand_instruction instr = let fullsz = sz + 8 in let addr1 = linear_addr RSP (Z.of_uint fullsz) in let addr2 = linear_addr RSP ofs_link in - emit (Pleaq (RAX, addr1)); + emit_leaq RAX addr1; emit (Pmovq_mr (addr2, RAX)); current_function_stacksize := Int64.of_int fullsz end else begin diff --git a/x86/Asmgenproof.v b/x86/Asmgenproof.v index f1fd41e3..67c42b2b 100644 --- a/x86/Asmgenproof.v +++ b/x86/Asmgenproof.v @@ -67,7 +67,7 @@ Lemma transf_function_no_overflow: transf_function f = OK tf -> list_length_z (fn_code tf) <= Ptrofs.max_unsigned. Proof. intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z (fn_code x))); monadInv EQ0. - omega. + lia. Qed. Lemma exec_straight_exec: @@ -332,8 +332,8 @@ Proof. split. unfold goto_label. rewrite P. rewrite H1. auto. split. rewrite Pregmap.gss. constructor; auto. rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. - auto. omega. - generalize (transf_function_no_overflow _ _ H0). omega. + auto. lia. + generalize (transf_function_no_overflow _ _ H0). lia. intros. apply Pregmap.gso; auto. Qed. @@ -852,7 +852,7 @@ Transparent destroyed_by_jumptable. econstructor; eauto. unfold nextinstr. rewrite Pregmap.gss. repeat rewrite Pregmap.gso; auto with asmgen. rewrite ATPC. simpl. constructor; eauto. - unfold fn_code. eapply code_tail_next_int. simpl in g. omega. + unfold fn_code. eapply code_tail_next_int. simpl in g. lia. constructor. apply agree_nextinstr. eapply agree_change_sp; eauto. Transparent destroyed_at_function_entry. @@ -877,7 +877,7 @@ Transparent destroyed_at_function_entry. - (* return *) inv STACKS. simpl in *. - right. split. omega. split. auto. + right. split. lia. split. auto. econstructor; eauto. rewrite ATPC; eauto. congruence. Qed. diff --git a/x86/Builtins1.v b/x86/Builtins1.v index f1d60961..e5233ff5 100644 --- a/x86/Builtins1.v +++ b/x86/Builtins1.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/x86/CBuiltins.ml b/x86/CBuiltins.ml index a16f3ef7..a549cd25 100644 --- a/x86/CBuiltins.ml +++ b/x86/CBuiltins.ml @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/x86/ConstpropOpproof.v b/x86/ConstpropOpproof.v index 82179fa4..09c6e91b 100644 --- a/x86/ConstpropOpproof.v +++ b/x86/ConstpropOpproof.v @@ -532,7 +532,7 @@ Proof. Int.bit_solve. destruct (zlt i0 n0). replace (Int.testbit n i0) with (negb (Int.testbit Int.zero i0)). rewrite Int.bits_zero. simpl. rewrite andb_true_r. auto. - rewrite <- EQ. rewrite Int.bits_zero_ext by omega. rewrite zlt_true by auto. + rewrite <- EQ. rewrite Int.bits_zero_ext by lia. rewrite zlt_true by auto. rewrite Int.bits_not by auto. apply negb_involutive. rewrite H6 by auto. auto. econstructor; split; eauto. auto. diff --git a/x86/Conventions1.v b/x86/Conventions1.v index 645aae90..a4e3b970 100644 --- a/x86/Conventions1.v +++ b/x86/Conventions1.v @@ -302,14 +302,14 @@ Remark loc_arguments_32_charact: In p (loc_arguments_32 tyl ofs) -> forall_rpair (loc_argument_32_charact ofs) p. Proof. assert (X: forall ofs1 ofs2 l, loc_argument_32_charact ofs2 l -> ofs1 <= ofs2 -> loc_argument_32_charact ofs1 l). - { destruct l; simpl; intros; auto. destruct sl; auto. intuition omega. } + { destruct l; simpl; intros; auto. destruct sl; auto. intuition lia. } induction tyl as [ | ty tyl]; simpl loc_arguments_32; intros. - contradiction. - destruct H. -+ destruct ty; subst p; simpl; omega. ++ destruct ty; subst p; simpl; lia. + apply IHtyl in H. generalize (typesize_pos ty); intros. destruct p; simpl in *. -* eapply X; eauto; omega. -* destruct H; split; eapply X; eauto; omega. +* eapply X; eauto; lia. +* destruct H; split; eapply X; eauto; lia. Qed. Remark loc_arguments_elf64_charact: @@ -317,7 +317,7 @@ Remark loc_arguments_elf64_charact: In p (loc_arguments_elf64 tyl ir fr ofs) -> (2 | ofs) -> forall_rpair (loc_argument_elf64_charact ofs) p. Proof. assert (X: forall ofs1 ofs2 l, loc_argument_elf64_charact ofs2 l -> ofs1 <= ofs2 -> loc_argument_elf64_charact ofs1 l). - { destruct l; simpl; intros; auto. destruct sl; auto. intuition omega. } + { destruct l; simpl; intros; auto. destruct sl; auto. intuition lia. } assert (Y: forall ofs1 ofs2 p, forall_rpair (loc_argument_elf64_charact ofs2) p -> ofs1 <= ofs2 -> forall_rpair (loc_argument_elf64_charact ofs1) p). { destruct p; simpl; intuition eauto. } assert (Z: forall ofs, (2 | ofs) -> (2 | ofs + 2)). @@ -334,8 +334,8 @@ Opaque list_nth_z. { intros. destruct (list_nth_z int_param_regs_elf64 ir) as [r|] eqn:E; destruct H1. subst. left. eapply list_nth_z_in; eauto. eapply IHtyl; eauto. - subst. split. omega. assumption. - eapply Y; eauto. omega. } + subst. split. lia. assumption. + eapply Y; eauto. lia. } assert (B: forall ty, In p match list_nth_z float_param_regs_elf64 fr with | Some ireg => One (R ireg) :: loc_arguments_elf64 tyl ir (fr + 1) ofs @@ -345,8 +345,8 @@ Opaque list_nth_z. { intros. destruct (list_nth_z float_param_regs_elf64 fr) as [r|] eqn:E; destruct H1. subst. right. eapply list_nth_z_in; eauto. eapply IHtyl; eauto. - subst. split. omega. assumption. - eapply Y; eauto. omega. } + subst. split. lia. assumption. + eapply Y; eauto. lia. } destruct a; eauto. Qed. @@ -355,7 +355,7 @@ Remark loc_arguments_win64_charact: In p (loc_arguments_win64 tyl r ofs) -> (2 | ofs) -> forall_rpair (loc_argument_win64_charact ofs) p. Proof. assert (X: forall ofs1 ofs2 l, loc_argument_win64_charact ofs2 l -> ofs1 <= ofs2 -> loc_argument_win64_charact ofs1 l). - { destruct l; simpl; intros; auto. destruct sl; auto. intuition omega. } + { destruct l; simpl; intros; auto. destruct sl; auto. intuition lia. } assert (Y: forall ofs1 ofs2 p, forall_rpair (loc_argument_win64_charact ofs2) p -> ofs1 <= ofs2 -> forall_rpair (loc_argument_win64_charact ofs1) p). { destruct p; simpl; intuition eauto. } assert (Z: forall ofs, (2 | ofs) -> (2 | ofs + 2)). @@ -372,8 +372,8 @@ Opaque list_nth_z. { intros. destruct (list_nth_z int_param_regs_win64 r) as [r'|] eqn:E; destruct H1. subst. left. eapply list_nth_z_in; eauto. eapply IHtyl; eauto. - subst. split. omega. assumption. - eapply Y; eauto. omega. } + subst. split. lia. assumption. + eapply Y; eauto. lia. } assert (B: forall ty, In p match list_nth_z float_param_regs_win64 r with | Some ireg => One (R ireg) :: loc_arguments_win64 tyl (r + 1) ofs @@ -383,8 +383,8 @@ Opaque list_nth_z. { intros. destruct (list_nth_z float_param_regs_win64 r) as [r'|] eqn:E; destruct H1. subst. right. eapply list_nth_z_in; eauto. eapply IHtyl; eauto. - subst. split. omega. assumption. - eapply Y; eauto. omega. } + subst. split. lia. assumption. + eapply Y; eauto. lia. } destruct a; eauto. Qed. @@ -423,7 +423,7 @@ Proof. unfold forall_rpair; destruct p; intuition auto. Qed. -Hint Resolve loc_arguments_acceptable: locs. +Global Hint Resolve loc_arguments_acceptable: locs. Lemma loc_arguments_main: loc_arguments signature_main = nil. @@ -431,7 +431,7 @@ Proof. unfold loc_arguments; destruct Archi.ptr64; auto; destruct Archi.win64; auto. Qed. -(** ** Normalization of function results *) +(** ** Normalization of function results and parameters *) (** In the x86 ABI, a return value of type "char" is returned in register AL, leaving the top 24 bits of EAX unspecified. @@ -444,3 +444,8 @@ Definition return_value_needs_normalization (t: rettype) : bool := | Tint8signed | Tint8unsigned | Tint16signed | Tint16unsigned => true | _ => false end. + +(** Function parameters are passed in normalized form and do not need + to be re-normalized at function entry. *) + +Definition parameter_needs_normalization (t: rettype) := false. diff --git a/x86/NeedOp.v b/x86/NeedOp.v index d9a58fbb..775a23db 100644 --- a/x86/NeedOp.v +++ b/x86/NeedOp.v @@ -206,9 +206,9 @@ Proof. unfold needs_of_operation; intros; destruct op; try (eapply default_needs_of_operation_sound; eauto; fail); simpl in *; FuncInv; InvAgree; TrivialExists. - apply sign_ext_sound; auto. compute; auto. -- apply zero_ext_sound; auto. omega. +- apply zero_ext_sound; auto. lia. - apply sign_ext_sound; auto. compute; auto. -- apply zero_ext_sound; auto. omega. +- apply zero_ext_sound; auto. lia. - apply neg_sound; auto. - apply mul_sound; auto. - apply mul_sound; auto with na. @@ -246,10 +246,10 @@ Lemma operation_is_redundant_sound: vagree v arg1' nv. Proof. intros. destruct op; simpl in *; try discriminate; inv H1; FuncInv; subst. -- apply sign_ext_redundant_sound; auto. omega. -- apply zero_ext_redundant_sound; auto. omega. -- apply sign_ext_redundant_sound; auto. omega. -- apply zero_ext_redundant_sound; auto. omega. +- apply sign_ext_redundant_sound; auto. lia. +- apply zero_ext_redundant_sound; auto. lia. +- apply sign_ext_redundant_sound; auto. lia. +- apply zero_ext_redundant_sound; auto. lia. - apply andimm_redundant_sound; auto. - apply orimm_redundant_sound; auto. Qed. diff --git a/x86/SelectOpproof.v b/x86/SelectOpproof.v index 961f602c..d8ab32a4 100644 --- a/x86/SelectOpproof.v +++ b/x86/SelectOpproof.v @@ -381,9 +381,9 @@ Proof. - TrivialExists. simpl. rewrite Int.and_commut; auto. - TrivialExists. simpl. rewrite Val.and_assoc. rewrite Int.and_commut. auto. - rewrite Val.zero_ext_and. TrivialExists. rewrite Val.and_assoc. - rewrite Int.and_commut. auto. omega. + rewrite Int.and_commut. auto. lia. - rewrite Val.zero_ext_and. TrivialExists. rewrite Val.and_assoc. - rewrite Int.and_commut. auto. omega. + rewrite Int.and_commut. auto. lia. - TrivialExists. Qed. @@ -743,7 +743,7 @@ Proof. red; intros until x. unfold cast8unsigned. destruct (cast8unsigned_match a); intros; InvEval. TrivialExists. subst. rewrite Val.zero_ext_and. rewrite Val.and_assoc. - rewrite Int.and_commut. apply eval_andimm; auto. omega. + rewrite Int.and_commut. apply eval_andimm; auto. lia. TrivialExists. Qed. @@ -759,7 +759,7 @@ Proof. red; intros until x. unfold cast16unsigned. destruct (cast16unsigned_match a); intros; InvEval. TrivialExists. subst. rewrite Val.zero_ext_and. rewrite Val.and_assoc. - rewrite Int.and_commut. apply eval_andimm; auto. omega. + rewrite Int.and_commut. apply eval_andimm; auto. lia. TrivialExists. Qed. @@ -860,7 +860,7 @@ Proof. simpl. rewrite Heqo; reflexivity. simpl. unfold Int64.loword. rewrite Int64.unsigned_repr, Int.repr_unsigned; auto. assert (Int.modulus < Int64.max_unsigned) by reflexivity. - generalize (Int.unsigned_range n); omega. + generalize (Int.unsigned_range n); lia. Qed. Theorem eval_floatofintu: diff --git a/x86/Stacklayout.v b/x86/Stacklayout.v index 4f68cf26..002b86bf 100644 --- a/x86/Stacklayout.v +++ b/x86/Stacklayout.v @@ -69,16 +69,16 @@ Local Opaque Z.add Z.mul sepconj range. set (ostkdata := align (ol + 4 * b.(bound_local)) 8). set (oretaddr := align (ostkdata + b.(bound_stack_data)) w). replace (size_chunk Mptr) with w by (rewrite size_chunk_Mptr; auto). - assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). + assert (0 < w) by (unfold w; destruct Archi.ptr64; lia). generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros. - assert (0 <= fe_ofs_arg) by (unfold fe_ofs_arg; destruct Archi.win64; omega). - assert (0 <= 4 * b.(bound_outgoing)) by omega. - assert (fe_ofs_arg + 4 * b.(bound_outgoing) <= olink) by (apply align_le; omega). - assert (olink + w <= ocs) by (unfold ocs; omega). + assert (0 <= fe_ofs_arg) by (unfold fe_ofs_arg; destruct Archi.win64; lia). + assert (0 <= 4 * b.(bound_outgoing)) by lia. + assert (fe_ofs_arg + 4 * b.(bound_outgoing) <= olink) by (apply align_le; lia). + assert (olink + w <= ocs) by (unfold ocs; lia). assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr). - assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega). - assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega). - assert (ostkdata + bound_stack_data b <= oretaddr) by (apply align_le; omega). + assert (size_callee_save_area b ocs <= ol) by (apply align_le; lia). + assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; lia). + assert (ostkdata + bound_stack_data b <= oretaddr) by (apply align_le; lia). (* Reorder as: outgoing back link @@ -90,13 +90,13 @@ Local Opaque Z.add Z.mul sepconj range. rewrite sep_swap45. rewrite sep_swap34. (* Apply range_split and range_split2 repeatedly *) - apply range_drop_left with 0. omega. - apply range_split_2. fold olink. omega. omega. - apply range_split. omega. - apply range_split_2. fold ol. omega. omega. - apply range_drop_right with ostkdata. omega. + apply range_drop_left with 0. lia. + apply range_split_2. fold olink. lia. lia. + apply range_split. lia. + apply range_split_2. fold ol. lia. lia. + apply range_drop_right with ostkdata. lia. rewrite sep_swap. - apply range_drop_left with (ostkdata + bound_stack_data b). omega. + apply range_drop_left with (ostkdata + bound_stack_data b). lia. rewrite sep_swap. exact H. Qed. @@ -113,17 +113,17 @@ Proof. set (ol := align (size_callee_save_area b ocs) 8). set (ostkdata := align (ol + 4 * b.(bound_local)) 8). set (oretaddr := align (ostkdata + b.(bound_stack_data)) w). - assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). + assert (0 < w) by (unfold w; destruct Archi.ptr64; lia). generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros. - assert (0 <= fe_ofs_arg) by (unfold fe_ofs_arg; destruct Archi.win64; omega). - assert (0 <= 4 * b.(bound_outgoing)) by omega. - assert (fe_ofs_arg + 4 * b.(bound_outgoing) <= olink) by (apply align_le; omega). - assert (olink + w <= ocs) by (unfold ocs; omega). + assert (0 <= fe_ofs_arg) by (unfold fe_ofs_arg; destruct Archi.win64; lia). + assert (0 <= 4 * b.(bound_outgoing)) by lia. + assert (fe_ofs_arg + 4 * b.(bound_outgoing) <= olink) by (apply align_le; lia). + assert (olink + w <= ocs) by (unfold ocs; lia). assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr). - assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega). - assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega). - assert (ostkdata + bound_stack_data b <= oretaddr) by (apply align_le; omega). - split. omega. omega. + assert (size_callee_save_area b ocs <= ol) by (apply align_le; lia). + assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; lia). + assert (ostkdata + bound_stack_data b <= oretaddr) by (apply align_le; lia). + split. lia. lia. Qed. Lemma frame_env_aligned: @@ -142,11 +142,11 @@ Proof. set (ol := align (size_callee_save_area b ocs) 8). set (ostkdata := align (ol + 4 * b.(bound_local)) 8). set (oretaddr := align (ostkdata + b.(bound_stack_data)) w). - assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). + assert (0 < w) by (unfold w; destruct Archi.ptr64; lia). replace (align_chunk Mptr) with w by (rewrite align_chunk_Mptr; auto). split. exists (fe_ofs_arg / 8). unfold fe_ofs_arg; destruct Archi.win64; reflexivity. - split. apply align_divides; omega. - split. apply align_divides; omega. - split. apply align_divides; omega. - apply align_divides; omega. + split. apply align_divides; lia. + split. apply align_divides; lia. + split. apply align_divides; lia. + apply align_divides; lia. Qed. diff --git a/x86/TargetPrinter.ml b/x86/TargetPrinter.ml index 481b09b9..5bc2be1c 100644 --- a/x86/TargetPrinter.ml +++ b/x86/TargetPrinter.ml @@ -95,9 +95,6 @@ let z oc n = output_string oc (Z.to_string n) let data_pointer = if Archi.ptr64 then ".quad" else ".long" -(* The comment deliminiter *) -let comment = "#" - (* Base-2 log of a Caml integer *) let rec log2 n = assert (n > 0); @@ -106,6 +103,7 @@ let rec log2 n = (* System dependent printer functions *) module type SYSTEM = sig + val comment: string val raw_symbol: out_channel -> string -> unit val symbol: out_channel -> P.t -> unit val label: out_channel -> int -> unit @@ -124,6 +122,9 @@ module type SYSTEM = module ELF_System : SYSTEM = struct + (* The comment delimiter *) + let comment = "#" + let raw_symbol oc s = fprintf oc "%s" s @@ -134,9 +135,9 @@ module ELF_System : SYSTEM = let name_of_section = function | Section_text -> ".text" | Section_data i | Section_small_data i -> - if i then ".data" else common_section () + variable_section ~sec:".data" ~bss:".bss" i | Section_const i | Section_small_const i -> - if i || (not !Clflags.option_fcommon) then ".section .rodata" else "COMM" + variable_section ~sec:".section .rodata" i | Section_string -> ".section .rodata" | Section_literal -> ".section .rodata.cst8,\"aM\",@progbits,8" | Section_jumptable -> ".text" @@ -180,6 +181,10 @@ module ELF_System : SYSTEM = module MacOS_System : SYSTEM = struct + (* The comment delimiter. + `##` instead of `#` to please the Clang assembler. *) + let comment = "##" + let raw_symbol oc s = fprintf oc "_%s" s @@ -192,11 +197,11 @@ module MacOS_System : SYSTEM = let name_of_section = function | Section_text -> ".text" | Section_data i | Section_small_data i -> - if i || (not !Clflags.option_fcommon) then ".data" else "COMM" + variable_section ~sec:".data" i | Section_const i | Section_small_const i -> - if i || (not !Clflags.option_fcommon) then ".const" else "COMM" + variable_section ~sec:".const" ~reloc:".const_data" i | Section_string -> ".const" - | Section_literal -> ".literal8" + | Section_literal -> ".const" | Section_jumptable -> ".text" | Section_user(s, wr, ex) -> sprintf ".section \"%s\", %s, %s" @@ -239,6 +244,9 @@ module MacOS_System : SYSTEM = module Cygwin_System : SYSTEM = struct + (* The comment delimiter *) + let comment = "#" + let symbol_prefix = if Archi.ptr64 then "" else "_" @@ -254,9 +262,9 @@ module Cygwin_System : SYSTEM = let name_of_section = function | Section_text -> ".text" | Section_data i | Section_small_data i -> - if i then ".data" else common_section () + variable_section ~sec:".data" ~bss:".bss" i | Section_const i | Section_small_const i -> - if i || (not !Clflags.option_fcommon) then ".section .rdata,\"dr\"" else "COMM" + variable_section ~sec:".section .rdata,\"dr\"" i | Section_string -> ".section .rdata,\"dr\"" | Section_literal -> ".section .rdata,\"dr\"" | Section_jumptable -> ".text" @@ -733,7 +741,7 @@ module Target(System: SYSTEM):TARGET = | Pret -> if (not Archi.ptr64) && (!current_function_sig).sig_cc.cc_structret then begin - fprintf oc " movl 0(%%esp), %%eax\n"; + fprintf oc " movl 4(%%esp), %%eax\n"; fprintf oc " ret $4\n" end else begin fprintf oc " ret\n" @@ -914,8 +922,7 @@ module Target(System: SYSTEM):TARGET = let print_epilogue oc = if !need_masks then begin - section oc (Section_const true); - (* not Section_literal because not 8-bytes *) + section oc Section_literal; print_align oc 16; fprintf oc "%a: .quad 0x8000000000000000, 0\n" raw_symbol "__negd_mask"; @@ -945,7 +952,7 @@ end let sel_target () = let module S = (val (match Configuration.system with | "linux" | "bsd" -> (module ELF_System:SYSTEM) - | "macosx" -> (module MacOS_System:SYSTEM) + | "macos" -> (module MacOS_System:SYSTEM) | "cygwin" -> (module Cygwin_System:SYSTEM) | _ -> invalid_arg ("System " ^ Configuration.system ^ " not supported") ):SYSTEM) in (module Target(S):TARGET) diff --git a/x86/extractionMachdep.v b/x86/extractionMachdep.v index 20c6a521..26a3f0a7 100644 --- a/x86/extractionMachdep.v +++ b/x86/extractionMachdep.v @@ -6,10 +6,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) @@ -28,6 +29,6 @@ Extract Constant Archi.win64 => Extract Constant SelectOp.symbol_is_external => "match Configuration.system with - | ""macosx"" -> C2C.atom_is_extern + | ""macos"" -> C2C.atom_is_extern | ""cygwin"" when Archi.ptr64 -> C2C.atom_is_extern | _ -> (fun _ -> false)". diff --git a/x86_32/Archi.v b/x86_32/Archi.v index bbc04950..0a7f365b 100644 --- a/x86_32/Archi.v +++ b/x86_32/Archi.v @@ -7,10 +7,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) diff --git a/x86_64/Archi.v b/x86_64/Archi.v index 0e027c0f..ed6dc317 100644 --- a/x86_64/Archi.v +++ b/x86_64/Archi.v @@ -7,10 +7,11 @@ (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) (* *) (* *********************************************************************) |