diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,16 @@ -## 0.905 (18 May, 2018) +## 0.906 (June 13, 2019) + +* Update to new fortran-src version 0.3.0. +* Add array-check, alloc-check, use-check, fp-check and implicit-none features. + * A collection of sanity checks on Fortran code looking for common issues, possible problems or potential inefficiencies. +* Introduce a divide-and-conquer methodology for solving units-inference problems, reducing the size of the matrices and taking advantage of SMP where available. +* Treat constant-expressions and parameter variables as literals, for units-inference purposes, making it easier to retrofit units annotations onto existing programs. +* Add 'units-infer --show-ast' feature, which decorates the displayed AST (internal data structure) with units information on each expression. +* Made assorted efficiency improvements to the units solver and other features, especially for large projects with many files. +* Add 'units-check --dump-mod-file' feature that lets you view an 'fsmod' file's contents with regard to units info. +* Allow override of Fortran version used by parser using -F option. + +## 0.905 (May 18, 2018) * Greatly improved units-of-measure support * Separate verification of modules diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,202 +1,15 @@ - - Apache License - Version 2.0, January 2004 - http://www.apache.org/licenses/ - - TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION - - 1. Definitions. - - "License" shall mean the terms and conditions for use, reproduction, - and distribution as defined by Sections 1 through 9 of this document. - - "Licensor" shall mean the copyright owner or entity authorized by - the copyright owner that is granting the License. - - "Legal Entity" shall mean the union of the acting entity and all - other entities that control, are controlled by, or are under common - control with that entity. For the purposes of this definition, - "control" means (i) the power, direct or indirect, to cause the - direction or management of such entity, whether by contract or - otherwise, or (ii) ownership of fifty percent (50%) or more of the - outstanding shares, or (iii) beneficial ownership of such entity. - - "You" (or "Your") shall mean an individual or Legal Entity - exercising permissions granted by this License. - - "Source" form shall mean the preferred form for making modifications, - including but not limited to software source code, documentation - source, and configuration files. - - "Object" form shall mean any form resulting from mechanical - transformation or translation of a Source form, including but - not limited to compiled object code, generated documentation, - and conversions to other media types. - - "Work" shall mean the work of authorship, whether in Source or - Object form, made available under the License, as indicated by a - copyright notice that is included in or attached to the work - (an example is provided in the Appendix below). - - "Derivative Works" shall mean any work, whether in Source or Object - form, that is based on (or derived from) the Work and for which the - editorial revisions, annotations, elaborations, or other modifications - represent, as a whole, an original work of authorship. For the purposes - of this License, Derivative Works shall not include works that remain - separable from, or merely link (or bind by name) to the interfaces of, - the Work and Derivative Works thereof. - - "Contribution" shall mean any work of authorship, including - the original version of the Work and any modifications or additions - to that Work or Derivative Works thereof, that is intentionally - submitted to Licensor for inclusion in the Work by the copyright owner - or by an individual or Legal Entity authorized to submit on behalf of - the copyright owner. For the purposes of this definition, "submitted" - means any form of electronic, verbal, or written communication sent - to the Licensor or its representatives, including but not limited to - communication on electronic mailing lists, source code control systems, - and issue tracking systems that are managed by, or on behalf of, the - Licensor for the purpose of discussing and improving the Work, but - excluding communication that is conspicuously marked or otherwise - designated in writing by the copyright owner as "Not a Contribution." - - "Contributor" shall mean Licensor and any individual or Legal Entity - on behalf of whom a Contribution has been received by Licensor and - subsequently incorporated within the Work. - - 2. Grant of Copyright License. Subject to the terms and conditions of - this License, each Contributor hereby grants to You a perpetual, - worldwide, non-exclusive, no-charge, royalty-free, irrevocable - copyright license to reproduce, prepare Derivative Works of, - publicly display, publicly perform, sublicense, and distribute the - Work and such Derivative Works in Source or Object form. - - 3. Grant of Patent License. Subject to the terms and conditions of - this License, each Contributor hereby grants to You a perpetual, - worldwide, non-exclusive, no-charge, royalty-free, irrevocable - (except as stated in this section) patent license to make, have made, - use, offer to sell, sell, import, and otherwise transfer the Work, - where such license applies only to those patent claims licensable - by such Contributor that are necessarily infringed by their - Contribution(s) alone or by combination of their Contribution(s) - with the Work to which such Contribution(s) was submitted. If You - institute patent litigation against any entity (including a - cross-claim or counterclaim in a lawsuit) alleging that the Work - or a Contribution incorporated within the Work constitutes direct - or contributory patent infringement, then any patent licenses - granted to You under this License for that Work shall terminate - as of the date such litigation is filed. - - 4. Redistribution. You may reproduce and distribute copies of the - Work or Derivative Works thereof in any medium, with or without - modifications, and in Source or Object form, provided that You - meet the following conditions: - - (a) You must give any other recipients of the Work or - Derivative Works a copy of this License; and - - (b) You must cause any modified files to carry prominent notices - stating that You changed the files; and - - (c) You must retain, in the Source form of any Derivative Works - that You distribute, all copyright, patent, trademark, and - attribution notices from the Source form of the Work, - excluding those notices that do not pertain to any part of - the Derivative Works; and - - (d) If the Work includes a "NOTICE" text file as part of its - distribution, then any Derivative Works that You distribute must - include a readable copy of the attribution notices contained - within such NOTICE file, excluding those notices that do not - pertain to any part of the Derivative Works, in at least one - of the following places: within a NOTICE text file distributed - as part of the Derivative Works; within the Source form or - documentation, if provided along with the Derivative Works; or, - within a display generated by the Derivative Works, if and - wherever such third-party notices normally appear. The contents - of the NOTICE file are for informational purposes only and - do not modify the License. You may add Your own attribution - notices within Derivative Works that You distribute, alongside - or as an addendum to the NOTICE text from the Work, provided - that such additional attribution notices cannot be construed - as modifying the License. - - You may add Your own copyright statement to Your modifications and - may provide additional or different license terms and conditions - for use, reproduction, or distribution of Your modifications, or - for any such Derivative Works as a whole, provided Your use, - reproduction, and distribution of the Work otherwise complies with - the conditions stated in this License. - - 5. Submission of Contributions. Unless You explicitly state otherwise, - any Contribution intentionally submitted for inclusion in the Work - by You to the Licensor shall be under the terms and conditions of - this License, without any additional terms or conditions. - Notwithstanding the above, nothing herein shall supersede or modify - the terms of any separate license agreement you may have executed - with Licensor regarding such Contributions. - - 6. Trademarks. This License does not grant permission to use the trade - names, trademarks, service marks, or product names of the Licensor, - except as required for reasonable and customary use in describing the - origin of the Work and reproducing the content of the NOTICE file. - - 7. Disclaimer of Warranty. Unless required by applicable law or - agreed to in writing, Licensor provides the Work (and each - Contributor provides its Contributions) on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or - implied, including, without limitation, any warranties or conditions - of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A - PARTICULAR PURPOSE. You are solely responsible for determining the - appropriateness of using or redistributing the Work and assume any - risks associated with Your exercise of permissions under this License. - - 8. Limitation of Liability. In no event and under no legal theory, - whether in tort (including negligence), contract, or otherwise, - unless required by applicable law (such as deliberate and grossly - negligent acts) or agreed to in writing, shall any Contributor be - liable to You for damages, including any direct, indirect, special, - incidental, or consequential damages of any character arising as a - result of this License or out of the use or inability to use the - Work (including but not limited to damages for loss of goodwill, - work stoppage, computer failure or malfunction, or any and all - other commercial damages or losses), even if such Contributor - has been advised of the possibility of such damages. - - 9. Accepting Warranty or Additional Liability. While redistributing - the Work or Derivative Works thereof, You may choose to offer, - and charge a fee for, acceptance of support, warranty, indemnity, - or other liability obligations and/or rights consistent with this - License. However, in accepting such obligations, You may act only - on Your own behalf and on Your sole responsibility, not on behalf - of any other Contributor, and only if You agree to indemnify, - defend, and hold each Contributor harmless for any liability - incurred by, or claims asserted against, such Contributor by reason - of your accepting any such warranty or additional liability. - - END OF TERMS AND CONDITIONS - - APPENDIX: How to apply the Apache License to your work. - - To apply the Apache License to your work, attach the following - boilerplate notice, with the fields enclosed by brackets "[]" - replaced with your own identifying information. (Don't include - the brackets!) The text should be enclosed in the appropriate - comment syntax for the file format. We also recommend that a - file or class name and description of purpose be included on the - same "printed page" as the copyright notice for easier - identification within third-party archives. +Copyright (c) 2015-2019: Matthew Danish, Mistral Contrastin, Dominic Orchard and Andrew Rice - Copyright [yyyy] [name of copyright owner] +Additional thanks for contributions from: Ben Moon, Bradley Hardy, Oleg Oshmyan and Vilem Liepelt - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at - http://www.apache.org/licenses/LICENSE-2.0 + http://www.apache.org/licenses/LICENSE-2.0 - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. diff --git a/camfort.cabal b/camfort.cabal --- a/camfort.cabal +++ b/camfort.cabal @@ -1,209 +1,290 @@ -name: camfort -version: 0.905 -synopsis: CamFort - Cambridge Fortran infrastructure -description: CamFort is a tool for the analysis, transformation, verification of Fortran code. -homepage: https://camfort.github.io -bug-reports: https://github.com/camfort/camfort/issues - -copyright: 2012-2018 University of Cambridge -author: Dominic Orchard, Matthew Danish, Mistral Contrastin, Andrew Rice, Oleg Oshmyan -maintainer: dom.orchard@gmail.com - -license: Apache-2.0 -license-file: LICENSE - -stability: experimental -build-type: Simple -category: Language +cabal-version: 1.12 -cabal-version: 1.18 -tested-with: GHC >= 8.2 +-- This file has been generated from package.yaml by hpack version 0.31.1. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: d90f27e0fcefd6d71f89123fef96fef2ec2cb33a5f7c7c99da877dd1734efa95 -extra-source-files: tests/fixtures/Specification/Stencils/*.f - tests/fixtures/Specification/Units/*.f90 - tests/fixtures/Transformation/*.f90 - CHANGELOG.md +name: camfort +version: 0.906 +synopsis: CamFort - Cambridge Fortran infrastructure +description: CamFort is a tool for the analysis, transformation, verification of Fortran code. +category: Language +stability: experimental +homepage: https://camfort.github.io +bug-reports: https://github.com/camfort/camfort/issues +author: Matthew Danish, Mistral Contrastin, Andrew Rice, Dominic Orchard +maintainer: Matthew Danish +copyright: 2012-2019 University of Cambridge +license: Apache-2.0 +license-file: LICENSE +tested-with: GHC >= 8.6 +build-type: Simple +extra-source-files: + tests/fixtures/Specification/Stencils/example10.expected.f + tests/fixtures/Specification/Stencils/example10.f + tests/fixtures/Specification/Stencils/example11.expected.f + tests/fixtures/Specification/Stencils/example11.f + tests/fixtures/Specification/Stencils/example12.f + tests/fixtures/Specification/Stencils/example13.expected.f + tests/fixtures/Specification/Stencils/example13.f + tests/fixtures/Specification/Stencils/example14.expected.f + tests/fixtures/Specification/Stencils/example14.f + tests/fixtures/Specification/Stencils/example15.expected.f + tests/fixtures/Specification/Stencils/example15.f + tests/fixtures/Specification/Stencils/example16.f + tests/fixtures/Specification/Stencils/example17.f + tests/fixtures/Specification/Stencils/example2.f + tests/fixtures/Specification/Stencils/example3.f + tests/fixtures/Specification/Stencils/example4.f + tests/fixtures/Specification/Stencils/example5.expected.f + tests/fixtures/Specification/Stencils/example5.f + tests/fixtures/Specification/Stencils/example5a.expected.f + tests/fixtures/Specification/Stencils/example5a.f + tests/fixtures/Specification/Stencils/example6.expected.f + tests/fixtures/Specification/Stencils/example6.f + tests/fixtures/Specification/Stencils/example7.expected.f + tests/fixtures/Specification/Stencils/example7.f + tests/fixtures/Specification/Stencils/example8.expected.f + tests/fixtures/Specification/Stencils/example8.f + tests/fixtures/Specification/Stencils/example9.expected.f + tests/fixtures/Specification/Stencils/example9.f + tests/fixtures/Specification/Units/do-loop1.f90 + tests/fixtures/Specification/Units/do-loop2.f90 + tests/fixtures/Specification/Units/eapVarApp.f90 + tests/fixtures/Specification/Units/eapVarScope.f90 + tests/fixtures/Specification/Units/ex1.f90 + tests/fixtures/Specification/Units/ex2.f90 + tests/fixtures/Specification/Units/ex3.f90 + tests/fixtures/Specification/Units/example-criticals-1.f90 + tests/fixtures/Specification/Units/example-criticals-2.f90 + tests/fixtures/Specification/Units/example-inconsist-1.f90 + tests/fixtures/Specification/Units/example-simple-1.f90 + tests/fixtures/Specification/Units/exp.ex1.f90 + tests/fixtures/Specification/Units/exp.ex2.f90 + tests/fixtures/Specification/Units/exp.ex3.f90 + tests/fixtures/Specification/Units/exp.param.f90 + tests/fixtures/Specification/Units/gcd1.f90 + tests/fixtures/Specification/Units/inconsist3.f90 + tests/fixtures/Specification/Units/inconsistLitInPolyFun.f90 + tests/fixtures/Specification/Units/inconsistRecMult.f90 + tests/fixtures/Specification/Units/inferPoly1.f90 + tests/fixtures/Specification/Units/insideOutside.f90 + tests/fixtures/Specification/Units/literal-nonzero-inconsist1.f90 + tests/fixtures/Specification/Units/literal-nonzero-inconsist2.f90 + tests/fixtures/Specification/Units/literal-nonzero-inconsist3.f90 + tests/fixtures/Specification/Units/literal-nonzero-inconsist4.f90 + tests/fixtures/Specification/Units/literal-nonzero-inconsist5.f90 + tests/fixtures/Specification/Units/literal-nonzero.f90 + tests/fixtures/Specification/Units/literal-nonzero2.f90 + tests/fixtures/Specification/Units/literal-zero.f90 + tests/fixtures/Specification/Units/param.f90 + tests/fixtures/Specification/Units/recursive1.f90 + tests/fixtures/Specification/Units/sqrtPoly.f90 + tests/fixtures/Specification/Units/squarePoly1.f90 + tests/fixtures/Specification/Units/transfer.f90 + tests/fixtures/Transformation/cmn.expected.f90 + tests/fixtures/Transformation/common.expected.f90 + tests/fixtures/Transformation/common.f90 + tests/fixtures/Transformation/equiv.expected.f90 + tests/fixtures/Transformation/equiv.f90 + CHANGELOG.md source-repository head type: git location: https://github.com/camfort/camfort -executable camfort - main-is: src/Main.hs - build-depends: base >= 4.6 && < 5, - directory >= 1.2 && < 2, - optparse-applicative >= 0.14 && < 0.15, - camfort - default-language: Haskell2010 - library - hs-source-dirs: src - build-tools: alex >= 3.1, happy >= 1.19 - extra-libraries: flint - exposed-modules: Camfort.Analysis - Camfort.Analysis.Logger - Camfort.Analysis.Annotations - Camfort.Analysis.CommentAnnotator - Camfort.Analysis.ModFile - Camfort.Analysis.Simple - Camfort.Specification.Parser - - Camfort.Specification.Stencils.Analysis - Camfort.Specification.Stencils.Annotation - Camfort.Specification.Stencils.CheckBackend - Camfort.Specification.Stencils.CheckFrontend - Camfort.Specification.Stencils.Consistency - Camfort.Specification.Stencils.DenotationalSemantics - Camfort.Specification.Stencils.InferenceBackend - Camfort.Specification.Stencils.InferenceFrontend - Camfort.Specification.Stencils.Model - Camfort.Specification.Stencils.Syntax - Camfort.Specification.Stencils.Generate - Camfort.Specification.Stencils.Parser - Camfort.Specification.Stencils.Parser.Types - Camfort.Specification.Stencils.Synthesis - Camfort.Specification.Stencils - - Camfort.Specification.Units - Camfort.Specification.Units.Analysis - Camfort.Specification.Units.Analysis.Consistent - Camfort.Specification.Units.Analysis.Criticals - Camfort.Specification.Units.Analysis.Infer - Camfort.Specification.Units.Annotation - Camfort.Specification.Units.InferenceBackend - Camfort.Specification.Units.InferenceBackendFlint - Camfort.Specification.Units.InferenceBackendSBV - Camfort.Specification.Units.BackendTypes - Camfort.Specification.Units.Environment - Camfort.Specification.Units.ModFile - Camfort.Specification.Units.Monad - Camfort.Specification.Units.MonadTypes - Camfort.Specification.Units.Parser - Camfort.Specification.Units.Parser.Types - Camfort.Specification.Units.Synthesis - - Camfort.Specification.Hoare - Camfort.Specification.Hoare.Annotation - Camfort.Specification.Hoare.Parser - Camfort.Specification.Hoare.Parser.Types - Camfort.Specification.Hoare.Lexer - Camfort.Specification.Hoare.Syntax - Camfort.Specification.Hoare.Translate - Camfort.Specification.Hoare.CheckFrontend - Camfort.Specification.Hoare.CheckBackend - - Camfort.Transformation.CommonBlockElim - Camfort.Transformation.DeadCode - Camfort.Transformation.EquivalenceElim - - Camfort.Helpers - Camfort.Helpers.Syntax - Camfort.Helpers.Vec - Camfort.Helpers.TypeLevel - Camfort.Functionality - Camfort.Input - Camfort.Output - Camfort.Reprint - - Language.Fortran.Model - Language.Fortran.Model.Singletons - Language.Fortran.Model.Types - Language.Fortran.Model.Types.Match - Language.Fortran.Model.Translate - Language.Fortran.Model.Repr - Language.Fortran.Model.Repr.Prim - Language.Fortran.Model.Vars - Language.Fortran.Model.Op - Language.Fortran.Model.Op.Eval - Language.Fortran.Model.Op.Core - Language.Fortran.Model.Op.Core.Match - Language.Fortran.Model.Op.Core.Core - Language.Fortran.Model.Op.Core.Eval - Language.Fortran.Model.Op.Meta - Language.Fortran.Model.Op.High - Language.Fortran.Model.Util - - build-depends: base >= 4.6 && < 5, - ghc-prim >= 0.3.1.0 && < 0.6, - containers >= 0.5.0.0 && < 0.6, - uniplate >= 1.6.10 && < 1.7, - syz >= 0.2 && < 0.3, - syb >= 0.4 && < 0.8, - matrix >= 0.2.2 && < 0.4, - hmatrix >= 0.15 && < 0.19, - mtl >= 2.1 && < 2.3, - text >= 0.11.2.3 && < 1.3, - array >= 0.4 && < 0.6, - directory >= 1.2 && < 1.4, - transformers >= 0.4 && < 0.6, - vector >= 0.1 && < 0.13, - GenericPretty >= 1.2.2 && < 1.3, - fortran-src >= 0.2.1.1 && < 0.3, - filepath >= 1.4 && < 1.5, - bytestring >= 0.10 && < 0.11, - fgl >= 5.6 && < 5.7, - binary >= 0.8.3.0 && < 0.9, - lattices >= 1.7.1 && < 1.8, - sbv >= 7.0 && < 8, - partial-order >= 0.1.2.1 && < 0.1.3, - lens >= 4.15.1 && < 5, - mmorph >= 1.0.9 && < 2, - singletons >= 2.2 && < 3, - template-haskell >= 2.11 && < 3, - vinyl >= 0.6 && < 1.0, - verifiable-expressions >= 0.4 + exposed-modules: + Camfort.Analysis + Camfort.Analysis.Logger + Camfort.Analysis.Annotations + Camfort.Analysis.CommentAnnotator + Camfort.Analysis.ModFile + Camfort.Analysis.Simple + Camfort.Specification.Parser + Camfort.Specification.DerivedDataType + Camfort.Specification.DerivedDataType.Parser + Camfort.Specification.Stencils.Analysis + Camfort.Specification.Stencils.Annotation + Camfort.Specification.Stencils.CheckBackend + Camfort.Specification.Stencils.CheckFrontend + Camfort.Specification.Stencils.Consistency + Camfort.Specification.Stencils.DenotationalSemantics + Camfort.Specification.Stencils.InferenceBackend + Camfort.Specification.Stencils.InferenceFrontend + Camfort.Specification.Stencils.PartialOrd + Camfort.Specification.Stencils.Model + Camfort.Specification.Stencils.Syntax + Camfort.Specification.Stencils.Generate + Camfort.Specification.Stencils.Parser + Camfort.Specification.Stencils.Parser.Types + Camfort.Specification.Stencils.Synthesis + Camfort.Specification.Stencils + Camfort.Specification.Units + Camfort.Specification.Units.Analysis + Camfort.Specification.Units.Analysis.Consistent + Camfort.Specification.Units.Analysis.Criticals + Camfort.Specification.Units.Analysis.Infer + Camfort.Specification.Units.Annotation + Camfort.Specification.Units.InferenceBackend + Camfort.Specification.Units.InferenceBackendFlint + Camfort.Specification.Units.InferenceBackendSBV + Camfort.Specification.Units.BackendTypes + Camfort.Specification.Units.Environment + Camfort.Specification.Units.ModFile + Camfort.Specification.Units.Monad + Camfort.Specification.Units.MonadTypes + Camfort.Specification.Units.Parser + Camfort.Specification.Units.Parser.Types + Camfort.Specification.Units.Synthesis + Camfort.Specification.Hoare + Camfort.Specification.Hoare.Annotation + Camfort.Specification.Hoare.Parser + Camfort.Specification.Hoare.Parser.Types + Camfort.Specification.Hoare.Lexer + Camfort.Specification.Hoare.Syntax + Camfort.Specification.Hoare.Translate + Camfort.Specification.Hoare.CheckFrontend + Camfort.Specification.Hoare.CheckBackend + Camfort.Transformation.CommonBlockElim + Camfort.Transformation.DeadCode + Camfort.Transformation.EquivalenceElim + Camfort.Helpers + Camfort.Helpers.Syntax + Camfort.Helpers.Vec + Camfort.Helpers.TypeLevel + Camfort.Functionality + Camfort.Input + Camfort.Output + Camfort.Reprint + Language.Fortran.Model + Language.Fortran.Model.Singletons + Language.Fortran.Model.Types + Language.Fortran.Model.Types.Match + Language.Fortran.Model.Translate + Language.Fortran.Model.Repr + Language.Fortran.Model.Repr.Prim + Language.Fortran.Model.Vars + Language.Fortran.Model.Op + Language.Fortran.Model.Op.Eval + Language.Fortran.Model.Op.Core + Language.Fortran.Model.Op.Core.Match + Language.Fortran.Model.Op.Core.Core + Language.Fortran.Model.Op.Core.Eval + Language.Fortran.Model.Op.Meta + Language.Fortran.Model.Op.High + Language.Fortran.Model.Util + hs-source-dirs: + src + extra-libraries: + flint + build-tools: + alex ==3.2.* + , happy ==1.19.* + build-depends: + GenericPretty >=1.2.2 && <1.3 + , array >=0.4 && <0.6 + , base >=4.6 && <5 + , binary >=0.8.3.0 && <0.9 + , bytestring >=0.10 && <0.11 + , containers >=0.5.0.0 && <0.7 + , directory >=1.2 && <1.4 + , fgl >=5.6 && <5.8 + , filepath >=1.4 && <1.5 + , fortran-src >=0.3 && <0.4 + , ghc-prim >=0.3.1.0 && <0.6 + , hmatrix >=0.15 && <0.20 + , lattices >=1.7.1 && <1.8 + , lens >=4.15.1 && <5 + , matrix >=0.2.2 && <0.4 + , mmorph >=1.0.9 && <2 + , mtl >=2.1 && <2.3 + , parallel + , pretty >=1.1 && <2 + , sbv >=7.0 && <8 + , singletons >=2.2 && <3 + , strict >=0.3.2 && <1 + , syb >=0.4 && <0.8 + , syz >=0.2 && <0.3 + , template-haskell >=2.11 && <3 + , text >=0.11.2.3 && <1.3 + , transformers >=0.5.5.0 && <0.6 + , uniplate >=1.6.10 && <1.7 + , vector >=0.1 && <0.13 + , verifiable-expressions >=0.4 + , vinyl >=0.6 && <1.0 + , writer-cps-morph >=0.1.0.2 + , writer-cps-mtl >=0.1.1.5 + , writer-cps-transformers >=0.1.1.2 + default-language: Haskell2010 +executable camfort + main-is: src/Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.6 && <5 + , camfort + , directory >=1.2 && <2 + , fortran-src >=0.3 && <0.4 + , optparse-applicative >=0.14 && <0.15 default-language: Haskell2010 test-suite spec - type: exitcode-stdio-1.0 - main-is: Spec.hs - hs-source-dirs: tests - other-modules: Camfort.Analysis.TestUtils - Camfort.Analysis.CommentAnnotatorSpec - Camfort.Analysis.ModFileSpec - Camfort.Analysis.ImplicitNoneSpec - Camfort.FunctionalitySpec - Camfort.ReprintSpec - Camfort.Specification.ParserSpec - Camfort.Specification.Stencils.CheckSpec - Camfort.Specification.Stencils.ConsistencySpec - Camfort.Specification.Stencils.DenotationalSemanticsSpec - Camfort.Specification.Stencils.ParserSpec - Camfort.Specification.Stencils.InferenceBackendSpec - Camfort.Specification.Stencils.ModelSpec - Camfort.Specification.StencilsSpec - Camfort.Specification.Units.Analysis.ConsistentSpec - Camfort.Specification.Units.Analysis.CriticalsSpec - Camfort.Specification.Units.Analysis.InferSpec - Camfort.Specification.Units.InferenceBackendSpec - Camfort.Specification.Units.ParserSpec - Camfort.Specification.Hoare.ParserSpec - Camfort.Transformation.CommonSpec - Camfort.Transformation.EquivalenceElimSpec - - build-depends: base >= 4.6 && < 5, - containers >= 0.5.0.0 && < 0.6, - filepath >= 1.4 && < 1.5, - directory >= 1.2 && < 2, - hspec >= 2.2 && < 3, - QuickCheck >= 2.8 && < 3, - fgl >= 5.6 && < 5.7, - fortran-src >= 0.2.1.1 && < 0.3, - uniplate >= 1.6.10 && < 1.7, - mtl >= 2.1 && < 2.3, - bytestring >= 0.10 && < 0.11, - array >= 0.4 && < 0.6, - hmatrix >= 0.15 && < 0.19, - text >= 0.11.2.3 && < 1.3, - binary >= 0.8.3.0 && < 0.9, - lattices >= 1.7.1 && < 1.8, - sbv >= 7.0 && < 8, - partial-order >= 0.1.2.1 && < 0.1.3, - silently == 1.2.*, - temporary >= 1.2.0.4 && < 1.3, - lens >= 4.15.1 && < 5, - time, - verifiable-expressions >= 0.4, - camfort + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Camfort.Analysis.CommentAnnotatorSpec + Camfort.Analysis.ImplicitNoneSpec + Camfort.Analysis.ModFileSpec + Camfort.Analysis.TestUtils + Camfort.FunctionalitySpec + Camfort.ReprintSpec + Camfort.Specification.DerivedDataTypeSpec + Camfort.Specification.Hoare.ParserSpec + Camfort.Specification.ParserSpec + Camfort.Specification.Stencils.CheckSpec + Camfort.Specification.Stencils.ConsistencySpec + Camfort.Specification.Stencils.DenotationalSemanticsSpec + Camfort.Specification.Stencils.InferenceBackendSpec + Camfort.Specification.Stencils.ModelSpec + Camfort.Specification.Stencils.ParserSpec + Camfort.Specification.StencilsSpec + Camfort.Specification.Units.Analysis.ConsistentSpec + Camfort.Specification.Units.Analysis.CriticalsSpec + Camfort.Specification.Units.Analysis.InferSpec + Camfort.Specification.Units.InferenceBackendSpec + Camfort.Specification.Units.ParserSpec + Camfort.Transformation.CommonSpec + Camfort.Transformation.EquivalenceElimSpec + Paths_camfort + hs-source-dirs: + tests + build-tool-depends: + hspec-discover:hspec-discover + build-depends: + QuickCheck >=2.8 && <3 + , array >=0.4 && <0.6 + , base >=4.6 && <5 + , binary >=0.8.3.0 && <0.9 + , bytestring >=0.10 && <0.11 + , camfort + , containers >=0.5.0.0 && <0.7 + , directory >=1.2 && <2 + , fgl >=5.6 && <5.8 + , filepath >=1.4 && <1.5 + , fortran-src >=0.3 && <0.4 + , hmatrix >=0.15 && <0.20 + , hspec >=2.2 && <3 + , lattices >=1.7.1 && <1.8 + , lens >=4.15.1 && <5 + , mtl >=2.1 && <2.3 + , sbv >=7.0 && <8 + , silently ==1.2.* + , temporary >=1.2.0.4 && <1.4 + , text >=0.11.2.3 && <1.3 + , time + , uniplate >=1.6.10 && <1.7 + , verifiable-expressions >=0.4 default-language: Haskell2010 diff --git a/src/Camfort/Analysis.hs b/src/Camfort/Analysis.hs --- a/src/Camfort/Analysis.hs +++ b/src/Camfort/Analysis.hs @@ -91,11 +91,12 @@ import Control.Monad.Morph import Control.Monad.Reader import qualified Control.Monad.RWS as Lazy -import Control.Monad.RWS.Strict +import Control.Monad.RWS.CPS import qualified Control.Monad.State as Lazy import Control.Monad.State.Strict import qualified Control.Monad.Writer as Lazy -import Control.Monad.Writer.Strict +import Control.Monad.Writer.CPS +import Control.Monad.Fail import Control.Lens @@ -131,6 +132,7 @@ , MonadState s , MonadWriter w' , MonadLogger e w + , MonadFail ) -- | A pure analysis computation which cannot do any 'IO'. @@ -330,9 +332,26 @@ putDescribeReport :: (Describe e, Describe w, Describe r, MonadIO m) - => Text -> Maybe LogLevel -> AnalysisReport e w r -> m () -putDescribeReport analysisName level = liftIO . Lazy.putStrLn . describeReport analysisName level + => Text -> Maybe LogLevel -> Bool -> AnalysisReport e w r -> m () +putDescribeReport analysisName level snippets report = do + let output = describeReport analysisName level report + output' <- if not snippets then return output else insertSnippets output + liftIO . Lazy.putStrLn $ output' +-- Insert snippets of code where source spans are referenced. +insertSnippets :: MonadIO m => Lazy.Text -> m Lazy.Text +insertSnippets output = do + let findLines n cnt str + | n > 0, ls <- Lazy.lines str, ls'@(_:_) <- drop (n-1) ls = Just (take cnt ls') + | otherwise = Nothing + let doLine l + | Just (ParsedOrigin fn (l1, _) (l2, _)) <- parseOrigin (Lazy.unpack l) = do + f <- liftIO $ Lazy.readFile fn + case findLines l1 (l2 - l1 + 1) f of + Just fLines -> return $ [l, Lazy.empty] ++ fLines ++ [Lazy.empty] + Nothing -> return [l] + | otherwise = return [l] + Lazy.unlines <$> concat <$> mapM doLine (Lazy.lines output) -------------------------------------------------------------------------------- -- Running Analyses diff --git a/src/Camfort/Analysis/Logger.hs b/src/Camfort/Analysis/Logger.hs --- a/src/Camfort/Analysis/Logger.hs +++ b/src/Camfort/Analysis/Logger.hs @@ -51,6 +51,8 @@ , (<>) -- * Messages , Origin(..) + , ParsedOrigin(..) + , parseOrigin , oFile , oSpan , LogLevel(..) @@ -84,11 +86,15 @@ import Control.Monad.Morph import Control.Monad.Reader import qualified Control.Monad.RWS as Lazy -import Control.Monad.RWS.Strict +import Control.Monad.RWS.CPS +import Control.Monad.Trans.RWS.CPS.Morph () +import Control.Monad.Trans.RWS.CPS.Internal (RWST(..)) import qualified Control.Monad.State as Lazy import Control.Monad.State.Strict import qualified Control.Monad.Writer as Lazy -import Control.Monad.Writer.Strict +import Control.Monad.Writer.CPS +import Control.Monad.Trans.Writer.CPS.Morph () +import Control.Monad.Fail import Data.Text (Text) import qualified Data.Text.IO as Text @@ -96,6 +102,7 @@ import Data.Text.Lazy.Builder (Builder) import qualified Data.Text.Lazy.Builder as Builder +import Text.Read (readMaybe) import qualified Language.Fortran.Util.Position as F -------------------------------------------------------------------------------- @@ -156,7 +163,7 @@ { _oFile :: FilePath , _oSpan :: F.SrcSpan } - deriving (Show, Eq) + deriving (Show, Eq, Ord) makeLenses ''Origin @@ -165,6 +172,30 @@ "at [" <> Builder.fromString (origin ^. oFile) <> ", " <> describeBuilder (origin ^. oSpan) <> "]" +data ParsedOrigin = ParsedOrigin FilePath (Int, Int) (Int, Int) + deriving (Show, Eq, Ord) + +-- | Extract information about filename and source span from a string. +parseOrigin :: String -> Maybe ParsedOrigin +parseOrigin str + | not (null filename) + , Just (pos1, rest) <- parsePos comma + , Just (pos2, _) <- parsePos rest = Just (ParsedOrigin filename pos1 pos2) + | otherwise = Nothing + where + lbrack = dropWhile (/= '[') str + (filename, comma) = break (==',') (drop 1 lbrack) + +parsePos :: String -> Maybe ((Int, Int), String) +parsePos str + | Just l <- readMaybe line + , Just c <- readMaybe col = Just ((l, c), rest) + | otherwise = Nothing + where + lparen = dropWhile (/= '(') str + (line, colon) = break (== ':') (drop 1 lparen) + (col, rest) = span (/= ')') (drop 1 colon) + -- | A logging level. At each logging level, only produce output at that level or lower. data LogLevel = LogError @@ -382,6 +413,7 @@ , Monad , MonadIO , MonadError e' + , MonadFail ) instance MonadTrans (LoggerT e w) where @@ -394,16 +426,15 @@ instance (MonadReader r m) => MonadReader r (LoggerT e w m) where ask = lift ask - local f (LoggerT (RWST k)) = LoggerT $ RWST $ \e -> local f . k e + local f (LoggerT m) | k <- runRWST m = LoggerT $ rwsT $ \e -> local f . k e instance (MonadWriter w' m) => MonadWriter w' (LoggerT e w m) where tell = lift . tell - - listen (LoggerT (RWST k)) = LoggerT $ RWST $ \e s -> do + listen (LoggerT m) | k <- runRWST m = LoggerT $ rwsT $ \e s -> do ((x, w, s'), w') <- listen (k e s) return ((x, w'), w, s') - pass (LoggerT (RWST k)) = LoggerT $ RWST $ \e s -> + pass (LoggerT m) | k <- runRWST m = LoggerT $ rwsT $ \e s -> pass $ (\((x, f), w, s') -> ((x, w, s'), f)) <$> k e s instance (Monad m, Describe e, Describe w) => @@ -420,10 +451,9 @@ -- the resulting 'LoggerT' cannot output as it goes. It still collects logs to -- be inspected when it finishes. instance MFunctor (LoggerT e w) where - hoist f (LoggerT (RWST k)) = LoggerT $ RWST $ \e s -> + hoist f (LoggerT (RWST k)) = LoggerT ( RWST ( \e s w -> let e' = hoistEnv (const (return ())) e - in f (k e' s) - + in f (k e' s w) ) ) -- | A function to output logs in a particular monad @m@. data LogOutput m = LogOutput @@ -490,7 +520,7 @@ -- | Change the error and warning types in a logger computation. To change the -- underlying monad use 'hoist'. mapLoggerT - :: (Functor m) + :: (Monad m) => (e -> e') -> (w -> w') -> LoggerT e w m a -> LoggerT e' w' m a mapLoggerT mapErr mapWarn (LoggerT x) = LoggerT (mapRWST mapInner x) @@ -551,4 +581,3 @@ logLevel <- LoggerT $ use lsLogLevel lift $ logFunc repeatedOrigin logLevel msgLevel originText msgText - diff --git a/src/Camfort/Analysis/ModFile.hs b/src/Camfort/Analysis/ModFile.hs --- a/src/Camfort/Analysis/ModFile.hs +++ b/src/Camfort/Analysis/ModFile.hs @@ -26,6 +26,7 @@ import Control.Monad (forM) import Control.Monad.IO.Class import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB import Data.Char (toLower) import Data.Data (Data) import Data.List ((\\)) @@ -44,6 +45,7 @@ import qualified Language.Fortran.AST as F import qualified Language.Fortran.Parser.Any as FP import qualified Language.Fortran.Util.ModFile as FM +import Language.Fortran.ParserMonad (FortranVersion(..)) import Camfort.Analysis.Annotations (A, unitAnnotation) import Camfort.Helpers @@ -67,9 +69,9 @@ -- | Generate a mode file based on the given mod file compiler genModFiles :: (MonadIO m) - => FM.ModFiles -> MFCompiler r m -> r -> FilePath -> [Filename] -> m FM.ModFiles -genModFiles mfs mfc env fp excludes = do - fortranFiles <- liftIO $ fmap fst <$> readParseSrcDir mfs fp excludes + => Maybe FortranVersion -> FM.ModFiles -> MFCompiler r m -> r -> FilePath -> [Filename] -> m FM.ModFiles +genModFiles mv mfs mfc env fp excludes = do + fortranFiles <- liftIO $ fmap fst <$> readParseSrcDir mv mfs fp excludes traverse (genCModFile mfc env mfs) fortranFiles -- | Retrieve the ModFiles under a given path. @@ -78,16 +80,18 @@ -- Figure out the camfort mod files and parse them. modFileNames <- (filter isModFile . map (dir )) <$> listDirectory dir mods <- forM modFileNames $ \modFileName -> do - modData <- B.readFile modFileName + modData <- LB.readFile modFileName let eResult = FM.decodeModFile modData case eResult of Left msg -> do putStrLn $ modFileName ++ ": Error: " ++ show msg pure Nothing Right modFile -> do - putStrLn $ modFileName ++ ": successfully parsed precompiled file." pure . pure $ modFile - pure . catMaybes $ mods + let mods' = catMaybes mods + putStrLn $ "Successfully parsed " ++ show (length mods) ++ " precompiled file(s)." + pure mods' + where isModFile :: String -> Bool isModFile = (== FM.modFileSuffix) . takeExtension @@ -105,11 +109,12 @@ concat <$> mapM (listDirectoryRec fullPath) conts else pure [fullPath] -readParseSrcDir :: FM.ModFiles +readParseSrcDir :: Maybe FortranVersion + -> FM.ModFiles -> FileOrDir -> [Filename] -> IO [(F.ProgramFile A, SourceText)] -readParseSrcDir mods inp excludes = do +readParseSrcDir mv mods inp excludes = do isdir <- isDirectory inp files <- if isdir @@ -120,15 +125,17 @@ let excludes' = excludes ++ map (\x -> inp x) excludes pure $ files \\ excludes' else pure [inp] - mapMaybeM (readParseSrcFile mods) files + mapMaybeM (readParseSrcFile mv mods) files where mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] mapMaybeM f = fmap catMaybes . mapM f -readParseSrcFile :: FM.ModFiles -> Filename -> IO (Maybe (F.ProgramFile A, SourceText)) -readParseSrcFile mods f = do +readParseSrcFile :: Maybe FortranVersion -> FM.ModFiles -> Filename -> IO (Maybe (F.ProgramFile A, SourceText)) +readParseSrcFile mv mods f = do inp <- flexReadFile f - let result = FP.fortranParserWithModFiles mods inp f + let result = case mv of + Nothing -> FP.fortranParserWithModFiles mods inp f + Just v -> FP.fortranParserWithModFilesAndVersion v mods inp f case result of Right ast -> pure $ Just (fmap (const unitAnnotation) ast, inp) Left err -> print err >> pure Nothing @@ -173,8 +180,9 @@ => FM.ModFiles -> F.ProgramFile a -> (F.ProgramFile (FA.Analysis a), FAR.ModuleMap, FAT.TypeEnv) withCombinedEnvironment mfs pf = let (pfRenamed, mmap) = withCombinedModuleMap mfs (FA.initAnalysis pf) - tenv = FM.combinedTypeEnv mfs - in (fst . FAT.analyseTypesWithEnv tenv $ pfRenamed, mmap, tenv) + moduleTEnv = FM.combinedTypeEnv mfs + (pf', tenv) = FAT.analyseTypesWithEnv moduleTEnv $ pfRenamed + in (pf', mmap, tenv) -- | From a module map, look up the unique name associated with a given source -- name in the given program unit. Also returns the name type, which tells you diff --git a/src/Camfort/Analysis/Simple.hs b/src/Camfort/Analysis/Simple.hs --- a/src/Camfort/Analysis/Simple.hs +++ b/src/Camfort/Analysis/Simple.hs @@ -16,28 +16,52 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} {- Simple syntactic analysis on Fortran programs -} module Camfort.Analysis.Simple - (countVariableDeclarations, checkImplicitNone, ImplicitNoneReport(..)) where + ( countVariableDeclarations + , checkImplicitNone + , ImplicitNoneReport(..) + , checkAllocateStatements + , checkFloatingPointUse + , checkModuleUse + , checkArrayUse ) +where + import Prelude hiding (unlines) import Control.Monad +import Control.Arrow (first) import Data.Data -import Data.Text (Text, unlines) +import Data.Function (on) +import Data.Maybe (catMaybes, fromMaybe, maybeToList, listToMaybe, mapMaybe) +import qualified Data.Set as S +import qualified Data.IntSet as IS +import qualified Data.Map.Strict as M +import qualified Data.IntMap.Strict as IM import qualified Data.Semigroup as SG import Data.Monoid ((<>)) import Data.Generics.Uniplate.Operations -import Data.Text.Lazy.Builder (Builder) import qualified Data.Text.Lazy.Builder as Builder +import Data.Text (Text, unlines, intercalate, pack) +import Data.List ((\\), sort, nub, nubBy, tails) +import Data.Graph.Inductive import qualified Language.Fortran.AST as F import qualified Language.Fortran.Util.Position as F +import qualified Language.Fortran.Analysis as F +import qualified Language.Fortran.Analysis.Types as F +import qualified Language.Fortran.Analysis.DataFlow as F +import qualified Language.Fortran.Analysis.BBlocks as F +import Language.Fortran.Util.ModFile -import Camfort.Analysis ( ExitCodeOfReport(..), atSpanned, Origin, failAnalysis' - , logError', logError, describe, describeBuilder +import Camfort.Analysis (describeShow, analysisModFiles, ExitCodeOfReport(..), atSpanned, atSpannedInFile, Origin + , logError, describe, describeBuilder , PureAnalysis, Describe ) +import Camfort.Analysis.ModFile (withCombinedEnvironment) {-| Counts the number of declarations (of variables) in a whole program -} @@ -118,3 +142,338 @@ instance ExitCodeOfReport ImplicitNoneReport where exitCodeOf (ImplicitNoneReport []) = 0 exitCodeOf (ImplicitNoneReport _) = 1 + +-------------------------------------------------- + +data CheckAllocReport + = CheckAllocReport { unbalancedAllocs :: [(F.Name, PULoc)] + , outOfOrder :: [(F.Name, PULoc)]} + +instance SG.Semigroup CheckAllocReport where + CheckAllocReport a1 b1 <> CheckAllocReport a2 b2 = CheckAllocReport (a1 ++ a2) (b1 ++ b2) + +instance Monoid CheckAllocReport where + mempty = CheckAllocReport [] [] + mappend = (SG.<>) + +checkAllocateStatements :: forall a. Data a => F.ProgramFile a -> PureAnalysis String () CheckAllocReport +checkAllocateStatements pf = do + let F.ProgramFile F.MetaInfo { F.miFilename = file } _ = pf + + let checkPU :: F.ProgramUnit a -> CheckAllocReport + checkPU pu = CheckAllocReport {..} + where + allocs = + [ (v, (F.getName pu, atSpannedInFile file e)) + | F.StAllocate _ _ _ (F.AList _ _ es) _ <- universeBi (F.programUnitBody pu) :: [F.Statement a] + , e <- es + , v <- take 1 [ v | F.ExpValue _ _ (F.ValVariable v) <- universeBi e :: [F.Expression a] ] + ] + deallocs = + [ (v, (F.getName pu, atSpannedInFile file e)) + | F.StDeallocate _ _ (F.AList _ _ es) _ <- universeBi (F.programUnitBody pu) :: [F.Statement a] + , e <- es + , v <- take 1 [ v | F.ExpValue _ _ (F.ValVariable v) <- universeBi e :: [F.Expression a] ] + ] + isDealloced v = not . null $ filter ((==v) . fst) deallocs + unbalancedAllocs = filter (not . isDealloced . fst) allocs + outOfOrder = concat $ zipWith (\ v1 v2 -> if fst v1 == fst v2 then [] else [v1, v2]) (nubBy ((==) `on` fst) allocs) (nubBy ((==) `on` fst) $ reverse deallocs) + + let reports = map checkPU (universeBi pf) + + return $ mconcat reports + + +instance Describe CheckAllocReport where + describeBuilder (CheckAllocReport {..}) + | null (unbalancedAllocs ++ outOfOrder) = "no cases detected" + | otherwise = Builder.fromText . unlines $ + [ describe orig <> " unbalanced allocation or deallocation for " <> pack name + | (name, (_, orig)) <- unbalancedAllocs ] ++ + [ describe orig <> " out-of-order (de)allocation " <> pack name + | (name, (_, orig)) <- outOfOrder ] + +instance ExitCodeOfReport CheckAllocReport where + exitCodeOf (CheckAllocReport {..}) + | null (unbalancedAllocs ++ outOfOrder) = 0 + | otherwise = 1 + +-------------------------------------------------- + +data CheckFPReport + = CheckFPReport { badEquality :: [PULoc] } + +instance SG.Semigroup CheckFPReport where + CheckFPReport a1 <> CheckFPReport a2 = CheckFPReport (a1 ++ a2) + +instance Monoid CheckFPReport where + mempty = CheckFPReport [] + mappend = (SG.<>) + +checkFloatingPointUse :: forall a. Data a => F.ProgramFile a -> PureAnalysis String () CheckFPReport +checkFloatingPointUse pf = do + let F.ProgramFile F.MetaInfo { F.miFilename = file } _ = pf + mfs <- analysisModFiles + let (pf', _, _) = withCombinedEnvironment mfs pf + let pvm = combinedParamVarMap mfs + let pf'' = F.analyseConstExps . F.analyseParameterVars pvm . F.analyseBBlocks $ pf' + + let checkPU :: F.ProgramUnit (F.Analysis a) -> CheckFPReport + checkPU pu = CheckFPReport {..} + where + candidates :: [F.Expression (F.Analysis a)] + candidates = [ e | e@(F.ExpBinary _ _ op x y) <- universeBi (F.programUnitBody pu) + , op `elem` [F.EQ, F.NE] + , Just (F.IDType (Just bt) _) <- [F.idType (F.getAnnotation x), F.idType (F.getAnnotation y)] + , bt `elem` floatingPointTypes ] + badEquality = nub [ (F.getName pu, atSpannedInFile file e) | e <- candidates ] + + let reports = map checkPU (universeBi pf'') + + return $ mconcat reports + +floatingPointTypes :: [F.BaseType] +floatingPointTypes = [F.TypeReal, F.TypeDoubleComplex, F.TypeComplex, F.TypeDoublePrecision] + +instance Describe CheckFPReport where + describeBuilder (CheckFPReport {..}) + | null (badEquality) = "no cases detected" + | otherwise = Builder.fromText . unlines $ + [ describe orig <> " equality operation used on floating-point numbers." + | (_, orig) <- badEquality ] + +instance ExitCodeOfReport CheckFPReport where + exitCodeOf (CheckFPReport {..}) + | null (badEquality) = 0 + | otherwise = 1 + +-------------------------------------------------- + +data CheckUseReport + = CheckUseReport { missingOnly :: [PULoc] + , duppedOnly :: [(String, PULoc)] + , unusedNames :: [(String, PULoc)] + } + +instance SG.Semigroup CheckUseReport where + CheckUseReport a1 b1 c1 <> CheckUseReport a2 b2 c2 = CheckUseReport (a1 ++ a2) (b1 ++ b2) (c1 ++ c2) + +instance Monoid CheckUseReport where + mempty = CheckUseReport [] [] [] + mappend = (SG.<>) + +checkModuleUse :: forall a. Data a => F.ProgramFile a -> PureAnalysis String () CheckUseReport +checkModuleUse pf = do + let F.ProgramFile F.MetaInfo { F.miFilename = file } _ = pf + mfs <- analysisModFiles + let (pf', _, _) = withCombinedEnvironment mfs pf + + let checkPU :: F.ProgramUnit (F.Analysis a) -> CheckUseReport + checkPU pu = CheckUseReport {..} + where + statements :: [F.Statement (F.Analysis a)] + statements = universeBi (F.programUnitBody pu) + expressions :: [F.Expression (F.Analysis a)] + expressions = universeBi pu + missingOnly = nub [ (F.getName pu, atSpannedInFile file s) + | s <- [ s | s@(F.StUse _ _ _ _ F.Permissive _) <- statements ] ] + duppedOnly = [ (n, (F.getName pu, atSpannedInFile file $ F.getSpan (ss, ss'))) + | F.StUse _ ss (F.ExpValue _ _ (F.ValVariable n)) _ _ _:rest <- tails statements + , F.StUse _ ss' (F.ExpValue _ _ (F.ValVariable n')) _ _ _ <- rest + , n == n' ] + extractUseName (F.UseID _ ss (F.ExpValue _ _ (F.ValVariable n))) = (n, ss) + extractUseName (F.UseRename _ ss (F.ExpValue _ _ (F.ValVariable n)) _) = (n, ss) + unusedNames = [ (n, (F.getName pu, atSpannedInFile file ss)) + | F.StUse _ _ _ _ _ (Just (F.AList _ _ uses)) <- statements + , (n, ss) <- map extractUseName uses + , length [ () | F.ExpValue _ _ (F.ValVariable n') <- expressions, n == n' ] < 2 ] + + let reports = map checkPU (universeBi pf') + + return $ mconcat reports + +instance Describe CheckUseReport where + describeBuilder (CheckUseReport {..}) + | null missingOnly && null duppedOnly && null unusedNames = "no cases detected" + | otherwise = Builder.fromText . unlines $ + [ describe orig <> " USE statement missing ONLY attribute." + | (_, orig) <- missingOnly ] ++ + [ describe orig <> " multiple USE statements for same module '" <> describe name <> "'" + | (name, (_, orig)) <- duppedOnly ] ++ + [ describe orig <> " local name '" <> describe name <> "' imported but unused in program unit." + | (name, (_, orig)) <- unusedNames ] + +instance ExitCodeOfReport CheckUseReport where + exitCodeOf (CheckUseReport {..}) + | null missingOnly && null duppedOnly && null unusedNames = 0 + | otherwise = 1 + +-------------------------------------------------- + +data CheckArrayReport + = CheckArrayReport { nestedIdx, missingIdx :: [([String], PULoc)] } + +instance SG.Semigroup CheckArrayReport where + CheckArrayReport a1 b1 <> CheckArrayReport a2 b2 = CheckArrayReport (a1 ++ a2) (b1 ++ b2) + +instance Monoid CheckArrayReport where + mempty = CheckArrayReport [] [] + mappend = (SG.<>) + +-- Look at array subscripting, especially with regard to order of +-- indices and perhaps whether there is a missing data dependency on +-- an index variable (e.g. due to copy/paste error). +checkArrayUse :: forall a. Data a => F.ProgramFile a -> PureAnalysis String () CheckArrayReport +checkArrayUse pf = do + let F.ProgramFile F.MetaInfo { F.miFilename = file } _ = pf + mfs <- analysisModFiles + let (pf', _, _) = withCombinedEnvironment mfs pf + let pvm = combinedParamVarMap mfs + let pf'' = F.analyseConstExps . F.analyseParameterVars pvm . F.analyseBBlocks $ pf' + let bm = F.genBlockMap pf'' + let dm = F.genDefMap bm + let cm = F.genCallMap pf'' + + let checkPU :: F.ProgramUnit (F.Analysis a) -> CheckArrayReport + checkPU pu | F.Analysis { F.bBlocks = Just _ } <- F.getAnnotation pu = CheckArrayReport {..} + where + F.Analysis { F.bBlocks = Just gr } = F.getAnnotation pu + bedges = F.genBackEdgeMap (F.dominators gr) $ F.bbgrGr gr + ivmap = F.genInductionVarMapByASTBlock bedges gr + divmap = F.genDerivedInductionMap bedges gr + rdmap = F.reachingDefinitions dm gr + flFrom = tc . grev $ F.genFlowsToGraph bm dm gr rdmap + + blocks :: [F.Block (F.Analysis a)] + blocks = F.programUnitBody pu + + nestedIdx = [ (ivars, (F.getName pu, atSpannedInFile file ss)) | (ivars, ss) <- getNestedIdx [] blocks ] + + -- find subscripts where the order of indices doesn't match + -- the order of introduction of induction variables by + -- nested do-loops. + getNestedIdx :: [F.Name] -> [F.Block (F.Analysis a)] -> [([String], F.SrcSpan)] + getNestedIdx _ [] = [] + getNestedIdx vs (b@(F.BlDo _ _ _ _ _ _ body _):bs) + | v:_ <- F.blockVarDefs b = getNestedIdx (v:vs) body ++ getNestedIdx vs bs + | otherwise = getNestedIdx vs bs + getNestedIdx vs (b:bs) = bad ++ getNestedIdx vs bs + where + vset = S.fromList vs + vmap = zip vs [0..] + subs = [ (ivars, ss) + | F.ExpSubscript _ ss _ (F.AList _ _ is) <- universeBi b :: [F.Expression (F.Analysis a)] + , let ivars = [ (F.varName e, F.srcName e) + | i <- is + , e@(F.ExpValue _ _ F.ValVariable{}) <- universeBi i :: [F.Expression (F.Analysis a)] + , F.varName e `S.member` vset ] ] + -- 'bad' subscripts are where the ordering doesn't match the nesting. + bad = [ (map snd ivars, ss) + | (ivars, ss) <- subs, let nums = mapMaybe (flip lookup vmap . fst) ivars, nums /= sort nums ] + + missingIdx = [ (missing, (F.getName pu, atSpannedInFile file ss)) | b <- blocks + , (missing, ss) <- getMissingUse [] b ] + + -- Seek any possible missing uses of an induction variable + -- within subscript expressions, looking through nested + -- blocks. We can exclude variables for which If/Case + -- control-flow depends on it instead of needing it to be + -- directly used by a subscript expression. + getMissingUse :: forall a. Data a => [String] -> F.Block (F.Analysis a) -> [([String], F.SrcSpan)] + getMissingUse excls (F.BlDo _ _ _ _ _ _ bs _) = concatMap (getMissingUse excls) bs + getMissingUse excls (F.BlDoWhile _ _ _ _ _ _ bs _) = concatMap (getMissingUse excls) bs + getMissingUse excls (F.BlForall _ _ _ _ _ bs _) = concatMap (getMissingUse excls) bs + getMissingUse excls b@(F.BlIf F.Analysis{F.insLabel = Just i} _ _ _ mes bss _) + -- check If statement conditions + | any (eligible i (length excls)) es = bads ++ rest + | otherwise = rest + where + es = catMaybes mes + -- find any induction variables that are referenced by If-Elseif expressions + excl' = concatMap getExcludes (universeBi es :: [F.Expression (F.Analysis a)]) + rest = concatMap (getMissingUse (excls ++ excl')) $ concat bss + bads = getMissingUse' excls b + getMissingUse excls b@(F.BlCase F.Analysis{F.insLabel = Just i} _ _ _ e _ bss _) + -- check Case statement scrutinee + | eligible i (length excls) e = bads ++ rest + | otherwise = rest + where + rest = concatMap (getMissingUse (excls ++ getExcludes e)) $ concat bss + bads = map (fmap (const (F.getSpan e))) $ getMissingUse' excls b + getMissingUse excls b@(F.BlStatement F.Analysis{F.insLabel = Just i} _ _ st) + | eligible i (length excls) st = getMissingUse' excls b + | otherwise = [] + getMissingUse _ F.BlInterface{} = [] + getMissingUse _ F.BlComment{} = [] + + getMissingUse' :: forall a. Data a => [F.Name] -> F.Block (F.Analysis a) -> [([F.Name], F.SrcSpan)] + getMissingUse' excls b + | Just i <- F.insLabel (F.getAnnotation b) + -- obtain the live induction variables at this program point + , Just ivarSet <- IM.lookup i ivmap + -- find the definitions that flowed into this program point + , flFroms <- suc flFrom i + -- get their AST Blocks + , Just flFromBlocks <- sequence $ map (flip IM.lookup bm) flFroms + -- find out what variables they define + , flFromBlockDefSet <- S.fromList $ concatMap F.blockVarDefs flFromBlocks + -- subtract the excludes and the defined variables from + -- the live induction variables in order to find out the + -- 'missing' or unaccounted-for induction vars. + , missingIVars <- ivarSet `S.difference` S.fromList excls `S.difference` flFromBlockDefSet + -- Try to look up source-names for the missing ivars in + -- each of the flow-from blocks. + , missingIVars' <- S.map (\ v -> "unk" `fromMaybe` findSrcNameInDefMap v) missingIVars + , not (S.null missingIVars) = [(S.toList missingIVars', F.getSpan b)] + getMissingUse' _ _ = [] + + -- eligible bits of AST are those that contain subscripting + -- expressions with a length equivalent to the number of + -- currently live induction variables. + eligible :: forall a b. (Data a, Data (b (F.Analysis a))) => Int -> Int -> b (F.Analysis a) -> Bool + eligible i numExcls x + | Just ivars <- IM.lookup i ivmap = + not $ null [ () | F.ExpSubscript _ _ _ (F.AList _ _ idxs) <- universeBi x :: [F.Expression (F.Analysis a)] + , length idxs == S.size ivars - numExcls ] + | otherwise = False + + -- check the derived induction maps to find out if a given + -- expression depends on any induction variable and + -- therefore can be used to exclude that induction variable + -- from the 'missing' list. + getExcludes e + | Just ei <- F.insLabel (F.getAnnotation e) + , Just (F.IELinear n _ _) <- IM.lookup ei divmap = [n] + getExcludes _ = [] + + -- look through the DefMap and BlockMap for instances of + -- variable v in order to retrieve its 'source name'. + findSrcNameInDefMap v = do + defSet <- M.lookup v dm + bs <- mapM (flip IM.lookup bm) $ IS.toList defSet + msum (map (findSrcName v) bs) + + checkPU _ = mempty + let reports = map checkPU (universeBi pf'') + + return $ mconcat reports + +-- Look through a piece of AST for the source name of a given var name. +findSrcName :: forall a. Data a => F.Name -> F.Block (F.Analysis a) -> Maybe F.Name +findSrcName v b = listToMaybe + [ F.srcName e | e@(F.ExpValue _ _ F.ValVariable{}) <- universeBi b :: [F.Expression (F.Analysis a)] + , F.varName e == v ] + +instance Describe CheckArrayReport where + describeBuilder (CheckArrayReport {..}) + | null nestedIdx && null missingIdx = "no cases detected" + | otherwise = Builder.fromText . unlines $ + [ describe orig <> " possibly less efficient order of subscript indices: " <> intercalate ", " (map describe ivars) + | (ivars, (_, orig)) <- nestedIdx ] ++ + [ describe orig <> " possibly missing use of variable(s) in array subscript: " <> intercalate ", " (map describe ivars) + | (ivars, (_, orig)) <- missingIdx ] + +instance ExitCodeOfReport CheckArrayReport where + exitCodeOf (CheckArrayReport {..}) + | null nestedIdx = 0 + | otherwise = 1 diff --git a/src/Camfort/Functionality.hs b/src/Camfort/Functionality.hs --- a/src/Camfort/Functionality.hs +++ b/src/Camfort/Functionality.hs @@ -33,6 +33,10 @@ , ast , countVarDecls , implicitNone + , allocCheck + , fpCheck + , useCheck + , arrayCheck -- ** Stencil Analysis , stencilsCheck , stencilsInfer @@ -40,6 +44,7 @@ -- ** Unit Analysis , unitsCriticals , unitsCheck + , unitsDump , unitsInfer , unitsCompile , unitsSynth @@ -49,25 +54,39 @@ , common , dead , equivalences + , ddtRefactor + , ddtInfer + , ddtCheck + , ddtSynth + , ddtCompile -- ** Project Management , camfortInitialize ) where import Control.Arrow (first, second) import Data.List (intersperse) +import Data.Maybe (fromMaybe) import Data.Void (Void) -import qualified Data.ByteString as B +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB import System.Directory (doesDirectoryExist, createDirectoryIfMissing, getCurrentDirectory) import System.FilePath (takeDirectory, (), replaceExtension) +import Text.PrettyPrint.GenericPretty (pp, pretty, Out) + import Control.Lens import Control.Monad.Reader.Class -import Control.Monad (forM_) +import Control.Monad +import Control.Monad.IO.Class import qualified Language.Fortran.AST as F +import qualified Language.Fortran.Analysis.Renaming as FA +import qualified Language.Fortran.Analysis as FA import qualified Language.Fortran.Util.ModFile as FM +import Language.Fortran.ParserMonad (FortranVersion(..)) +import Language.Fortran.PrettyPrint import Camfort.Analysis import Camfort.Analysis.Annotations (Annotation) @@ -79,15 +98,18 @@ simpleCompiler) import Camfort.Analysis.Simple import Camfort.Input +import qualified Camfort.Specification.DerivedDataType as DDT import qualified Camfort.Specification.Stencils as Stencils import Camfort.Specification.Stencils.Analysis (compileStencils) import qualified Camfort.Specification.Units as LU import Camfort.Specification.Units.Analysis (compileUnits) +import Camfort.Specification.Units.Annotation (unitInfo) import Camfort.Specification.Units.Analysis.Consistent (checkUnits) import Camfort.Specification.Units.Analysis.Criticals (inferCriticalVariables) -import Camfort.Specification.Units.Analysis.Infer (inferUnits) +import Camfort.Specification.Units.Analysis.Infer (InferenceResult(..), InferenceReport(..), inferUnits) import Camfort.Specification.Units.Monad (runUnitAnalysis, unitOpts0) +import Camfort.Specification.Units.ModFile (dumpModFileCompiledUnits) import Camfort.Specification.Units.MonadTypes (LiteralsOpt, UnitAnalysis, UnitEnv (..), @@ -112,10 +134,12 @@ data CamfortEnv = CamfortEnv - { ceInputSources :: FileOrDir - , ceIncludeDir :: Maybe FileOrDir - , ceExcludeFiles :: [Filename] - , ceLogLevel :: LogLevel + { ceInputSources :: FileOrDir + , ceIncludeDir :: Maybe FileOrDir + , ceExcludeFiles :: [Filename] + , ceLogLevel :: LogLevel + , ceSourceSnippets :: Bool + , ceFortranVersion :: Maybe FortranVersion } -------------------------------------------------------------------------------- @@ -166,8 +190,8 @@ -- ...instead for now, just get the mod files modFiles <- getModFiles incDir - pfsTexts <- readParseSrcDir modFiles (ceInputSources env) (ceExcludeFiles env) - runner program (logOutputStd True) (ceLogLevel env) modFiles pfsTexts + pfsTexts <- readParseSrcDir (ceFortranVersion env) modFiles (ceInputSources env) (ceExcludeFiles env) + runner program (logOutputStd True) (ceLogLevel env) (ceSourceSnippets env) modFiles pfsTexts @@ -178,7 +202,7 @@ ast env = do incDir' <- maybe getCurrentDirectory pure (ceIncludeDir env) modFiles <- getModFiles incDir' - xs <- readParseSrcDir modFiles (ceInputSources env) (ceExcludeFiles env) + xs <- readParseSrcDir (ceFortranVersion env) modFiles (ceInputSources env) (ceExcludeFiles env) print . fmap fst $ xs @@ -225,6 +249,88 @@ (describePerFileAnalysis "check 'implicit none'") simpleCompiler () +allocCheck :: CamfortEnv -> IO Int +allocCheck = + runFunctionality + "Checking allocate / deallocate usage" + (generalizePureAnalysis . checkAllocateStatements) + (describePerFileAnalysis "check allocate / deallocate") + simpleCompiler () + +fpCheck :: CamfortEnv -> IO Int +fpCheck = + runFunctionality + "Checking usage of floating point" + (generalizePureAnalysis . checkFloatingPointUse) + (describePerFileAnalysis "check floating point") + simpleCompiler () + +useCheck :: CamfortEnv -> IO Int +useCheck = + runFunctionality + "Checking usage of USE statements" + (generalizePureAnalysis . checkModuleUse) + (describePerFileAnalysis "check module USE") + simpleCompiler () + +arrayCheck :: CamfortEnv -> IO Int +arrayCheck = + runFunctionality + "Checking array usage" + (generalizePureAnalysis . checkArrayUse) + (describePerFileAnalysis "check array usage") + simpleCompiler () + +ddtRefactor :: FileOrDir -> CamfortEnv -> IO Int +ddtRefactor = + runWithOutput + "Refactoring derived datatypes" + (generalizePureAnalysis . DDT.refactor) + (doRefactor "infer derived data types") + simpleCompiler () + +ddtSynth :: AnnotationType -> FileOrDir -> CamfortEnv -> IO Int +ddtSynth annType = + runWithOutput + "Synthesising derived datatypes" + (generalizePureAnalysis . DDT.synth (markerChar annType)) + (doRefactor "synth derived data types") + simpleCompiler () + +ddtCheck :: CamfortEnv -> IO Int +ddtCheck = + runFunctionality + "Checking derived datatype annotations" + (generalizePureAnalysis . DDT.check) + (describePerFileAnalysis "check derived datatypes") + simpleCompiler () + +ddtInfer :: CamfortEnv -> IO Int +ddtInfer = + runFunctionality + "Inferring derived datatypes" + (generalizePureAnalysis . DDT.infer) + (describePerFileAnalysis "infer derived datatypes") + simpleCompiler () + +ddtCompile :: CamfortEnv -> IO Int +ddtCompile env = do + let description = "Compiling derived datatypes for" + putStrLn $ description ++ " '" ++ ceInputSources env ++ "'" + incDir' <- maybe getCurrentDirectory pure (ceIncludeDir env) + isDir <- doesDirectoryExist incDir' + let incDir | isDir = incDir' + | otherwise = takeDirectory incDir' + modFiles <- getModFiles incDir + + -- Run the gen mod file routine directly on the input source + modFiles <- genModFiles (ceFortranVersion env) modFiles DDT.compile () (ceInputSources env) (ceExcludeFiles env) + -- Write the mod files out + forM_ modFiles $ \ modFile -> do + let mfname = replaceExtension (FM.moduleFilename modFile) FM.modFileSuffix + LB.writeFile mfname (FM.encodeModFile modFile) + return 0 + {- Units feature -} runUnitsFunctionality @@ -284,6 +390,20 @@ return (rs', ps) +unitsDump :: LiteralsOpt -> CamfortEnv -> IO Int +unitsDump _ env = do + let modFileName = ceInputSources env + modData <- LB.readFile modFileName + let eResult = FM.decodeModFile modData + case eResult of + Left msg -> do + putStrLn $ modFileName ++ ": Error: " ++ show msg + pure 1 + Right modFile -> do + putStrLn $ modFileName ++ ": successfully parsed precompiled file." + putStrLn . fromMaybe "unable to find units info" $ dumpModFileCompiledUnits modFile + pure 0 + unitsCheck :: LiteralsOpt -> CamfortEnv -> IO Int unitsCheck = runUnitsFunctionality @@ -292,13 +412,30 @@ (describePerFileAnalysis "unit checking") -unitsInfer :: LiteralsOpt -> CamfortEnv -> IO Int -unitsInfer = +unitsInfer :: Bool -> LiteralsOpt -> CamfortEnv -> IO Int +unitsInfer showAST = runUnitsFunctionality "Inferring units for" (singlePfUnits inferUnits) - (describePerFileAnalysis "unit inference") + (if showAST + then describePerFileAnalysisShowASTUnitInfo + else describePerFileAnalysis "unit inference") +-- | Given an analysis program for a single file, run it over every input file +-- and collect the reports, then print those reports to standard output. +describePerFileAnalysisShowASTUnitInfo + :: (MonadIO m, Describe w, Describe e) + => AnalysisRunner e w m ProgramFile InferenceResult Int +describePerFileAnalysisShowASTUnitInfo program logOutput logLevel snippets modFiles pfsTexts = do + reports <- runPerFileAnalysis program logOutput logLevel snippets modFiles pfsTexts + flip mapM_ reports $ \ r -> do + case r of + AnalysisReport _ _ (ARSuccess (Inferred (InferenceReport pfUA eVars))) -> + liftIO . pp . fmap (unitInfo . FA.prevAnnotation) . FA.rename $ pfUA + _ -> pure () + putDescribeReport "unit inference" (Just logLevel) snippets r + return $ exitCodeOfSet reports + {- TODO: remove if not needed unitsCompile :: FileOrDir -> LiteralsOpt -> CamfortEnv -> IO () unitsCompile outSrc opts env = @@ -325,11 +462,11 @@ modFiles <- getModFiles incDir -- Run the gen mod file routine directly on the input source - modFiles <- genModFiles modFiles compileUnits uo (ceInputSources env) (ceExcludeFiles env) + modFiles <- genModFiles (ceFortranVersion env) modFiles compileUnits uo (ceInputSources env) (ceExcludeFiles env) -- Write the mod files out forM_ modFiles $ \modFile -> do let mfname = replaceExtension (FM.moduleFilename modFile) FM.modFileSuffix - B.writeFile mfname (FM.encodeModFile modFile) + LB.writeFile mfname (FM.encodeModFile modFile) return 0 unitsSynth :: AnnotationType -> FileOrDir -> LiteralsOpt -> CamfortEnv -> IO Int @@ -400,4 +537,3 @@ camfortInitialize :: FilePath -> IO () camfortInitialize projectDir = createDirectoryIfMissing False (projectDir ".camfort") - diff --git a/src/Camfort/Helpers.hs b/src/Camfort/Helpers.hs --- a/src/Camfort/Helpers.hs +++ b/src/Camfort/Helpers.hs @@ -43,7 +43,7 @@ import qualified Data.ByteString.Char8 as B import System.Directory import qualified Data.Map.Lazy as Map hiding (map, (\\)) -import Control.Monad.Writer.Strict +import Control.Monad.Writer.CPS -- collect: from an association list to a map with list-based bins for matching keys collect :: (Eq a, Ord k) => [(k, a)] -> Map.Map k [a] diff --git a/src/Camfort/Helpers/Syntax.hs b/src/Camfort/Helpers/Syntax.hs --- a/src/Camfort/Helpers/Syntax.hs +++ b/src/Camfort/Helpers/Syntax.hs @@ -51,6 +51,7 @@ import Data.Generics.Uniplate.Data import qualified Language.Fortran.AST as F +import qualified Language.Fortran.Analysis as FA import qualified Language.Fortran.Util.Position as FU -- * Comparison and ordering @@ -88,11 +89,14 @@ x'' = transformBi setSpanConst x' setSpanConst :: FU.SrcSpan -> FU.SrcSpan setSpanConst (FU.SrcSpan _ _) = FU.SrcSpan pos0 pos0 - where pos0 = FU.Position 0 0 0 + where pos0 = FU.Position 0 0 0 "" Nothing instance Eq (AnnotationFree F.BaseType) where (AnnotationFree x) == (AnnotationFree y) = x == y +instance Eq (AnnotationFree FA.ConstructType) where + (AnnotationFree x) == (AnnotationFree y) = x == y + -- * Accessor functions for extracting various pieces of information -- out of syntax trees {-| Extracts a string of the (root) variable name from an expression, @@ -114,18 +118,18 @@ -- SrcSpan helpers dropLine :: FU.SrcSpan -> FU.SrcSpan -dropLine (FU.SrcSpan s1 (FU.Position o _ l)) = - FU.SrcSpan s1 (FU.Position o 1 (l+1)) +dropLine (FU.SrcSpan s1 (FU.Position o _ l f Nothing)) = + FU.SrcSpan s1 (FU.Position o 1 (l+1) f Nothing) deleteLine :: FU.SrcSpan -> FU.SrcSpan -deleteLine (FU.SrcSpan (FU.Position ol cl ll) (FU.Position ou _ lu)) = - FU.SrcSpan (FU.Position ol (cl-1) ll) (FU.Position ou 1 (lu+1)) +deleteLine (FU.SrcSpan (FU.Position ol cl ll fl pl) (FU.Position ou _ lu fu pu)) = + FU.SrcSpan (FU.Position ol (cl-1) ll fl pl) (FU.Position ou 1 (lu+1) fu pu) linesCovered :: FU.Position -> FU.Position -> Int -linesCovered (FU.Position _ _ l1) (FU.Position _ _ l2) = l2 - l1 + 1 +linesCovered (FU.Position _ _ l1 _ _) (FU.Position _ _ l2 _ _) = l2 - l1 + 1 -toCol0 (FU.Position o _ l) = FU.Position o 1 l +toCol0 (FU.Position o _ l f p) = FU.Position o 1 l f p afterAligned :: FU.SrcSpan -> FU.Position -afterAligned (FU.SrcSpan (FU.Position o cA _) (FU.Position _ _ lB)) = - FU.Position o cA (lB+1) +afterAligned (FU.SrcSpan (FU.Position o cA _ f p) (FU.Position _ _ lB _ _)) = + FU.Position o cA (lB+1) f p diff --git a/src/Camfort/Input.hs b/src/Camfort/Input.hs --- a/src/Camfort/Input.hs +++ b/src/Camfort/Input.hs @@ -38,6 +38,7 @@ import qualified Language.Fortran.AST as F import Language.Fortran.Util.ModFile (ModFiles, emptyModFiles) +import Language.Fortran.ParserMonad (FortranVersion(..)) import Camfort.Analysis import Camfort.Analysis.Annotations @@ -56,7 +57,7 @@ -- | An 'AnalysisRunner' is a function to run an 'AnalysisProgram' in a -- particular way. Produces a final result of type @r@. type AnalysisRunner e w m a b r = - AnalysisProgram e w m a b -> LogOutput m -> LogLevel -> ModFiles -> [(ProgramFile, SourceText)] -> m r + AnalysisProgram e w m a b -> LogOutput m -> LogLevel -> Bool -> ModFiles -> [(ProgramFile, SourceText)] -> m r -------------------------------------------------------------------------------- -- Simple runners @@ -67,7 +68,7 @@ runPerFileAnalysis :: (Monad m, Describe e, Describe w) => AnalysisRunner e w m ProgramFile b [AnalysisReport e w b] -runPerFileAnalysis program logOutput logLevel modFiles = +runPerFileAnalysis program logOutput logLevel snippets modFiles = traverse (\pf -> runAnalysisT (F.pfGetFilename pf) @@ -81,7 +82,7 @@ runMultiFileAnalysis :: (Monad m, Describe e, Describe w) => AnalysisRunner e w m [ProgramFile] b (AnalysisReport e w b) -runMultiFileAnalysis program logOutput logLevel modFiles +runMultiFileAnalysis program logOutput logLevel snippets modFiles = runAnalysisT "" logOutput logLevel modFiles . program . map fst -------------------------------------------------------------------------------- @@ -119,9 +120,9 @@ describePerFileAnalysis :: (MonadIO m, Describe r, ExitCodeOfReport r, Describe w, Describe e) => Text -> AnalysisRunner e w m ProgramFile r Int -describePerFileAnalysis analysisName program logOutput logLevel modFiles pfsTexts = do - reports <- runPerFileAnalysis program logOutput logLevel modFiles pfsTexts - mapM_ (putDescribeReport analysisName (Just logLevel)) reports +describePerFileAnalysis analysisName program logOutput logLevel snippets modFiles pfsTexts = do + reports <- runPerFileAnalysis program logOutput logLevel snippets modFiles pfsTexts + mapM_ (putDescribeReport analysisName (Just logLevel) snippets) reports return $ exitCodeOfSet reports -- | Accepts an analysis program for multiple input files which produces a @@ -132,8 +133,8 @@ => Text -> FileOrDir -> FilePath -> AnalysisRunner e w IO [ProgramFile] (r, [Either e' ProgramFile]) Int -doRefactor analysisName inSrc outSrc program logOutput logLevel modFiles pfsTexts = do - report <- runMultiFileAnalysis program logOutput logLevel modFiles pfsTexts +doRefactor analysisName inSrc outSrc program logOutput logLevel snippets modFiles pfsTexts = do + report <- runMultiFileAnalysis program logOutput logLevel snippets modFiles pfsTexts let -- Get the user-facing output from the report @@ -141,7 +142,7 @@ -- Get the refactoring result form the report resultFiles = report ^? arResult . _ARSuccess . _2 - putDescribeReport analysisName (Just logLevel) report' + putDescribeReport analysisName (Just logLevel) snippets report' -- If the refactoring succeeded, change the files case resultFiles of @@ -156,8 +157,8 @@ => Text -> FileOrDir -> FilePath -> AnalysisRunner e w IO [ProgramFile] ([ProgramFile], [ProgramFile]) Int -doRefactorAndCreate analysisName inSrc outSrc program logOutput logLevel modFiles pfsTexts = do - report <- runMultiFileAnalysis program logOutput logLevel modFiles pfsTexts +doRefactorAndCreate analysisName inSrc outSrc program logOutput logLevel snippets modFiles pfsTexts = do + report <- runMultiFileAnalysis program logOutput logLevel snippets modFiles pfsTexts let -- Get the user-facing output from the report @@ -165,7 +166,7 @@ -- Get the refactoring result form the report resultFiles = report ^? arResult . _ARSuccess - putDescribeReport analysisName (Just logLevel) report' + putDescribeReport analysisName (Just logLevel) snippets report' case resultFiles of -- If the refactoring succeeded, change the files @@ -225,8 +226,8 @@ :: (Monad m) => AnalysisRunner e w m a b r -> (r -> m r') -> AnalysisRunner e w m a b r' -runThen runner withResult program output level modFiles programFiles = - runner program output level modFiles programFiles >>= withResult +runThen runner withResult program output level snippets modFiles programFiles = + runner program output level snippets modFiles programFiles >>= withResult -------------------------------------------------------------------------------- -- Misc @@ -257,14 +258,14 @@ loadModAndProgramFiles :: (MonadIO m) - => MFCompiler r m -> r + => Maybe FortranVersion + -> MFCompiler r m -> r -> FileOrDir -- ^ Input source file or directory -> FileOrDir -- ^ Include path -> [Filename] -- ^ Excluded files -> m (ModFiles, [(ProgramFile, SourceText)]) -loadModAndProgramFiles mfc env inSrc incDir excludes = do +loadModAndProgramFiles mv mfc env inSrc incDir excludes = do liftIO $ printExcludes inSrc excludes - modFiles <- genModFiles emptyModFiles mfc env incDir excludes - ps <- liftIO $ readParseSrcDir modFiles inSrc excludes + modFiles <- genModFiles mv emptyModFiles mfc env incDir excludes + ps <- liftIO $ readParseSrcDir mv modFiles inSrc excludes pure (modFiles, ps) - diff --git a/src/Camfort/Output.hs b/src/Camfort/Output.hs --- a/src/Camfort/Output.hs +++ b/src/Camfort/Output.hs @@ -166,18 +166,22 @@ -- Output comments refactorBlocks _ inp (F.BlComment ann span (F.Comment comment)) = do cursor <- get + let FU.SrcSpan lb ub = span + lb' | deleteNode ann = lb { FU.posColumn = 0 } + | otherwise = lb + (p0, _) = takeBounds (cursor, lb') inp + nl | null comment || + deleteNode ann = B.empty + | otherwise = B.pack "\n" if pRefactored ann - then let (FU.SrcSpan lb ub) = span - (p0, _) = takeBounds (cursor, lb) inp - nl = if null comment then B.empty else B.pack "\n" - in put ub >> return (B.concat [p0, B.pack comment, nl], True) - else return (B.empty, False) + then put ub >> return (B.concat [p0, B.pack comment, nl], True) + else return (B.empty, False) -- Refactor use statements refactorBlocks v inp b@(F.BlStatement _ _ _ u@F.StUse{}) = do cursor <- get case refactored $ F.getAnnotation u of - Just (FU.Position _ rCol _) -> do + Just (FU.Position _ rCol _ _ _) -> do let (FU.SrcSpan lb _) = FU.getSpan u let (p0, _) = takeBounds (cursor, lb) inp let out = B.pack $ PP.pprintAndRender v b (Just (rCol -1)) @@ -194,8 +198,6 @@ refactorStatements v inp s refactorBlocks v inp (F.BlStatement _ _ _ s@F.StCommon{}) = refactorStatements v inp s -refactorBlocks v inp (F.BlStatement _ _ _ s@F.StDeclaration{}) = - refactorStatements v inp s -- Arbitrary statements can be refactored *as blocks* (in order to -- get good indenting) refactorBlocks v inp b@F.BlStatement {} = refactorSyntax v inp b @@ -215,12 +217,15 @@ let a = F.getAnnotation e case refactored a of Nothing -> return (B.empty, False) - Just (FU.Position _ rCol _) -> do - let (FU.SrcSpan lb ub) = FU.getSpan e - let (pre, _) = takeBounds (cursor, lb) inp - let indent = if newNode a then Just (rCol - 1) else Nothing - let output = if deleteNode a then B.empty - else B.pack $ PP.pprintAndRender v e indent + Just (FU.Position _ rCol _ _ _) -> do + let FU.SrcSpan lb ub = FU.getSpan e + lb' | deleteNode a = lb { FU.posColumn = 0 } + | otherwise = lb + (pre, _) = takeBounds (cursor, lb') inp + let indent | newNode a = Just (rCol - 1) + | otherwise = Nothing + let output | deleteNode a = B.empty + | otherwise = B.pack $ PP.pprintAndRender v e indent out <- if newNode a then do -- If a new node is begin created then numAdded <- lift get @@ -232,14 +237,12 @@ lift $ put (numAdded - numRemoved) return out else return output - put ub + put $ if FU.posColumn ub == 1 + then ub else ub { FU.posLine = FU.posLine ub + 1, FU.posColumn = 1 } return (B.concat [pre, out], True) -countLines xs = - case B.uncons xs of - Nothing -> 0 - Just ('\n', xs) -> 1 + countLines xs - Just (_, xs) -> countLines xs +countLines :: B.ByteString -> Int +countLines = B.count '\n' {- 'removeNewLines xs n' removes at most 'n' new lines characters from the input string xs, returning the new string and the number of new diff --git a/src/Camfort/Reprint.hs b/src/Camfort/Reprint.hs --- a/src/Camfort/Reprint.hs +++ b/src/Camfort/Reprint.hs @@ -133,8 +133,8 @@ -- incoming SourceText based on the distanceF between the FU.Position pairs takeBounds :: (FU.Position, FU.Position) -> SourceText -> (SourceText, SourceText) takeBounds (l, u) = subtext (ll, lc) (ll, lc) (ul, uc) - where (FU.Position _ lc ll) = l - (FU.Position _ uc ul) = u + where (FU.Position _ lc ll _ _) = l + (FU.Position _ uc ul _ _) = u {-| Split a text. diff --git a/src/Camfort/Specification/DerivedDataType.hs b/src/Camfort/Specification/DerivedDataType.hs new file mode 100644 --- /dev/null +++ b/src/Camfort/Specification/DerivedDataType.hs @@ -0,0 +1,772 @@ +{- + Copyright 2018, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-} + +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE RecordWildCards #-} + +module Camfort.Specification.DerivedDataType + ( infer, refactor, check, synth, compile + , DerivedDataTypeReport(..), successful ) +where + +import Camfort.Analysis +import Camfort.Analysis.Annotations (onPrev, buildCommentText, A, Annotation(..)) +import Camfort.Analysis.CommentAnnotator (annotateComments, ASTEmbeddable(..), Linkable(..)) +import Camfort.Analysis.ModFile +import Camfort.Helpers (Filename) +import Camfort.Helpers.Syntax (afterAligned, toCol0, deleteLine) +import Camfort.Specification.DerivedDataType.Parser (ddtParser, DDTStatement(..)) +import Control.Applicative +import Control.Arrow ((***), (|||), first, second, (&&&)) +import Control.Lens +import Control.Monad +import Control.Monad.RWS.CPS +import Control.Monad.Writer.CPS +import Data.Binary (Binary, decodeOrFail, encode) +import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Data +import Data.Function (on) +import Data.Generics.Uniplate.Operations +import qualified Data.IntMap.Strict as IM +import Data.List (sort, foldl', groupBy) +import qualified Data.List as List +import qualified Data.Map.Strict as M +import Data.Maybe (mapMaybe, fromMaybe, fromJust, maybeToList, isJust) +import Data.Monoid ((<>)) +import qualified Data.Semigroup as SG +import qualified Data.Set as S +import qualified Data.Strict.Either as SE +import Data.Text (Text, unlines, intercalate, pack) +import Data.Text.Lazy.Builder (Builder) +import qualified Data.Text.Lazy.Builder as Builder +import GHC.Generics (Generic) +import qualified Language.Fortran.AST as F +import qualified Language.Fortran.Analysis as FA +import qualified Language.Fortran.Analysis.BBlocks as FAB +import qualified Language.Fortran.Analysis.DataFlow as FAD +import qualified Language.Fortran.Analysis.Renaming as FAR +import qualified Language.Fortran.Analysis.Types as FAT +import Language.Fortran.Util.ModFile +import qualified Language.Fortran.Util.Position as FU +import Prelude hiding (unlines) + +ddtShort :: String +ddtShort = "ddt" + +-------------------------------------------------- +-- Linking DDT specifications with associated AST-blocks. + +-- | Annotation used for derived-datatype info. +data DDTAnnotation = DDTAnnotation { + prevAnnotation :: A, + ddtSpec :: Maybe DDTStatement, -- ^ parsed spec on comments, if any + ddtBlock :: Maybe (F.Block DA) -- ^ linked variable declaration, if any + } deriving (Data, Typeable, Show) +-- | Initialize DDTAnnotation +ddtAnnotation0 :: A -> DDTAnnotation +ddtAnnotation0 a = DDTAnnotation a Nothing Nothing + +-- | Annotation used by most analysis in this file. +type DA = FA.Analysis DDTAnnotation + +-- | Modify top-level annotation. +onOrigAnnotation :: (A -> A) -> DA -> DA +onOrigAnnotation f = onPrev $ \ a -> a { prevAnnotation = f (prevAnnotation a) } + +-- | Strip annotations used by this file. +stripAnnotations :: Functor f => f DA -> f A +stripAnnotations = fmap (prevAnnotation . FA.prevAnnotation) + +-- Instances for embedding parsed specifications into the AST +instance ASTEmbeddable DA DDTStatement where + annotateWithAST ann ast = onPrev (\ ann' -> ann' { ddtSpec = Just ast }) ann + +-- Link annotation comments to declaration statements +instance Linkable DA where + link ann b@(F.BlStatement _ _ _ F.StDeclaration{}) = onPrev (\ ann' -> ann' { ddtBlock = Just b }) ann + link ann _ = ann + linkPU ann _ = ann -- annotation on PU not needed/supported + +-------------------------------------------------- +-- Reporting data structures. + +-- | Map of information about constants used to index arrays. Nothing +-- implies a non-constant is used to index the array at the given +-- dimension. +-- +-- Variable name (unique name) => (dim => maybe constants) +type AMap = M.Map F.Name (IM.IntMap (S.Set (Maybe Int))) + +-- | Map of info about vars (unique name). +type VMap = M.Map F.Name (S.Set VInfo) + +-- | Map of specification essences connected to var-unique-name(dim)s. +type SMap = M.Map (F.Name, Int) (S.Set Essence) + +-- | Info about a variable: source name, source filename, source span. +data VInfo = VInfo { vSrcName :: F.Name, vFileName :: String, vSrcSpan :: FU.SrcSpan } + deriving (Generic, Show, Eq) +instance Binary VInfo + +-- special ord instance compares by filename, source span and then name. +instance Ord VInfo where + VInfo s1 f1 ss1 `compare` VInfo s2 f2 ss2 = (f1, ss1, s1) `compare` (f2, ss2, s2) + +-- | The 'essence' of a specification, in comparable form. +data Essence = Essence { essTypeName :: String -- ^ specified type name + , essLabelMap :: IM.IntMap String -- ^ specified index => label map + , essVInfoSet :: S.Set VInfo -- ^ location of specified vars + , essStarred :: Bool -- ^ is this essence 'starred'? + } + deriving (Show, Generic) +instance Binary Essence + +-- special eq instance: only compare type-name and labels +instance Eq Essence where + Essence ty1 l1 _ _ == Essence ty2 l2 _ _ = (ty1, l1) == (ty2, l2) + +-- special ord instance: only compare type-name and labels +instance Ord Essence where + Essence ty1 l1 _ _ `compare` Essence ty2 l2 _ _ = (ty1, l1) `compare` (ty2, l2) + +-- given type name, (source name, span), dupped labels +data IndexError = IndexDupError String VInfo [Int] + | IndexOOBError String VInfo [Int] + deriving (Show, Eq, Ord, Generic) +instance Binary IndexError + +-- | Variable(dim)s and any conflicting spec essences. +type ConflictErrors = M.Map (F.Name, Int) (S.Set Essence) + +-- | Variable(dim)s where the specification has a bad (e.g. duplicated) label name +type BadLabelErrors = M.Map (F.Name, Int) (S.Set (String, VInfo)) + +-- | Variable(dim)s where the specification has a bad (e.g. duplicated) index +type BadDimErrors = M.Map (F.Name, Int) (S.Set (Int, VInfo)) + +-- | Collection of information comprising a 'derived datatype' report +-- for CamFort output purposes. +data DerivedDataTypeReport + = DerivedDataTypeReport { ddtrAMap :: AMap + , ddtrVMap :: VMap + , ddtrSMap :: SMap + , ddtrSpecs :: [DDTStatement] + , ddtrIDE :: (S.Set IndexError) + , ddtrCE :: ConflictErrors + , ddtrBLE :: BadLabelErrors + , ddtrBDE :: BadDimErrors + , ddtrCheck :: Bool } + deriving Generic +instance Binary DerivedDataTypeReport + +-- | These reports can be combined, e.g. from multiple files, and the +-- key part is that the problem reports are also combined, and new +-- problems can be identified from the combination of the SMaps. +instance SG.Semigroup DerivedDataTypeReport where + DerivedDataTypeReport m1 v1 s1 sp1 ide1 ce1 ble1 bde1 ch1 <> DerivedDataTypeReport m2 v2 s2 sp2 ide2 ce2 ble2 bde2 ch2 = + DerivedDataTypeReport (M.unionWith (IM.unionWith S.union) m1 m2) (M.unionWith S.union v1 v2) newSMap + (sp1 ++ sp2) + (S.union ide1 ide2) (M.unionsWith S.union [ce1, ce2, newCE]) + (M.unionWith S.union ble1 ble2) + (M.unionWith S.union bde1 bde2) + (ch1 && ch2) + where + -- new conflicts found, if any + newCE = M.map SE.fromLeft $ M.filter SE.isLeft e_smap + -- combined SMaps + newSMap = M.map (S.singleton . SE.fromRight) $ M.filter SE.isRight e_smap + + -- | Combine the SMaps while looking for new conflicts. + e_smap = M.fromListWith combine [ (v, SE.Right e) | (v, eSet) <- M.toList s1 ++ M.toList s2, e <- S.toList eSet ] + + combine (SE.Left e1) _ = SE.Left e1 + combine _ (SE.Left e2) = SE.Left e2 + combine (SE.Right e1) (SE.Right e2) = combineEssences e1 e2 + +-- | Combine compatible essences (SE.Right) or else indicate conflict (SE.Left) +combineEssences :: Essence -> Essence -> SE.Either (S.Set Essence) Essence +combineEssences e1 e2 + | Essence ty1 labMap1 vinfoSet1 s1 <- e1 + , Essence ty2 labMap2 vinfoSet2 s2 <- e2 = + fromMaybe (SE.Left $ S.fromList [e1, e2]) $ do + -- In case of conflict, starred essence info overwrites unstarred essence info. + -- + -- Compatible type name: + ty <- case () of _ | ty1 == ty2 -> pure ty1 + | s1 && not s2 -> pure ty1 + | not s1 && s2 -> pure ty2 + | otherwise -> mzero + -- Compatible label names: + let labelStarCombine l1 l2 | l1 == l2 = l1 + | s1 && not s2 = l1 + | not s1 && s2 = l2 + | otherwise = mzero + -- Combined label map: + labMap <- sequenceIntMap $ IM.unionWith labelStarCombine (IM.map pure labMap1) (IM.map pure labMap2) + pure . SE.Right $ Essence ty labMap (S.union vinfoSet1 vinfoSet2) (s1 || s2) + +instance Monoid DerivedDataTypeReport where + mempty = DerivedDataTypeReport M.empty M.empty M.empty [] S.empty M.empty M.empty M.empty False + mappend = (SG.<>) + +-- | True iff no errors are reported. +successful :: DerivedDataTypeReport -> Bool +successful r = and [S.null (ddtrIDE r), M.null (ddtrCE r), M.null (ddtrBLE r), M.null (ddtrBDE r)] + +instance ExitCodeOfReport DerivedDataTypeReport where exitCodeOf r | successful r = 0 | otherwise = 1 + +instance Describe DerivedDataTypeReport where + describeBuilder r@DerivedDataTypeReport{..} + | not (successful r) = Builder.fromText errorReport + | M.null ddtrSMap = "no cases detected" + | ddtrCheck && num == 1 = "1 specification checked." + | ddtrCheck = Builder.fromText $ describe num <> " specifications checked." + | otherwise = Builder.fromText specReport + where + num = length ddtrSpecs + specReport = linesByFile specLines + specLines = [ (vinfo, [pack $ genCommentText r (var, vSrcName)]) + | ((var, dim), essenceSet) <- M.toList ddtrSMap + , Essence{..} <- S.toList essenceSet + , vinfo@VInfo{..} <- S.toList essVInfoSet ] + + ideLines = [ (vinfo, [pack ty <> " has duplicated indice(s) [" <> + intercalate ", " (map describe ints) <> "] for variable: " <> pack (vSrcName vinfo)]) + | IndexDupError ty vinfo ints <- S.toList ddtrIDE ] + oobLines = [ (vinfo, [pack ty <> " has out-of-bounds indice(s) [" <> + intercalate ", " (map describe ints) <> "] for variable: " <> pack (vSrcName vinfo)]) + | IndexOOBError ty vinfo ints <- S.toList ddtrIDE ] + ceLines = [ (vinfo, [pack ty0 <> "(" <> describeLabels l0 <> ") :: " <> pack (vSrcName vinfo) <> "(dim=" <> + describe dim <> ")\nconflicts with\n" <> + unlines [ pack fn <> ": " <> describe ss <> " " <> pack ty <> "(" <> describeLabels labs <> ")" + | Essence ty labs vinfoSet _ <- essences + , VInfo src fn ss <- S.toList vinfoSet ]]) + | ((_, dim), essenceSet) <- M.toList ddtrCE + , not (S.null essenceSet) + , let Essence ty0 l0 vinfoSet0 _:essences = S.toList essenceSet + , vinfo <- take 1 (S.toList vinfoSet0) ] + bleLines = [ (vinfo, ["duplicated label '" <> pack lab <> "', associated with variable " <> + pack (vSrcName vinfo) <> "(dim=" <> describe dim <> ")"]) + | ((_, dim), badSet) <- M.toList ddtrBLE + , (lab, vinfo) <- S.toList badSet ] + bdeLines = [ (vinfo, [pack (vSrcName vinfo) <> ": bad dim " <> describe dim <> + if maxDim == 0 then " less than 1" + else " not in range 1.." <> describe maxDim]) + | ((_, dim), badSet) <- M.toList ddtrBDE + , (maxDim, vinfo) <- S.toList badSet ] + + errorReport = linesByFile $ ideLines ++ oobLines ++ ceLines ++ bleLines ++ bdeLines + describeLabels labs = intercalate ", " [describe i <> "=>" <> pack l | (i,l) <- IM.toList labs] + +-- | Return combined text where entries are grouped and sorted by filename, source span +linesByFile :: [(VInfo, [Text])] -> Text +linesByFile vinfoTexts = unlines $ concat [ ("\n"<>pack fileName<>":\n") : [ describe ss <> " " <> text + | (ss, text) <- sort sstexts ] + | (fileName, sstexts) <- M.toList mapByFile ] + where + mapByFile = M.fromListWith (++) [ (vFileName vinfo, map (vSrcSpan vinfo,) texts) | (vinfo, texts) <- vinfoTexts ] + +-------------------------------------------------- +-- External Functionality Interface + +-- | Generate report about derived datatypes in given program file +infer :: F.ProgramFile A -> PureAnalysis String () DerivedDataTypeReport +infer pf = do + mfs <- analysisModFiles + return . fst $ genProgramFileReport mfs pf + +-- | Check annotations relating to derived datatypes in given program file +check :: F.ProgramFile A -> PureAnalysis String () DerivedDataTypeReport +check pf = do + mfs <- analysisModFiles + return (fst $ genProgramFileReport mfs pf) { ddtrCheck = True } + -- FIXME: check that a user-supplied spec doesn't conflict with something disqualifying in the code + +-- | Generate and insert comments about derived datatypes +synth :: Char -> [F.ProgramFile A] -> PureAnalysis String () (DerivedDataTypeReport, [Either String (F.ProgramFile A)]) +synth marker pfs = do + mfs <- analysisModFiles + forEachProgramFile pfs $ \ pf -> do + let (report, pf'@(F.ProgramFile mi _)) = genProgramFileReport mfs pf + let synthedPF = descendBi (synthBlocks (mi, marker) report) pf' + let strippedPF | successful report = Right (stripAnnotations synthedPF) + | otherwise = Left "error" + return $ (report, strippedPF) + +-- | Refactor derived datatypes based on marked comments +refactor :: [F.ProgramFile A] -> PureAnalysis String () (DerivedDataTypeReport, [Either String (F.ProgramFile A)]) +refactor pfs = do + mfs <- analysisModFiles + forEachProgramFile pfs $ \ pf -> do + let (report, pf') = genProgramFileReport mfs pf + let smap = M.filter (not . S.null) . M.map (S.filter essStarred) $ ddtrSMap report + let amap = M.filter (not . IM.null) . M.mapWithKey cullDims $ ddtrAMap report + where cullDims var = IM.filterWithKey (\ dim _ -> M.member (var, dim) smap) + let report' = report { ddtrSMap = smap, ddtrAMap = amap } + if M.null smap + then return (report', Left "nothing to do") + else return (report', Right . stripAnnotations $ refactorPF report' pf') + +-- | Compile a program to a 'ModFile' containing derived datatype information. +compile :: () -> ModFiles -> F.ProgramFile A -> IO ModFile +compile _ mfs pf = do + let (report, pf') = genProgramFileReport mfs pf + return $ genDDTModFile pf' report + +-------------------------------------------------- +-- Analysis helpers + +-- | Perform monadic action on each, which returns a pair. The fst +-- elements of the pairs is combined with (<>) and the second elements +-- of the pairs are returned in a list. +forEachProgramFile :: (Monad m, Monoid r) => [a] -> (a -> m (r, b)) -> m (r, [b]) +forEachProgramFile pfs f = do + results <- mapM f pfs + return (foldl' (<>) mempty (map fst results), map snd results) + +-- | Performs analysis about a single program file and returns a +-- report containing the essences and problems detected, as well as an +-- annotated program file for further usage. +genProgramFileReport :: ModFiles -> F.ProgramFile A -> (DerivedDataTypeReport, F.ProgramFile DA) +genProgramFileReport mfs (pf@(F.ProgramFile F.MetaInfo{ F.miFilename = srcFile } _)) = (report, pf') + where + (amap, pf', tenv) = analysis mfs pf + vars = S.fromList $ M.keys amap + vls1 = [ (v, S.singleton $ VInfo (FA.srcName e) srcFile ss) + | F.DeclArray _ ss e _ _ _ <- universeBi pf' :: [F.Declarator DA] + , let v = FA.varName e + , v `S.member` vars ] + vls2 = [ (v, S.singleton $ VInfo (FA.srcName e) srcFile ss) + | F.DeclVariable _ ss e _ _ <- universeBi pf' :: [F.Declarator DA] + , let v = FA.varName e + , v `S.member` vars ] + vmap = M.fromListWith S.union $ vls1 ++ vls2 + + specs = [ (spec, b) | DDTAnnotation { ddtSpec = Just spec, ddtBlock = Just b } <- universeBi pf' ] + + -- Boil down the specs parsed from the comments. + e_essences = [ essMapping | (spec@DDTSt{..}, b) <- specs + , (var, dim) <- ddtStVarDims + , (declVarName, vinfo) <- declaredVars srcFile b + , vSrcName vinfo == var + , let essMapping = ((declVarName, dim), distil spec vinfo) ] + (l_errors, r_essences) = List.partition (SE.isLeft . snd) e_essences + + -- Dupped indices: + dupIndices = S.fromList $ map (SE.fromLeft . snd) l_errors + + essences :: M.Map (F.Name, Int) (S.Set Essence) + essences = M.fromListWith S.union $ map (second (S.singleton . SE.fromRight)) r_essences + + -- Conflicting specs: + conflicts = M.filter ((>1) . S.size) essences + findDupLabels Essence{..} = [ (lab, vinfo) | lab <- labs, vinfo <- vinfos ] + where + vinfos = S.toList essVInfoSet + -- Labels that appear more than once in the label map: + labs = M.keys . M.filter (>1) . M.fromListWith (+) . map (,1) $ IM.elems essLabelMap + + -- Dupped labels: + badLabels = M.filter (not . null) $ M.map (setConcatMap findDupLabels) essences + + -- Badly specified 'dim' attributes (e.g. out of bounds): + badDims = [ ((declVarName, dim), S.singleton (maxDim, vinfo)) + | (spec@DDTSt{..} , b) <- specs + , (srcName, dim) <- ddtStVarDims + , (declVarName, vinfo) <- declaredVars srcFile b + , vSrcName vinfo == srcName + , Just maxDim <- [ do guard (dim < 1) + return 0 -- Stand-in number for 'dim violates the lower bound' case. + <|> + do FA.IDType { FA.idCType = Just (FA.CTArray dims) } <- M.lookup declVarName tenv + let maxDim = length dims + guard $ not (null dims || dim <= maxDim) + -- There is a known upper-bound and dim violates it. + return maxDim ] ] + + -- Index out-of-bounds of statically-known array dimensions: + oobIndices = [ IndexOOBError tyname vinfo indices + | (spec@DDTSt{..} , b) <- specs + , (srcName, dim) <- ddtStVarDims + , (declVarName, vinfo) <- declaredVars srcFile b + , let indices = [], let tyname = "" + , vSrcName vinfo == srcName + , Just indices <- [ do FA.IDType { FA.idCType = Just (FA.CTArray dims) } <- M.lookup declVarName tenv + let maxDim = length dims + guard $ dim >= 1 && dim <= maxDim + let (mminBound, mmaxBound) = dims !! (dim - 1) + let minBound = 1 `fromMaybe` mminBound + maxBound <- mmaxBound + let indices = [ read i | (i, _) <- ddtStLabels ] + let oob = filter (uncurry (||) . ((< minBound) &&& (> maxBound))) indices + guard . not . null $ oob + -- oob is the list of indices out-of-bounds + return oob ] ] + + -- Distil specs from the inferred AMap: + smapFromAMap = M.fromList [ ((v, dim), essenceSet) | (v, aminfoMap) <- M.toList amap + , (dim, aminfo) <- IM.toList aminfoMap + , all isJust (S.toList aminfo) + , Just vinfoSet <- [M.lookup v vmap] + , let e = distilArrayInfo v vinfoSet (S.map fromJust aminfo) + , let essenceSet = S.singleton e ] + -- Specs in the file override inferred specs: + smap = M.unionWith (curry fst) essences smapFromAMap + + ide = dupIndices `S.union` S.fromList oobIndices + ce = conflicts + ble = badLabels + bde = M.fromList badDims + -- Combine this report with those reports read from modfiles: + report = DerivedDataTypeReport amap vmap smap (map fst specs) ide ce ble bde False <> combinedDerivedDataTypeReport mfs + +-- | Analyse and return an AMap, a spec-linked ProgramFile and a type +-- environment (convenience). The AMap contains derived information +-- about array accesses that appear to be in a 'category 1' pattern, +-- namely whether the array is accessed at the particular dimension +-- only by constants. +analysis :: ModFiles -> F.ProgramFile A -> (AMap, F.ProgramFile DA, FAT.TypeEnv) +analysis mfs pf = (amap', linkedPF, tenv) + -- FIXME: check for violations of the 'only one array deref in a path' rule + where + (pf', _, tenv) = withCombinedEnvironment mfs (fmap ddtAnnotation0 pf) + pf'' = FAD.analyseConstExps $ FAB.analyseBBlocks pf' + + -- Link specifications (in comments) to associated AST-blocks: + (linkedPF, _) = runWriter $ annotateComments ddtParser + (\ srcSpan err -> tell $ "Error " ++ show srcSpan ++ ": " ++ show err) pf'' + + -- Attempt to gather any constant-expression information from indices. + perArray :: [F.Index DA] -> [(Int, Maybe Int)] + perArray is = [ (n, do F.IxSingle _ _ Nothing e <- Just ix + FAD.ConstInt i <- FA.constExp (F.getAnnotation e) + return (fromIntegral i)) + | (n, ix) <- zip [1..] is ] + + -- Gathered array information for each observed array access: + accessInfo :: [(F.Name, IM.IntMap (S.Set (Maybe Int)))] + accessInfo = [ (FA.varName a, makeIntMapSet observation) + | F.ExpSubscript _ _ a@(F.ExpValue _ _ (F.ValVariable _)) is <- universeBi pf'' + , let observation = perArray $ F.aStrip is ] + + -- Convert access info into a map of information about the + -- constants used to index arrays. + amap :: M.Map F.Name (IM.IntMap (S.Set (Maybe Int))) + amap = M.fromListWith (IM.unionWith S.union) accessInfo + + -- Filter only the interesting ones: at least one of the + -- parameters was populated only by a range of constants where + -- each constant is no more than 3 away from the adjacent ones. + amap' = M.filter (not . IM.null . IM.filter valid) amap -- accept if at least one valid parameter + where + diffs = uncurry (zipWith subtract) . (id &&& drop 1) . sort -- compute differences between consecutive numbers + -- valid set if... + valid = and . sequence [ not . null -- (1) non-empty list + , all isJust -- (2) of constants only, no wildcards + , all (< 3) . diffs . map fromJust -- (3) no more than 3 away from adjacent constants + ] . S.toList +-------------------------------------------------- +-- Refactoring helpers + +type RefactorM = RWS DerivedDataTypeReport [Essence] Bool + +refactorPF :: DerivedDataTypeReport -> F.ProgramFile DA -> F.ProgramFile DA +refactorPF r pf = pf' + where + -- FIXME: possibly use the 'essences' writer slot to instead + -- gather derived-type declarations and put them somewhere + -- central. + (pf', _, essences) = runRWS (descendBiM refactorBlocks pf) r False + +refactorBlocks :: [F.Block DA] -> RefactorM [F.Block DA] +refactorBlocks = fmap concat . mapM refactorBlock + +refactorBlock :: F.Block DA -> RefactorM [F.Block DA] +refactorBlock b = ask >>= \ DerivedDataTypeReport{..} -> case b of + -- Rewrite a type declaration of the variable to be converted into the new form. + -- FIXME: handle references to other converted variables that are found in initialisation expressions + F.BlStatement a ss lab (F.StDeclaration stA stSS ty attrs (F.AList alA alSS decls)) -> do + let declNames = map ((FA.varName . declExp) &&& id) decls + -- Partition declared variables into 'refactor' and 'remain' sets. + let (declsRef, declsRem) = List.partition ((`M.member` ddtrAMap) . fst) declNames + let a' | null declsRef = a + | otherwise = flip onOrigAnnotation a $ \ orig -> orig { refactored = Just (afterAligned ss) } + + -- Process a variable (and its corresponding declaration). + let eachVar (var, decl) + | Just dimMap <- M.lookup var ddtrAMap + -- find the DimDecls for the array we are working on + , dimDeclALists <- universeBi b :: [F.AList F.DimensionDeclarator DA] + , not (null dimDeclALists) + -- if DimDecls are specified twice, take the last one: + , F.AList alDDA alDDSS dimList <- last dimDeclALists + , dims <- IM.keys dimMap + , minDim <- minimum dims + , maxDim <- maximum dims + , dimDeclAList' <- F.AList alDDA alDDSS (take (minDim - 1) dimList) + , dimEssences <- sort $ mapMaybe (\ dim -> (dim,) <$> M.lookup (var, dim) ddtrSMap) dims + , (_, esset1):_ <- dimEssences + , ess1:_ <- S.toList esset1 = + let + F.TypeSpec tyA tySS _ msel = ty + ty' = F.TypeSpec tyA tySS (F.TypeCustom $ essTypeName ess1) msel + a'' = flip onOrigAnnotation a' $ \ orig -> orig { newNode = True } + ss' = FU.SrcSpan (toCol0 lp) lp where lp = afterAligned ss + -- FIXME: character length, what to do + decl' ddAList + | dds <- F.aStrip ddAList + , null dds = F.DeclVariable (F.getAnnotation decl) (FU.getSpan decl) (declExp decl) Nothing Nothing + | otherwise = F.DeclArray (F.getAnnotation decl) (FU.getSpan decl) (declExp decl) ddAList Nothing Nothing + + -- The list of attributes minus any dimension attributes. + attrs' = descendBi (List.filter (not . isAttrDimension)) attrs + attrs'' | Just (F.AList _ _ []) <- attrs' = Nothing + | otherwise = attrs' + + -- Each dimension index number along with its associated type-name. + dimTypes = flip map dimEssences . second $ \ esset -> case S.toList esset of + Essence{..}:_ -> F.TypeSpec tyA tySS (F.TypeCustom $ essTypeName) Nothing + _ -> error "dimTypes: something broken badly: no essences in set" + + -- Process each dimension and return the AST-blocks that define the derived type. + eachDim :: [F.DimensionDeclarator DA] -> Int -> [(Int, F.TypeSpec DA)] -> [F.Block DA] + eachDim dimList maxDim ((dim, F.TypeSpec _ _ (F.TypeCustom tyName) _):(_, nextTy):rest) + | Just (Essence{..}:_) <- fmap S.toList $ M.lookup (var, dim) ddtrSMap = let + mInit | null rest = declInitialiser decl + | otherwise = Nothing + dimDeclAList = F.AList a ss $ drop dim dimList + eachLabel (n, lab) + | maxDim == dim && + dim < length dimList = F.DeclArray a ss (FA.genVar a ss lab) dimDeclAList Nothing mInit + | otherwise = F.DeclVariable a ss (FA.genVar a ss lab) Nothing mInit + labelDecls = map eachLabel . sort $ IM.toList essLabelMap + in [ F.BlStatement a'' ss' Nothing (F.StType stA stSS Nothing tyName) + , F.BlStatement a'' ss' Nothing (F.StDeclaration stA stSS nextTy attrs'' (F.AList alA alSS labelDecls)) + , F.BlStatement a'' ss' Nothing (F.StEndType stA stSS Nothing) ] + eachDim _ _ _ = [] + + in (concat . reverse $ map (eachDim dimList maxDim) (List.tails $ dimTypes ++ [(0, ty)])) ++ + -- The declaration of the variable under the new derived type: + [F.BlStatement a'' ss' lab (F.StDeclaration stA stSS ty' attrs'' (F.AList alA alSS [decl' dimDeclAList']))] + let aRem = onOrigAnnotation (\ orig -> orig { deleteNode = null declsRem }) a' + return $ -- Reinsert any other variables, with the refactored ones removed from the list. + [F.BlStatement aRem ss lab (F.StDeclaration stA stSS ty attrs (F.AList alA alSS (map snd declsRem)))] ++ + -- Followed by the new set of declarations and derived types. + concatMap eachVar declsRef + + -- Eliminate comments that were processed. + F.BlComment a ss _ + | Just spec <- ddtSpec (FA.prevAnnotation a) + , ddtStStarred spec -> do + let FU.SrcSpan lp _ = ss + ss' = deleteLine ss + a' = flip onOrigAnnotation a $ \ orig -> orig { refactored = Just lp, deleteNode = True } + return $ if spec `List.elem` ddtrSpecs + then [F.BlComment a' ss' $ F.Comment ""] + else [b] + -- Rewrite references to the converted variable + F.BlStatement _ _ _ _ -> do + put False + b' <- transformBiM refactorExp b + flag <- get + let FU.SrcSpan lb _ = FU.getSpan b' + if flag + then return [F.modifyAnnotation (onOrigAnnotation $ \ a -> a { refactored = Just lb }) b'] + else return [b] + -- FIXME: handle BlDo, etc + _ -> (:[]) <$> descendBiM refactorBlocks b + +isAttrDimension :: F.Attribute DA -> Bool +isAttrDimension F.AttrDimension{} = True; isAttrDimension _ = False + +-- | Convert references such as @x(1,2,3)@ into @x % label1 % label2(3)@. +refactorExp :: F.Expression DA -> RefactorM (F.Expression DA) +refactorExp e = do + smap <- asks ddtrSMap + case e of + F.ExpSubscript a s e1 ixAList + | ixs <- F.aStrip ixAList + , list <- zipWith ixLookup [1..] ixs + , any SE.isRight list + , list' <- groupBy ((==) `on` SE.isLeft) list + , e' <- foldl' rewrite e1 list' -> put True >> return e' + where + ixLookup dim ix@(F.IxSingle ixA ixS Nothing e) + | Just (FAD.ConstInt i) <- FA.constExp (F.getAnnotation e) + , Just (Essence{..}:_) <- fmap S.toList $ M.lookup (FA.varName e1, dim) smap + , Just label <- IM.lookup (fromIntegral i) essLabelMap = SE.Right (ixA, ixS, label) + ixLookup _ ix = SE.Left ix + + rewrite e l@(SE.Left _:_) = F.ExpSubscript a s e (F.AList a s $ map SE.fromLeft l) + rewrite e (SE.Right (ixA, ixS, label):l) = rewrite (F.ExpDataRef a s e (F.ExpValue a s (F.ValVariable label))) l + rewrite e [] = e + -- FIXME: either convert array slices, or regard that as a disqualifying effect + _ -> return e + +-------------------------------------------------- +-- Synthesis helpers + +-- Operate on [Block], handling insertion or deletion of blocks +synthBlocks :: (F.MetaInfo, Char) -> DerivedDataTypeReport -> [F.Block DA] -> [F.Block DA] +synthBlocks marker report = concatMap (synthBlock marker report) + +-- Synthesise comments where needed, strip existing comment annotations. +synthBlock :: (F.MetaInfo, Char) -> DerivedDataTypeReport -> F.Block DA -> [F.Block DA] +synthBlock (mi, marker) r@DerivedDataTypeReport { ddtrAMap = amap } b = case b of + -- check if this declaration has variables of interest + F.BlStatement a ss _ F.StDeclaration{} | vars <- ofInterest b -> genComment vars ++ [b] + where + ofInterest b = filter (flip M.member amap . fst) $ + [ (FA.varName e, FA.srcName e) | F.DeclVariable _ _ e _ _ <- universeBi b :: [F.Declarator DA] ] ++ + [ (FA.varName e, FA.srcName e) | F.DeclArray _ _ e _ _ _ <- universeBi b :: [F.Declarator DA] ] + + genComment = map $ \ var -> + F.BlComment newA newSS . F.Comment . buildCommentText mi space $ marker:genCommentText r var + + -- Set the refactored flag for the reprinter. + newA = onOrigAnnotation (\ orig -> orig { refactored = Just lp } ) a + + newSS = FU.SrcSpan (lp {FU.posColumn = 0}) (lp {FU.posColumn = 0}) + FU.SrcSpan lp _ = ss + space = FU.posColumn lp - 1 + -- strip existing comment annotations + F.BlComment a ss c | isJust . ddtSpec . FA.prevAnnotation $ a -> [F.BlComment a' ss' $ F.Comment ""] + where + FU.SrcSpan lp _ = ss + ss' = deleteLine ss + a' = flip onOrigAnnotation a $ \ orig -> orig { refactored = Just lp, deleteNode = True } + -- otherwise leave the Block untouched + _ -> [descendBi (synthBlocks (mi, marker) r) b] + +-- Generate the text that goes into the specification. +genCommentText :: DerivedDataTypeReport -> (F.Name, F.Name) -> String +genCommentText DerivedDataTypeReport{..} (varName, srcName) + | Just pmap <- M.lookup varName ddtrAMap + , (dim, set):_ <- IM.toList $ IM.filter (all isJust . S.toList) pmap = + case M.lookup (varName, dim) ddtrSMap of + -- generate new comment from scratch + Nothing + | nums <- map fromJust $ S.toList set + , ty <- varName ++ "_type" + , labs <- List.intercalate ", " [ str ++ "=>" ++ "label" ++ str | num <- nums, let str = show num ] -> + " ddt " ++ ty ++ "(" ++ labs ++ ") :: " ++ srcName ++ "(dim=" ++ show dim ++ ")" + -- generate comment from pre-existing info + Just essenceSet + | Essence{..}:_ <- S.toList essenceSet + , labs <- List.intercalate ", " [ show i ++ "=>" ++ lab | (i, lab) <- IM.toList essLabelMap ] + , starStr <- if essStarred then "* " else " " -> + " " ++ ddtShort ++ starStr ++ essTypeName ++ "(" ++ labs ++ ") :: " ++ srcName ++ "(dim=" ++ show dim ++ ")" + _ -> error $ "genCommentText: unable to generate text for " ++ srcName + +-------------------------------------------------- +-- Check helpers + +-- | From the given piece of AST, returns a list of declared variables +-- (unique form) paired with location. +declaredVars :: Data (f DA) => String -> f DA -> [(F.Name, VInfo)] +declaredVars srcFile x = [ (FA.varName e, VInfo (FA.srcName e) srcFile (FU.getSpan e)) | e <- declaredExps x ] + + +-- | From the given piece of AST, returns a list of expressions +-- associated with the declarators. +declaredExps :: Data (f DA) => f DA -> [F.Expression DA] +declaredExps x = [ e | d <- universeBi x :: [F.Declarator DA] + , e@(F.ExpValue _ _ (F.ValVariable _)) <- [declExp d] ] + + +-- | Pattern matches the expression from the declarator +declExp :: F.Declarator a -> F.Expression a +declExp (F.DeclVariable _ _ e _ _) = e +declExp (F.DeclArray _ _ e _ _ _) = e + +-- | Pattern matches the initialiser from the declarator +declInitialiser :: F.Declarator a -> Maybe (F.Expression a) +declInitialiser (F.DeclVariable _ _ _ _ me) = me +declInitialiser (F.DeclArray _ _ _ _ _ me) = me + +-- | Given a parsed specification and variable information, attempts +-- to 'distil' the essence of the specification. If there is a problem +-- with the spec then it returns SE.Left, otherwise SE.Right. +distil :: DDTStatement -> VInfo -> SE.Either IndexError Essence +distil (DDTSt { ddtStStarred = star, ddtStTypeName = tyname, ddtStLabels = labels }) vinfo + -- if no duplicated indices + | noDups nums = SE.Right $ Essence { essTypeName = tyname + , essLabelMap = IM.fromList [ (n, lname) | (n, lname) <- labels' ] + , essVInfoSet = S.singleton vinfo + , essStarred = star } + -- if there's a problem + | otherwise = SE.Left $ IndexDupError tyname vinfo (nums List.\\ List.nub nums) + where + labels' = map (first read) labels + nums = map fst labels' + noDups nums = length (List.nub nums) == length nums + +-- | Create an essence from array access information derived in a +-- file, assuming some default names and labels. +distilArrayInfo :: F.Name -> S.Set VInfo -> S.Set Int -> Essence +distilArrayInfo var essVInfoSet dimSet = Essence{..} + where + essTypeName = var ++ "_type" + essLabelMap = IM.fromList [ (n, lname) | n <- S.toList dimSet, let lname = "label" ++ show n ] + essStarred = False + +-- | Like concatMap, over Sets +setConcatMap :: (Ord a, Ord b) => (a -> [b]) -> S.Set a -> S.Set b +setConcatMap f = S.fromList . concatMap f . S.toList + +-- | Turn a list of indexed pairs into an IntMap combining values into sets. +makeIntMapSet :: Ord b => [(Int, b)] -> IM.IntMap (S.Set b) +makeIntMapSet = IM.fromListWith S.union . map (second S.singleton) + +-- | Operates like 'sequence' but on an IntMap. +sequenceIntMap :: Monad m => IM.IntMap (m a) -> m (IM.IntMap a) +sequenceIntMap = fmap IM.fromList . sequence . map mstrength . IM.toList + +-- | Lifts the monad from the second half of the pair. +mstrength :: Functor f => (a, f b) -> f (a, b) +mstrength (x, my) = fmap (x,) my + +-------------------------------------------------- +-- Compilation helpers + +-- | Generate a new ModFile containing derived datatype information. +genDDTModFile :: Data a => F.ProgramFile (FA.Analysis a) -> DerivedDataTypeReport -> ModFile +genDDTModFile pf ddtr = alterModFileData f ddtCompiledDataLabel $ genModFile pf + where + f _ = Just $ encode ddtr + +-- | Decode a DerivedDataTypeReport from a ModFile. +mfDerivedDataTypeReport :: ModFile -> DerivedDataTypeReport +mfDerivedDataTypeReport mf = case lookupModFileData ddtCompiledDataLabel mf of + Nothing -> mempty + Just bs -> case decodeOrFail bs of + Left _ -> mempty + Right (_, _, ddtr) -> ddtr + +-- | Combine all reports from ModFiles using (<>) +combinedDerivedDataTypeReport :: ModFiles -> DerivedDataTypeReport +combinedDerivedDataTypeReport = foldMap mfDerivedDataTypeReport + +-- | Section name for derived datatype info inside a ModFile. +ddtCompiledDataLabel :: String +ddtCompiledDataLabel = "derived-datatypes-compiled-data" diff --git a/src/Camfort/Specification/DerivedDataType/Parser.y b/src/Camfort/Specification/DerivedDataType/Parser.y new file mode 100644 --- /dev/null +++ b/src/Camfort/Specification/DerivedDataType/Parser.y @@ -0,0 +1,140 @@ +{ -- -*- Mode: Haskell -*- +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Camfort.Specification.DerivedDataType.Parser + ( ddtParser + , DDTParseError + , DDTStatement(..) + ) where + +import Camfort.Specification.Parser (mkParser, SpecParser) +import Control.Monad.Except (throwError) +import Data.Binary (Binary) +import Data.Char (isLetter, isNumber, isAlphaNum, toLower) +import Data.Data (Data) +import GHC.Generics (Generic) + +} + +%monad { DDTSpecParser } { >>= } { return } +%name parseDDT DDT +%tokentype { Token } + +%token + ddt { TId "ddt" } + dim { TId "dim" } + id { TId $$ } + num { TNum $$ } + ',' { TComma } + '::' { TDoubleColon } + '=' { TEqual } + '=>' { TArrow } + '(' { TLeftPar } + ')' { TRightPar } + '*' { TStar } + +%% + +DDT :: { DDTStatement } +: ddt OPTSTAR id '(' LABELS ')' '::' VARDIMS { DDTSt $2 $3 $5 $8 } + +OPTSTAR :: { Bool } +: '*' { True } +| { False } + +VARDIMS :: { [(String, Int)] } +: VARDIM ',' VARDIMS { $1 : $3 } +| VARDIM { [$1] } + +VARDIM :: { (String, Int) } +: id '(' dim '=' num ')' { ($1, read $5) } + +LABELS :: { [(String, String)] } +: LABEL ',' LABELS { $1 : $3 } +| LABEL { [$1] } + +LABEL :: { (String, String) } +: num '=>' id { ($1, $3) } + +{ + +data DDTStatement + = DDTSt { ddtStStarred :: Bool + , ddtStTypeName :: String + , ddtStLabels :: [(String, String)] + , ddtStVarDims :: [(String, Int)] } + deriving (Data, Eq, Show, Generic) +instance Binary DDTStatement + +data DDTParseError + -- | Not a valid identifier character. + = NotAnIdentifier Char + -- | Tokens do not represent a syntactically valid specification. + | CouldNotParseSpecification [Token] + deriving (Eq) + +instance Show DDTParseError where + show (CouldNotParseSpecification ts) = + "Could not parse specification at: \"" ++ show ts ++ "\"\n" + show (NotAnIdentifier c) = "Invalid character in identifier: " ++ show c + +notAnIdentifier :: Char -> DDTParseError +notAnIdentifier = NotAnIdentifier + +couldNotParseSpecification :: [Token] -> DDTParseError +couldNotParseSpecification = CouldNotParseSpecification + +type DDTSpecParser a = Either DDTParseError a + +data Token = + TComma + | TDoubleColon + | TArrow + | TEqual + | TStar + | TLeftPar + | TRightPar + | TId String + | TNum String + deriving (Show, Eq) + +addToTokens :: Token -> String -> DDTSpecParser [ Token ] +addToTokens tok rest = do + tokens <- lexer rest + return $ tok : tokens + +lexer :: String -> DDTSpecParser [ Token ] +lexer [] = Right [] +lexer ['\n'] = Right [] +lexer ['\r', '\n'] = Right [] +lexer ['\r'] = Right [] -- windows +lexer (' ':xs) = lexer xs +lexer ('\t':xs) = lexer xs +lexer (':':':':xs) = addToTokens TDoubleColon xs +lexer ('=':'>':xs) = addToTokens TArrow xs +lexer (',':xs) = addToTokens TComma xs +lexer ('=':xs) = addToTokens TEqual xs +lexer ('*':xs) = addToTokens TStar xs +lexer ('(':xs) = addToTokens TLeftPar xs +lexer (')':xs) = addToTokens TRightPar xs +lexer (x:xs) + | isLetter x || x == '\'' = aux (\ c -> isAlphaNum c || c `elem` ['\'','_','-']) + TId + | isNumber x = aux isNumber TNum + | otherwise + = throwError $ notAnIdentifier x + where + aux p cons = + let (target, rest) = span p xs + in lexer rest >>= (\tokens -> return $ cons (x:target) : tokens) + +ddtParser :: SpecParser DDTParseError DDTStatement +ddtParser = mkParser (\src -> do + tokens <- lexer $ map toLower src + parseDDT tokens) ["ddt"] + +happyError :: [ Token ] -> DDTSpecParser a +happyError = throwError . couldNotParseSpecification + +} diff --git a/src/Camfort/Specification/Hoare.hs b/src/Camfort/Specification/Hoare.hs --- a/src/Camfort/Specification/Hoare.hs +++ b/src/Camfort/Specification/Hoare.hs @@ -199,12 +199,13 @@ testOn :: FilePath -> IO () testOn fp = do - (mfs, pfsSources) <- loadModAndProgramFiles simpleCompiler () fp fp [] + (mfs, pfsSources) <- loadModAndProgramFiles Nothing simpleCompiler () fp fp [] describePerFileAnalysis "invariant checking" (check PROIdealized) (logOutputStd True) LogDebug + False mfs pfsSources return () diff --git a/src/Camfort/Specification/Hoare/CheckBackend.hs b/src/Camfort/Specification/Hoare/CheckBackend.hs --- a/src/Camfort/Specification/Hoare/CheckBackend.hs +++ b/src/Camfort/Specification/Hoare/CheckBackend.hs @@ -25,8 +25,9 @@ import Control.Exception (Exception (..)) import Control.Lens import Control.Monad.Reader +import Control.Monad.Fail import Control.Monad.State.Strict -import Control.Monad.Writer.Strict +import Control.Monad.Writer.CPS import Control.Monad.Trans.Maybe import Data.Data (Data) import Data.Foldable (foldlM) @@ -495,6 +496,7 @@ , MonadWriter [MetaFormula Bool] , MonadLogger HoareBackendError HoareBackendWarning , MonadAnalysis HoareBackendError HoareBackendWarning + , MonadFail ) @@ -593,6 +595,7 @@ tryBlockToAssignment :: ( MonadReader CheckHoareEnv m , MonadAnalysis HoareBackendError HoareBackendWarning m + , MonadFail m ) => F.Block HA -> m (Maybe FortranAssignment) tryBlockToAssignment bl = do @@ -624,6 +627,7 @@ :: ( ReportAnn (F.Analysis ann) , MonadReader CheckHoareEnv m , MonadAnalysis HoareBackendError HoareBackendWarning m + , MonadFail m ) => NamePair -> F.Expression (F.Analysis ann) @@ -644,6 +648,7 @@ :: ( ReportAnn (F.Analysis ann) , MonadReader CheckHoareEnv m , MonadAnalysis HoareBackendError HoareBackendWarning m + , MonadFail m ) => NamePair -> F.Expression (F.Analysis ann) @@ -675,6 +680,7 @@ :: ( F.Spanned a , MonadReader CheckHoareEnv m , MonadAnalysis HoareBackendError HoareBackendWarning m + , MonadFail m ) => a -> NamePair -> m SomeVar varFromScope loc np = do @@ -696,7 +702,7 @@ doTranslate - :: (MonadReader CheckHoareEnv m, ReportAnn ann) + :: (MonadReader CheckHoareEnv m, ReportAnn ann, MonadFail m) => (HoareBackendError -> m a) -> (f ann -> TranslateT m a) -> f ann -> m a doTranslate handle trans ast = do env <- asks toTranslateEnv @@ -720,6 +726,7 @@ :: ( ReportAnn (F.Analysis ann) , MonadReader CheckHoareEnv m , MonadAnalysis HoareBackendError w m + , MonadFail m ) => D a -> F.Expression (F.Analysis ann) -> m (FortranExpr a) tryTranslateExpr d e = doTranslate (failAnalysis' e) (translateExpression' d) e @@ -728,6 +735,7 @@ :: ( ReportAnn (F.Analysis ann) , MonadReader CheckHoareEnv m , MonadAnalysis HoareBackendError w m + , MonadFail m ) => D a -> F.Expression (F.Analysis ann) -> m (MetaExpr FortranVar a) tryTranslateCoerceExpr d e = @@ -738,6 +746,7 @@ :: ( ReportAnn (F.Analysis ann) , MonadReader CheckHoareEnv m , MonadAnalysis HoareBackendError w m + , MonadFail m ) => TypeInfo (F.Analysis ann) -> m SomeType tryTranslateTypeInfo ti = doTranslate (failAnalysis' ti) translateTypeInfo ti @@ -746,6 +755,7 @@ :: ( ReportAnn (F.Analysis ann) , MonadReader CheckHoareEnv m , MonadAnalysis HoareBackendError w m + , MonadFail m ) => F.Expression (F.Analysis ann) -> m (MetaExpr FortranVar Bool) tryTranslateBoolExpr e = doTranslate (failAnalysis' e) translateBoolExpression e @@ -756,6 +766,7 @@ , Data ann , MonadReader CheckHoareEnv m , MonadAnalysis HoareBackendError w m + , MonadFail m ) => o -> PrimFormula (F.Analysis ann) -> m (MetaFormula Bool) tryTranslateFormula loc formula = do @@ -774,7 +785,7 @@ -- Utility functions -------------------------------------------------------------------------------- -dropWhileM :: (Monad m) => (a -> m Bool) -> [a] -> m [a] +dropWhileM :: (Monad m, MonadFail m) => (a -> m Bool) -> [a] -> m [a] dropWhileM _ [] = return [] dropWhileM f (x : xs) = do continue <- f x @@ -783,7 +794,7 @@ else return (x : xs) -fromMaybeM :: (Monad m) => m a -> Maybe a -> m a +fromMaybeM :: (Monad m, MonadFail m) => m a -> Maybe a -> m a fromMaybeM e = maybe e return diff --git a/src/Camfort/Specification/Hoare/CheckFrontend.hs b/src/Camfort/Specification/Hoare/CheckFrontend.hs --- a/src/Camfort/Specification/Hoare/CheckFrontend.hs +++ b/src/Camfort/Specification/Hoare/CheckFrontend.hs @@ -27,7 +27,7 @@ import Control.Applicative (liftA2) import Control.Exception import Control.Lens -import Control.Monad.Writer.Strict hiding (Product) +import Control.Monad.Writer.CPS hiding (Product) import Data.Generics.Uniplate.Operations import Data.Map (Map) import qualified Data.Map as Map diff --git a/src/Camfort/Specification/Hoare/Translate.hs b/src/Camfort/Specification/Hoare/Translate.hs --- a/src/Camfort/Specification/Hoare/Translate.hs +++ b/src/Camfort/Specification/Hoare/Translate.hs @@ -35,6 +35,7 @@ import Control.Lens import Control.Monad.Except (MonadError (..)) +import Control.Monad.Fail import qualified Language.Fortran.Analysis as F import qualified Language.Fortran.AST as F @@ -65,7 +66,7 @@ -------------------------------------------------------------------------------- -- | Translate an untyped logical formula into a strongly typed 'MetaFormula'. -translateFormula :: (Monad m) => PrimFormula (F.Analysis ann) -> TranslateT m (MetaFormula Bool) +translateFormula :: (Monad m, MonadFail m) => PrimFormula (F.Analysis ann) -> TranslateT m (MetaFormula Bool) translateFormula = \case PFExpr e -> do e' <- translateBoolExpression e @@ -76,7 +77,7 @@ -- | Translate a boolean-valued untyped Fortran expression into a strongly typed 'MetaExpr'. translateBoolExpression - :: (Monad m) + :: (Monad m, MonadFail m) => F.Expression (F.Analysis ann) -> TranslateT m (MetaExpr FortranVar Bool) translateBoolExpression e = do diff --git a/src/Camfort/Specification/Stencils.hs b/src/Camfort/Specification/Stencils.hs --- a/src/Camfort/Specification/Stencils.hs +++ b/src/Camfort/Specification/Stencils.hs @@ -35,12 +35,13 @@ import qualified Language.Fortran.Util.ModFile as MF import qualified Language.Fortran.Analysis.Renaming as FAR import qualified Language.Fortran.Analysis.BBlocks as FAB +import qualified Language.Fortran.Analysis.DataFlow as FAD import Data.List -- | Helper for retrieving analysed blocks. -getBlocks = FAB.analyseBBlocks . FAR.analyseRenames . FA.initAnalysis . fmap SA.mkStencilAnnotation +getBlocks = FAD.analyseConstExps . FAB.analyseBBlocks . FAR.analyseRenames . FA.initAnalysis . fmap SA.mkStencilAnnotation -------------------------------------------------- -- Stencil specification inference -- diff --git a/src/Camfort/Specification/Stencils/CheckFrontend.hs b/src/Camfort/Specification/Stencils/CheckFrontend.hs --- a/src/Camfort/Specification/Stencils/CheckFrontend.hs +++ b/src/Camfort/Specification/Stencils/CheckFrontend.hs @@ -32,7 +32,7 @@ import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader (MonadReader, ReaderT, asks, runReaderT) import Control.Monad.State.Strict -import Control.Monad.Writer.Strict hiding (Product) +import Control.Monad.Writer.CPS hiding (Product) import Data.Function (on) import Data.Generics.Uniplate.Operations import Data.List (intercalate, sort, union) @@ -184,7 +184,7 @@ unusedRegion srcSpan var = SCWarn $ UnusedRegion srcSpan var specOkay :: FU.SrcSpan -> Specification -> Variable -> FU.SrcSpan -> StencilResult -specOkay spanSpec@(FU.SrcSpan (FU.Position o1 _ _) (FU.Position o2 _ _)) spec var spanBody@(FU.SrcSpan (FU.Position o1' _ _) (FU.Position o2' _ _)) = +specOkay spanSpec@(FU.SrcSpan (FU.Position o1 _ _ _ _) (FU.Position o2 _ _ _ _)) spec var spanBody@(FU.SrcSpan (FU.Position o1' _ _ _ _) (FU.Position o2' _ _ _ _)) = SCOkay { scSpan = spanSpec , scSpec = spec , scBodySpan = spanBody @@ -252,7 +252,7 @@ -- create graph of definition "flows" flowsGraph = FAD.genFlowsToGraph bm dm gr rd -- identify every loop by its back-edge - beMap = FAD.genBackEdgeMap (FAD.dominators gr) gr + beMap = FAD.genBackEdgeMap (FAD.dominators gr) $ FA.bbgrGr gr ivmap = FAD.genInductionVarMapByASTBlock beMap gr -- results :: Checker (F.ProgramFile (F.ProgramFile (FA.Analysis A))) results = descendBiM perProgramUnitCheck pf' @@ -288,7 +288,7 @@ -- | Start tracking a region. addRegionToTracked :: FU.SrcSpan -> Variable -> Checker () -addRegionToTracked srcSpan@(FU.SrcSpan (FU.Position o1 _ _) (FU.Position o2 _ _)) r = +addRegionToTracked srcSpan@(FU.SrcSpan (FU.Position o1 _ _ _ _) (FU.Position o2 _ _ _ _)) r = modify (\s -> s { regions = (srcSpan, r) : regions s }) -- | True if the region name is already tracked. diff --git a/src/Camfort/Specification/Stencils/Generate.hs b/src/Camfort/Specification/Stencils/Generate.hs --- a/src/Camfort/Specification/Stencils/Generate.hs +++ b/src/Camfort/Specification/Stencils/Generate.hs @@ -17,11 +17,9 @@ ( EvalLog , Neighbour(..) - , convIxToNeighbour , extractRelevantIVS , genOffsets , genSpecifications - , indicesToSpec , isArraySubscript , neighbourIndex , runStencilInferer @@ -37,7 +35,7 @@ import Control.Monad (void, when, zipWithM) import Control.Monad.State.Strict (State, get, put, runState) -import Control.Monad.Writer.Strict (WriterT, runWriterT, tell) +import Control.Monad.Writer.CPS (WriterT, runWriterT, tell) import Control.Monad.Reader (ReaderT, runReaderT, asks) import Data.Data (Data) import Data.Foldable (foldrM) @@ -310,15 +308,37 @@ expToNeighbour _ (F.ExpValue _ _ val) = Constant (void val) +-- use constant-expression analysis if available expToNeighbour ivs (F.ExpBinary _ _ F.Addition + e1@(F.ExpValue _ _ (F.ValVariable _)) + e2) + | FA.varName e1 `elem` ivs + , Just (FAD.ConstInt offs) <- FA.constExp (F.getAnnotation e2) = Neighbour (FA.varName e1) (fromIntegral offs) + +expToNeighbour ivs (F.ExpBinary _ _ F.Addition e@(F.ExpValue _ _ (F.ValVariable _)) (F.ExpValue _ _ (F.ValInteger offs))) | FA.varName e `elem` ivs = Neighbour (FA.varName e) (read offs) +-- use constant-expression analysis if available expToNeighbour ivs (F.ExpBinary _ _ F.Addition + e1@(F.ExpValue _ _ (F.ValVariable _)) + e2) + | FA.varName e1 `elem` ivs + , Just (FAD.ConstInt offs) <- FA.constExp (F.getAnnotation e2) = Neighbour (FA.varName e1) (fromIntegral offs) + +expToNeighbour ivs (F.ExpBinary _ _ F.Addition (F.ExpValue _ _ (F.ValInteger offs)) e@(F.ExpValue _ _ (F.ValVariable _))) | FA.varName e `elem` ivs = Neighbour (FA.varName e) (read offs) + +-- use constant-expression analysis if available +expToNeighbour ivs (F.ExpBinary _ _ F.Subtraction + e1@(F.ExpValue _ _ (F.ValVariable _)) + e2) + | FA.varName e1 `elem` ivs + , Just (FAD.ConstInt offs) <- FA.constExp (F.getAnnotation e2) + , offs' <- if offs < 0 then abs offs else (- offs) = Neighbour (FA.varName e1) (fromIntegral offs') expToNeighbour ivs (F.ExpBinary _ _ F.Subtraction e@(F.ExpValue _ _ (F.ValVariable _)) diff --git a/src/Camfort/Specification/Stencils/InferenceFrontend.hs b/src/Camfort/Specification/Stencils/InferenceFrontend.hs --- a/src/Camfort/Specification/Stencils/InferenceFrontend.hs +++ b/src/Camfort/Specification/Stencils/InferenceFrontend.hs @@ -29,8 +29,8 @@ , StencilsReport(..) ) where -import Control.Monad.RWS.Strict -import Control.Monad.Writer.Strict +import Control.Monad.RWS.CPS +import Control.Monad.Writer.CPS import Camfort.Analysis import Camfort.Analysis.Annotations @@ -209,7 +209,7 @@ flTo = FAD.genFlowsToGraph bm dm gr rd -- induction variable map - beMap = FAD.genBackEdgeMap (FAD.dominators gr) gr + beMap = FAD.genBackEdgeMap (FAD.dominators gr) $ FA.bbgrGr gr -- identify every loop by its back-edge ivMap = FAD.genInductionVarMapByASTBlock beMap gr diff --git a/src/Camfort/Specification/Stencils/Model.hs b/src/Camfort/Specification/Stencils/Model.hs --- a/src/Camfort/Specification/Stencils/Model.hs +++ b/src/Camfort/Specification/Stencils/Model.hs @@ -61,7 +61,7 @@ import Data.Data import Data.List (sortBy, nub) import Data.Maybe (fromJust) -import qualified Data.PartialOrd as PO +import qualified Camfort.Specification.Stencils.PartialOrd as PO import qualified Camfort.Helpers.Vec as V import System.IO.Unsafe diff --git a/src/Camfort/Specification/Stencils/PartialOrd.hs b/src/Camfort/Specification/Stencils/PartialOrd.hs new file mode 100644 --- /dev/null +++ b/src/Camfort/Specification/Stencils/PartialOrd.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} + +{-| +Module : Data.PartialOrd +Description : Provides the PartialOrd Typeclass. +Copyright : (c) 2016 Moritz Schulte +License : BSD3 +Maintainer : mtesseract@silverratio.net +Stability : experimental +Portability : POSIX + +This module provides the `PartialOrd' typeclass suitable for types +admitting a partial order. + +Along with the `PartialOrd' typeclass and some utility functions for +working with partially ordered types, it exports implementations for +the numeric types several numeric types, lists and sets. +-} + +-- Code imported into camfort to avoid build-dependency hell with +-- unmaintained upstream package. + +module Camfort.Specification.Stencils.PartialOrd + ( PartialOrd(..) + , maxima, minima + , elem, notElem + , nub ) where + +import Data.Bool +import Data.Maybe +import Prelude (Int, Integer, Float, Double, ($), Integral) +import qualified Data.Ord as Ord +import qualified Data.Eq as Eq +import qualified Data.List as List +import qualified Data.Set as Set +import qualified Data.Foldable as Foldable + +class PartialOrd a where + + -- | Less-than-or-equal relation. + (<=) :: a -> a -> Bool + + -- | Bigger-than-or-equal relation. Defined in terms of `<='. + (>=) :: a -> a -> Bool + a >= a' = a' <= a + + -- | Equality relation. Defined in terms of `<='. + (==) :: a -> a -> Bool + a == a' = a <= a' && a' <= a + + -- | Inequality relation. Defined in terms of `=='. + (/=) :: a -> a -> Bool + a /= a' = not (a == a') + + -- | Less-than relation relation. Defined in terms of `<=' and `/='. + (<) :: a -> a -> Bool + a < a' = a <= a' && (a /= a') + + -- | Bigger-than relation. Defined in terms of `<=` and `/='. + (>) :: a -> a -> Bool + a > a' = a' <= a && (a /= a') + + -- | Compare function, returning either `Just' an `Ordering' or + -- `Nothing'. + compare :: a -> a -> Maybe Ord.Ordering + compare a a' = if | a == a' -> Just Ord.EQ + | a <= a' -> Just Ord.LT + | a >= a' -> Just Ord.GT + | otherwise -> Nothing + + {-# MINIMAL (<=) #-} + +-- | Derive the partial order from the total order for the following +-- types: +instance PartialOrd Int where + (<=) = (Ord.<=) + +instance PartialOrd Integer where + (<=) = (Ord.<=) + +instance PartialOrd Double where + (<=) = (Ord.<=) + +instance PartialOrd Float where + (<=) = (Ord.<=) + +-- | Define the partial order in terms of the subset relation. +instance (Ord.Ord a) => PartialOrd (Set.Set a) where + (<=) = Set.isSubsetOf + +-- | Define the partial order in terms of the sublist relation. +instance PartialOrd a => PartialOrd [a] where + (<=) = isSublistOf + +-- | Return True if the first list is a sublist of the second list. +isSublistOf :: PartialOrd a => [a] -> [a] -> Bool +isSublistOf [] _ = True +isSublistOf (a:as) a' = a `elem` a' && as `isSublistOf` a' + +-- | Compute the list of all elements that are not less than any other +-- element in the list. +maxima :: PartialOrd a => [a] -> [a] +maxima as = nub $ extrema (<=) as + +-- | Compute the list of all elements that are not bigger than any +-- other element in the list. +minima :: PartialOrd a => [a] -> [a] +minima as = nub $ extrema (>=) as + +extrema :: PartialOrd a => (a -> a -> Bool) -> [a] -> [a] +extrema f as = List.filter isExtremal as + where isExtremal a = + -- Return true if there exists no a' in as \ {a} such that + -- a `f` a'. + let as' = List.filter (/= a) as + in not (Foldable.any (a `f`) as') + +-- | Version of the traditional elem function using the PartialOrd +-- notion of equality. +elem :: (PartialOrd a, Foldable.Foldable t) => a -> t a -> Bool +elem x xs = Foldable.any (x ==) xs + +-- | Version of the traditional notElem function using the PartialOrd +-- notion of equality. +notElem :: (PartialOrd a, Foldable.Foldable t) => a -> t a -> Bool +notElem x xs = not $ elem x xs + +-- | Version of the traditional nub function using the PartialOrd +-- notion of equality. +nub :: PartialOrd a => [a] -> [a] +nub as = List.reverse $ Foldable.foldl' collect [] as + where collect uniques a = + if a `elem` uniques + then uniques + else a : uniques diff --git a/src/Camfort/Specification/Stencils/Synthesis.hs b/src/Camfort/Specification/Stencils/Synthesis.hs --- a/src/Camfort/Specification/Stencils/Synthesis.hs +++ b/src/Camfort/Specification/Stencils/Synthesis.hs @@ -74,7 +74,7 @@ ------------------------ a = (head $ FA.initAnalysis [unitAnnotation]) { FA.insLabel = Just 0 } -s = SrcSpan (Position 0 0 0) (Position 0 0 0) +s = SrcSpan (Position 0 0 0 "" Nothing) (Position 0 0 0 "" Nothing) -- Make indexing expression for variable 'v' from an offset. -- essentially inverse to `ixToOffset` in StencilSpecification diff --git a/src/Camfort/Specification/Units/Analysis.hs b/src/Camfort/Specification/Units/Analysis.hs --- a/src/Camfort/Specification/Units/Analysis.hs +++ b/src/Camfort/Specification/Units/Analysis.hs @@ -23,7 +23,7 @@ import Control.Monad import Control.Monad.State.Strict -import Control.Monad.Writer.Strict +import Control.Monad.Writer.CPS import Control.Monad.Reader import Data.Data (Data) import qualified Data.IntMap.Strict as IM @@ -31,16 +31,17 @@ import Data.List (nub, intercalate) import qualified Data.Array as A import qualified Data.Map.Strict as M -import Data.Maybe (isJust, fromMaybe) +import Data.Maybe (isJust, fromMaybe, mapMaybe) import qualified Data.Set as S import qualified Numeric.LinearAlgebra as H -- for debugging import Data.Text (Text) import Control.Lens ((^?), _1) -import qualified Debug.Trace as D import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA -import Language.Fortran.Analysis (varName, srcName) +import qualified Language.Fortran.Analysis.DataFlow as FAD +import qualified Language.Fortran.Analysis.BBlocks as FAB +import Language.Fortran.Analysis (constExp, varName, srcName) import Language.Fortran.Parser.Utils (readReal, readInteger) import Language.Fortran.Util.ModFile import Language.Fortran.Util.Position (getSpan) @@ -133,8 +134,9 @@ mfs <- lift analysisModFiles let (pf', _, _) = withCombinedEnvironment mfs . fmap UA.mkUnitAnnotation $ pf - - runUnitSolver pf' $ do + let pvm = combinedParamVarMap mfs + let pf'' = FAD.analyseConstExps . FAD.analyseParameterVars pvm . FAB.analyseBBlocks $ pf' + runUnitSolver pf'' $ do initializeModFiles initInference solver @@ -183,7 +185,9 @@ -- Specifically handle variables insertUndeterminedUnitVar :: DeclMap -> F.Expression UA -> UnitSolver (F.Expression UA) -insertUndeterminedUnitVar dmap v@(F.ExpValue _ _ (F.ValVariable _)) = do +insertUndeterminedUnitVar dmap v@(F.ExpValue _ _ (F.ValVariable _)) + | Just (FA.IDType { FA.idVType = Just bty }) <- FA.idType (F.getAnnotation v) + , bty `elem` acceptableTypes = do let vname = varName v let sname = srcName v let unit = toUnitVar dmap (vname, sname) @@ -200,6 +204,10 @@ Just (DCSubroutine (F.Named fvname, F.Named fsname)) -> UnitParamVarAbs ((fvname, fsname), (vname, sname)) _ -> UnitVar (vname, sname) +-- Insert undetermined units annotations on the following types of variables. +acceptableTypes :: [F.BaseType] +acceptableTypes = [F.TypeReal, F.TypeDoublePrecision, F.TypeComplex, F.TypeDoubleComplex, F.TypeInteger] + -------------------------------------------------- -- | Convert explicit polymorphic annotations such as (UnitName "'a") @@ -286,8 +294,11 @@ annotateAllVariables :: UnitSolver () annotateAllVariables = modifyProgramFileM $ \ pf -> do varUnitMap <- getVarUnitMap + importedVariables <- getImportedVariables + let varUnitMap' = M.unionWith (curry snd) varUnitMap importedVariables + let annotateExp e@(F.ExpValue _ _ (F.ValVariable _)) - | Just info <- M.lookup (varName e, srcName e) varUnitMap = UA.setUnitInfo info e + | Just info <- M.lookup (varName e, srcName e) varUnitMap' = UA.setUnitInfo info e -- may need to annotate intrinsics separately annotateExp e = e pure $ transformBi annotateExp pf @@ -314,13 +325,33 @@ -- Follow the LitMixed rules. expMixed e = case e of F.ExpValue _ _ (F.ValInteger i) | readInteger i == Just 0 -> withLiterals genParamLit e - | isPolyCtxt -> expUnitless e | otherwise -> withLiterals genUnitLiteral e F.ExpValue _ _ (F.ValReal i) | readReal i == Just 0 -> withLiterals genParamLit e - | isPolyCtxt -> expUnitless e | otherwise -> withLiterals genUnitLiteral e - _ -> pure e + F.ExpBinary a s op e1 e2 + | op `elem` [F.Multiplication, F.Division] -> case () of + -- leave it alone if they're both constants + _ | Just c1 <- constExp (F.getAnnotation e1) + , Just c2 <- constExp (F.getAnnotation e2) -> pure e + -- a constant multiplier is unitless + _ | Just c1 <- constExp (F.getAnnotation e1) + , Just UnitLiteral{} <- UA.getUnitInfo e1 -> + pure $ F.ExpBinary a s op (UA.setUnitInfo UnitlessLit e1) e2 + -- a constant multiplier is unitless + | Just c2 <- constExp (F.getAnnotation e2) + , Just UnitLiteral{} <- UA.getUnitInfo e2 -> + pure $ F.ExpBinary a s op e1 (UA.setUnitInfo UnitlessLit e2) + _ -> pure e + + _ | Just _ <- constExp (F.getAnnotation e) -> case UA.getUnitInfo e of + -- Treat constant expressions as if they were fresh + -- literals, unless assigned units already. + Just UnitLiteral{} -> genLit e + Just UnitVar{} -> genLit e + _ -> pure e + | otherwise -> pure e + -- Set all literals to unitless. expUnitless e | isLiteral e = pure $ UA.setUnitInfo UnitlessLit e @@ -333,22 +364,40 @@ isPolyCtxt = case pu of F.PUFunction {} -> True; F.PUSubroutine {} -> True; _ -> False + genLit e + | isLiteralZero e = withLiterals genParamLit e + | otherwise = withLiterals genUnitLiteral e + -- | Is it a literal, literally? isLiteral :: F.Expression UA -> Bool isLiteral (F.ExpValue _ _ (F.ValReal _)) = True isLiteral (F.ExpValue _ _ (F.ValInteger _)) = True -isLiteral _ = False +-- allow propagated constants to be interpreted as literals +isLiteral e = isJust (constExp (F.getAnnotation e)) --- | Is expression a literal and is it zero? +-- | Is expression a literal and is it non-zero? isLiteralNonZero :: F.Expression UA -> Bool isLiteralNonZero (F.ExpValue _ _ (F.ValInteger i)) = readInteger i /= Just 0 isLiteralNonZero (F.ExpValue _ _ (F.ValReal i)) = readReal i /= Just 0 -isLiteralNonZero _ = False +-- allow propagated constants to be interpreted as literals +isLiteralNonZero e = case constExp (F.getAnnotation e) of + Just (FA.ConstInt i) -> i /= 0 + Just (FA.ConstUninterpInt s) -> readInteger s /= Just 0 + Just (FA.ConstUninterpReal s) -> readReal s /= Just 0 + _ -> False -isLiteralZero = not . isLiteralNonZero +isLiteralZero x = isLiteral x && not (isLiteralNonZero x) -------------------------------------------------- +-- | Filter out redundant constraints. +cullRedundant :: Constraints -> Constraints +cullRedundant = nub . mapMaybe ( \ con -> case con of + ConEq u1 u2 | u1 /= u2 -> Just con + ConConj cs | cs' <- cullRedundant cs, not (null cs) -> Just (ConConj cs') + _ -> Nothing + ) + -- | Convert all parametric templates into actual uses, via substitution. applyTemplates :: Constraints -> UnitSolver Constraints -- postcondition: returned constraints lack all Parametric constructors @@ -369,9 +418,15 @@ logDebug' pf $ ("instances: " <> describeShow instances) logDebug' pf $ ("dummies: " <> describeShow dummies) + importedVariables <- getImportedVariables + + -- Prepare constraints for all variables imported via StUse. + let importedCons = [ ConEq (UnitVar vv) units | (vv, units) <- M.toList importedVariables ] + -- Work through the instances, expanding their templates, and -- substituting the callId into the abstract parameters. - concreteCons <- liftM2 (++) (foldM (substInstance False []) [] instances) + concreteCons <- cullRedundant <$> + liftM2 (++) (foldM (substInstance False []) importedCons instances) (foldM (substInstance True []) [] dummies) dumpConsM "applyTemplates: concreteCons" concreteCons @@ -384,7 +439,7 @@ transAlias u = u dumpConsM "aliases" aliases - pure . transformBi transAlias $ cons ++ concreteCons ++ aliases + pure . transformBi transAlias . cullRedundant $ cons ++ concreteCons ++ aliases -- | Look up the Parametric templates for a given function or -- subroutine, and do the substitutions. Process any additional @@ -424,11 +479,6 @@ dumpConsM ("instantiating " ++ show (name, callId) ++ ": (output ++ template) is") (output ++ template) dumpConsM ("instantiating " ++ show (name, callId) ++ ": (template') is") template' - -- Get constraints for any imported variables - let filterForVars (NPKVariable _) _ = True; filterForVars _ _ = False - nmap <- M.filterWithKey filterForVars <$> getNameParamMap - let importedVariables = [ ConEq (UnitVar vv) (foldUnits units) | (NPKVariable vv, units) <- M.toList nmap ] - -- Convert abstract parametric units into concrete ones. let output' = -- Do not instantiate explicitly annotated polymorphic @@ -438,10 +488,7 @@ -- Only instantiate explicitly annotated polymorphic -- variables from nested function/subroutine calls. - instantiate callId template' ++ - - -- any imported variables - importedVariables + instantiate callId template' dumpConsM ("final output for " ++ show (name, callId)) output' @@ -527,7 +574,8 @@ -- that variables have all been annotated. propagateUnits :: UnitSolver () -- precondition: all variables have already been annotated -propagateUnits = modifyProgramFileM $ transformBiM propagatePU <=< +propagateUnits = modifyProgramFileM $ transformBiM propagateInterface <=< + transformBiM propagatePU <=< transformBiM propagateDoSpec <=< transformBiM propagateStatement <=< transformBiM propagateExp @@ -543,6 +591,7 @@ F.ExpFunctionCall {} -> propagateFunctionCall e F.ExpSubscript _ _ e1 _ -> pure $ UA.maybeSetUnitInfo (UA.getUnitInfo e1) e F.ExpUnary _ _ _ e1 -> pure $ UA.maybeSetUnitInfo (UA.getUnitInfo e1) e + F.ExpInitialisation{} -> pure e _ -> do logDebug' e $ "progagateExp: unhandled " <> describeShow e pure e @@ -576,6 +625,11 @@ , do u1 <- UA.getUnitInfo e1 u3 <- (UA.getUnitInfo =<< m_e3) `mplus` if isMonomorphic u1 then mzero else pure UnitlessVar pure [ConEq u1 u3] + + -- units(e2) ~ units(e3) or if e3 not specified then units(e2) ~ 1 in a polymorphic context + , do u2 <- UA.getUnitInfo e1 + u3 <- (UA.getUnitInfo =<< m_e3) `mplus` if isMonomorphic u2 then mzero else pure UnitlessVar + pure [ConEq u2 u3] ] propagateStatement :: F.Statement UA -> UnitSolver (F.Statement UA) @@ -600,13 +654,30 @@ => F.Expression UA -> F.Expression UA -> f UA -> UnitSolver (f UA) literalAssignmentSpecialCase e1 e2 ast + | isLiteralZero e2 = pure ast | isLiteral e2 - , Just u1 <- UA.getUnitInfo e1 - , Just u2 <- UA.getUnitInfo e2 - , isMonomorphic u1 || isLiteralZero e2 = pure ast + , Just u1 <- UA.getUnitInfo e1 + , Just UnitLiteral{} <- UA.getUnitInfo e2 + , isMonomorphic u1 = pure ast -- otherwise express the constraint between LHS and RHS of assignment. | otherwise = pure $ UA.maybeSetUnitConstraintF2 ConEq (UA.getUnitInfo e1) (UA.getUnitInfo e2) ast +-- Generic Interface template mapping will be same as first module procedure. +propagateInterface :: F.Block UA -> UnitSolver (F.Block UA) +propagateInterface b@(F.BlInterface _ _ (Just e) _ _ bs) = do + let iname = varName e + case [ varName e1 | F.StModuleProcedure _ _ (F.AList _ _ (e1:_)) <- universeBi bs :: [F.Statement UA] ] of + mpname:_ -> do + -- translate any instance of mpname into iname within the template + let trans = transformBi (\ x -> if x == mpname then iname else x) + -- copy (translated) template from first module procedure to interface + modifyTemplateMap $ \ m -> fromMaybe m ((\ t -> M.insert iname (trans t) m) <$> M.lookup mpname m) + _ -> + pure () + pure b + +propagateInterface b = pure b + propagatePU :: F.ProgramUnit UA -> UnitSolver (F.ProgramUnit UA) propagatePU pu = do let name = puName pu @@ -768,6 +839,31 @@ binOpKind F.NotEquivalent = RelOp binOpKind (F.BinCustom _) = RelOp +-- | Get information about imported variables coming from mod files. +getImportedVariables :: UnitSolver (M.Map VV UnitInfo) +getImportedVariables = do + pf <- getProgramFile + nmap <- getNameParamMap + -- Translate a Use AST node into a pair mapping unique name to 'local' source name in this program file. + let useToPair (F.UseID _ _ e) = (varName e, srcName e) + useToPair (F.UseRename _ _ e1 e2) = (varName e1, srcName e1) -- (unique name, 'local' source name) + -- A map of modules -> (maps of variables -> their unit info). + let modnmaps = [ M.fromList (mapMaybe f (M.toList npkmap)) + -- find all StUse statements and identify variables that need to be imported from nmap + | F.StUse _ _ e _ only alist <- universeBi pf :: [ F.Statement UA ] + , let mod = srcName e + , let uses = map useToPair (fromMaybe [] (F.aStrip <$> alist)) + , Just npkmap <- [M.lookup (F.Named mod) nmap] + , let f (npk, ui) = case npk of + (NPKVariable (var, src)) + -- import all variables from module -- apply any renames from uses + | only == F.Permissive -> Just (NPKVariable (var, src `fromMaybe` lookup var uses), ui) + -- only import variable mentioned in uses + | Just src' <- lookup var uses -> Just (NPKVariable (var, src'), ui) + _ -> Nothing + ] + pure $ M.fromList [ (vv, foldUnits units) | (NPKVariable vv, units) <- M.toList (M.unions modnmaps) ] + -------------------------------------------------- logDebugNoOrigin :: Text -> UnitSolver () @@ -838,7 +934,10 @@ logDebugNoOrigin "--------------------------------------------------" let unitAssignments = BackendSBV.genUnitAssignments cons logDebugNoOrigin . describe . unlines $ map (\ (u1s, u2) -> " ***UnitAssignmentSBV: " ++ show u1s ++ " === " ++ show (flattenUnits u2)) unitAssignments - logDebugNoOrigin "--------------------------------------------------" + logDebugNoOrigin "--------------------------------------------------\nProvenance:" + let (augM', p) = provenance augM + logDebugNoOrigin . describeShow $ augM' + logDebugNoOrigin . describeShow $ p -------------------------------------------------- diff --git a/src/Camfort/Specification/Units/Analysis/Consistent.hs b/src/Camfort/Specification/Units/Analysis/Consistent.hs --- a/src/Camfort/Specification/Units/Analysis/Consistent.hs +++ b/src/Camfort/Specification/Units/Analysis/Consistent.hs @@ -30,7 +30,7 @@ import Camfort.Specification.Units.Analysis (UnitAnalysis, runInference) import qualified Camfort.Specification.Units.Annotation as UA import Camfort.Specification.Units.Environment -import Camfort.Specification.Units.InferenceBackendSBV (inconsistentConstraints) +import Camfort.Specification.Units.InferenceBackend (inconsistentConstraints) import qualified Camfort.Specification.Units.InferenceBackend as MatrixBackend import Camfort.Specification.Units.Monad import Camfort.Specification.Units.MonadTypes diff --git a/src/Camfort/Specification/Units/Analysis/Infer.hs b/src/Camfort/Specification/Units/Analysis/Infer.hs --- a/src/Camfort/Specification/Units/Analysis/Infer.hs +++ b/src/Camfort/Specification/Units/Analysis/Infer.hs @@ -12,7 +12,7 @@ {-# LANGUAGE DeriveGeneric #-} module Camfort.Specification.Units.Analysis.Infer - ( InferenceReport + ( InferenceReport(..) , InferenceResult(..) , getInferred , inferUnits diff --git a/src/Camfort/Specification/Units/Environment.hs b/src/Camfort/Specification/Units/Environment.hs --- a/src/Camfort/Specification/Units/Environment.hs +++ b/src/Camfort/Specification/Units/Environment.hs @@ -49,6 +49,8 @@ import GHC.Generics (Generic) import Text.Printf import Control.Arrow (first, second) +import Text.PrettyPrint.GenericPretty (pp, pretty, Out, doc, docPrec) +import Text.PrettyPrint (text) import qualified Language.Fortran.AST as F import qualified Camfort.Specification.Units.Parser.Types as P @@ -196,6 +198,10 @@ | otherwise = "(" ++ s ++ ")" where s = show x isUnitMulOk c = isSpace c || isAlphaNum c || c `elem` "*." + +instance Out UnitInfo where + doc = text . show + docPrec _ = text . show -- Converts doubles to a rational that can be expressed -- as a rational with denominator at most 10 diff --git a/src/Camfort/Specification/Units/InferenceBackend.hs b/src/Camfort/Specification/Units/InferenceBackend.hs --- a/src/Camfort/Specification/Units/InferenceBackend.hs +++ b/src/Camfort/Specification/Units/InferenceBackend.hs @@ -35,23 +35,29 @@ , rref , genUnitAssignments , genUnitAssignments' + , provenance + , splitNormHNF ) where - import Prelude hiding ((<>)) +import Control.Arrow (first, second, (***)) import Control.Monad import Control.Monad.ST +import Control.Parallel +import Control.Parallel.Strategies import qualified Data.Array as A import Data.Generics.Uniplate.Operations (transformBi, universeBi) import Data.List - ((\\), findIndex, inits, nub, partition, sortBy, group, tails) + ((\\), findIndex, inits, nub, partition, sort, sortBy, group, tails, foldl') import Data.Ord import qualified Data.Map.Strict as M +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS import Data.Maybe (fromMaybe, mapMaybe) import Data.Tuple (swap) import Numeric.LinearAlgebra ( atIndex, (<>), (><) - , rank, (?) + , rank, (?), (¿) , rows, cols , subMatrix, diag , fromBlocks, ident @@ -62,6 +68,7 @@ , writeMatrix, runSTMatrix , freezeMatrix, STMatrix ) +import Data.Graph.Inductive hiding ((><)) import Camfort.Specification.Units.Environment import qualified Camfort.Specification.Units.InferenceBackendFlint as Flint @@ -77,24 +84,79 @@ [ (var, units) | ([UnitPow (UnitVar var) k], units) <- unitAssignments, k `approxEq` 1 ] ++ [ (var, units) | ([UnitPow (UnitParamVarAbs (_, var)) k], units) <- unitAssignments, k `approxEq` 1 ] --- detect inconsistency if concrete units are assigned an implicit --- abstract unit variable with coefficients not equal -detectInconsistency :: [([UnitInfo], UnitInfo)] -> [([UnitInfo], UnitInfo)] -detectInconsistency unitAssignments = [ fmap foldUnits a | a@([UnitPow (UnitParamImpAbs _) k1], rhs) <- ua' - , UnitPow _ k2 <- rhs - , k1 /= k2 ] +-- Detect inconsistency if concrete units are assigned an implicit +-- abstract unit variable with coefficients not equal, or there are +-- monomorphic literals being given parametric polymorphic units. +detectInconsistency :: [([UnitInfo], UnitInfo)] -> Constraints +detectInconsistency unitAssignments = inconsist where ua' = map (shiftTerms . fmap flattenUnits) unitAssignments + badImplicits = [ fmap foldUnits a | a@([UnitPow (UnitParamImpAbs _) k1], rhs) <- ua' + , UnitPow _ k2 <- rhs + , k1 /= k2 ] + inconsist = unitAssignmentsToConstraints badImplicits ++ mustBeUnitless unitAssignments +-- Must be unitless: any assignments of parametric abstract units to +-- monomorphic literals. +mustBeUnitless :: [([UnitInfo], UnitInfo)] -> Constraints +mustBeUnitless unitAssignments = mbu + where + mbu = [ ConEq UnitlessLit (UnitPow (UnitLiteral l) k) + | a@(UnitPow (UnitLiteral l) k:_, rhs) <- ua'' + , any isParametric (universeBi rhs :: [UnitInfo]) ] + ua' = map (shiftTerms . fmap flattenUnits) unitAssignments + ua'' = map (shiftTermsBy isLiteral . fmap flattenUnits) unitAssignments + + isLiteral UnitLiteral{} = True + isLiteral (UnitPow UnitLiteral{} _) = True + isLiteral _ = False + + isParametric UnitParamVarAbs{} = True + isParametric UnitParamPosAbs{} = True + isParametric UnitParamEAPAbs{} = True + isParametric UnitParamLitAbs{} = True + isParametric UnitParamImpAbs{} = True + isParametric (UnitPow u _) = isParametric u + isParametric _ = False + + +-- convert the assignment format back into constraints +unitAssignmentsToConstraints :: [([UnitInfo], UnitInfo)] -> Constraints +unitAssignmentsToConstraints = map (uncurry ConEq . first foldUnits) + -- | Raw units-assignment pairs. -genUnitAssignments :: [Constraint] -> [([UnitInfo], UnitInfo)] +genUnitAssignments :: Constraints -> [([UnitInfo], UnitInfo)] genUnitAssignments cons - | null (detectInconsistency ua) = ua - | otherwise = [] + -- if the results include any mappings that must be forced to be unitless... + | mbu <- mustBeUnitless ua, not (null mbu) = genUnitAssignments (mbu ++ unitAssignmentsToConstraints ua) + | null (detectInconsistency ua) = ua + | otherwise = [] where ua = genUnitAssignments' colSort cons -genUnitAssignments' :: SortFn -> [Constraint] -> [([UnitInfo], UnitInfo)] +-- | Break up the problem of solving normHNF on each group of related +-- columns, then bring it all back together. +splitNormHNF :: H.Matrix Double -> (H.Matrix Double, [Int]) +splitNormHNF unsolvedM = (combinedMat, allNewColIndices) + where + combinedMat = joinMat (map (first fst) solvedMs) + allNewColIndices = concatMap (snd . fst) solvedMs + + inParallel = (`using` parTuple2 (parList rseq) rseq) + (solvedMs, _) = inParallel . foldl' eachResult ([], cols unsolvedM) $ map (first Flint.normHNF) (splitMat unsolvedM) + + -- for each result re-number the generated columns & add mappings for each. + eachResult (ms, startI) ((m, newColIndices), origCols) = (((m, newColIndices'), origCols'):ms, endI) + where + -- produce (length newColIndices) number of mappings + endI = startI + length newColIndices + -- re-number the newColIndices according to the lookup list + newColIndices' = map (origCols !!) newColIndices + -- add columns in the (combined) matrix for the newly + -- generated columns from running normHNF on m. + origCols' = origCols ++ [startI .. endI-1] + +genUnitAssignments' :: SortFn -> Constraints -> [([UnitInfo], UnitInfo)] genUnitAssignments' _ [] = [] genUnitAssignments' sortfn cons | null colList = [] @@ -105,8 +167,7 @@ unsolvedM | rows rhsM == 0 || cols rhsM == 0 = lhsM | rows lhsM == 0 || cols lhsM == 0 = rhsM | otherwise = fromBlocks [[lhsM, rhsM]] - - (solvedM, newColIndices) = Flint.normHNF unsolvedM + (solvedM, newColIndices) = splitNormHNF unsolvedM -- solvedM can have additional columns and rows from normHNF; -- cosolvedM corresponds to the original lhsM. cosolvedM = subMatrix (0, 0) (rows solvedM, cols lhsM) solvedM @@ -148,10 +209,109 @@ -------------------------------------------------- approxEq a b = abs (b - a) < epsilon +notApproxEq a b = not (approxEq a b) epsilon = 0.001 -- arbitrary -------------------------------------------------- +type RowNum = Int -- ^ 'row number' of matrix +type ColNum = Int -- ^ 'column number' of matrix +-- | Represents a subproblem of AX=B where the row numbers and column +-- numbers help you re-map back to the original problem. +type Subproblem = ([RowNum], (H.Matrix Double, H.Matrix Double), [ColNum]) + +-- | Divide up the AX=B problem into smaller problems based on the +-- 'related columns' and their corresponding rows in the +-- right-hand-side of the equation. Where lhsM = A and rhsM = B. The +-- resulting list of subproblems contains the new, smaller As and Bs +-- as well as a list of original row numbers and column numbers to +-- aide re-mapping back to the original lhsM and rhsM. +splitMatWithRHS :: H.Matrix Double -> H.Matrix Double -> [Subproblem] +splitMatWithRHS lhsM rhsM | cols lhsM > 0 = map (eachComponent . sort) $ scc (relatedColumnsGraph lhsM) + | otherwise = [] + where + -- Gets called on every strongly-connected component / related set of columns. + eachComponent cs = (rs, mats, cs) + where + -- Selected columns + lhsSelCols :: H.Matrix Double + lhsSelCols = lhsM ¿ cs + + csLen = cols lhsSelCols + + -- Find the row numbers of the 'all zero' rows in lhsM. + lhsAllZeroRows :: [RowNum] + lhsAllZeroRows = map fst . filter (all (approxEq 0) . snd) . zip [0..] $ H.toLists lhsM + + -- Find the row numbers that correspond to the non-zero co-efficients in the selected columns. + lhsNonZeroColRows :: [(RowNum, [Double])] + lhsNonZeroColRows = filter (any (notApproxEq 0) . snd) . zip [0..] . H.toLists $ lhsSelCols + + -- List of all the row numbers and row values combined from the two above variables. + lhsNumberedRows :: [(RowNum, [Double])] + lhsNumberedRows = sortBy (comparing fst) $ lhsNonZeroColRows ++ zip lhsAllZeroRows (repeat (replicate csLen 0)) + + -- For each of the above LHS rows find a corresponding RHS row. + rhsSelRows :: [[Double]] + rhsSelRows | rows rhsM > 0 = H.toLists (rhsM ? map fst lhsNumberedRows) + | otherwise = [] + + reassoc (a, b) c = (a, (b, c)) + + notAllZero (_, (lhs, rhs)) = any (notApproxEq 0) (lhs ++ rhs) + + -- Zip the selected LHS, RHS rows together, filter out any that are all zeroes. + numberedRows :: ([RowNum], [([Double], [Double])]) + numberedRows = unzip . filter notAllZero $ zipWith reassoc lhsNumberedRows rhsSelRows + + rs :: [RowNum] -- list of row numbers in the subproblem + mats :: (H.Matrix Double, H.Matrix Double) -- LHS/RHS subproblem matrices + (rs, mats) = second ((H.fromLists *** H.fromLists) . unzip) numberedRows + +-- | Split the lhsM/rhsM problem into subproblems and then look for +-- inconsistent rows in each subproblem, concatenating all of the +-- inconsistent row numbers found (in terms of the rows of the +-- original lhsM). +splitFindInconsistentRows :: H.Matrix Double -> H.Matrix Double -> [RowNum] +splitFindInconsistentRows lhsM rhsM = concatMap eachComponent $ splitMatWithRHS lhsM rhsM + where + eachComponent (rs, (lhsM, rhsM), _) = map (rs !!) $ findInconsistentRows lhsM augM + where + -- Augmented matrix is defined as the combined LHS/RHS matrices. + augM + | rows rhsM == 0 || cols rhsM == 0 = lhsM + | rows lhsM == 0 || cols lhsM == 0 = rhsM + | otherwise = fromBlocks [[lhsM, rhsM]] + +-- | Break out the 'unrelated' columns in a single matrix into +-- separate matrices, along with a list of their original column +-- positions. +splitMat :: H.Matrix Double -> [(H.Matrix Double, [ColNum])] +splitMat m = map (eachComponent . sort) $ scc (relatedColumnsGraph m) + where + eachComponent cs = (H.fromLists . filter (any (/= 0)) . H.toLists $ m ¿ cs, cs) + +-- | Bring together the split matrices and put the columns back in +-- their original order. Rows may not be in the same order as the +-- original, but the constraints should be equivalent. +joinMat :: [(H.Matrix Double, [Int])] -> H.Matrix Double +joinMat ms = sortedM + where + disorderedM = H.diagBlock (map fst ms) + colsWithIdx = zip (concatMap snd ms) . H.toColumns $ disorderedM + sortedM = H.fromColumns . map snd . sortBy (comparing fst) $ colsWithIdx + +-- | Turn a matrix into a graph where each node represents a column +-- and each edge represents two columns that have non-zero +-- co-efficients in some row. Basically, 'related columns'. Also +-- includes self-refs for each node.. +relatedColumnsGraph :: H.Matrix Double -> Gr () () +relatedColumnsGraph m = mkGraph (map (,()) ns) (map (\ (a,b) -> (a,b,())) es) + where + nonZeroCols = [ [ j | j <- [0..cols m - 1], not (m `atIndex` (i, j) `approxEq` 0) ] | i <- [0..rows m - 1] ] + ns = nub $ concat nonZeroCols + es = [ (i, j) | cs <- nonZeroCols, [i, j] <- sequence [cs, cs] ] + -- Convert a set of constraints into a matrix of co-efficients, and a -- reverse mapping of column numbers to units. constraintsToMatrix :: Constraints -> (H.Matrix Double, [Int], A.Array Int UnitInfo) @@ -169,7 +329,7 @@ (rhsM, rhsCols) = flattenedToMatrix colSort rhs colElems = A.elems lhsCols ++ A.elems rhsCols augM = if rows rhsM == 0 || cols rhsM == 0 then lhsM else if rows lhsM == 0 || cols lhsM == 0 then rhsM else fromBlocks [[lhsM, rhsM]] - inconsists = findInconsistentRows lhsM augM + inconsists = splitFindInconsistentRows lhsM rhsM constraintsToMatrices :: Constraints -> (H.Matrix Double, H.Matrix Double, [Int], A.Array Int UnitInfo, A.Array Int UnitInfo) constraintsToMatrices cons = constraintsToMatrices' colSort cons @@ -188,7 +348,7 @@ (lhsM, lhsCols) = flattenedToMatrix sortfn lhs (rhsM, rhsCols) = flattenedToMatrix sortfn rhs augM = if rows rhsM == 0 || cols rhsM == 0 then lhsM else if rows lhsM == 0 || cols lhsM == 0 then rhsM else fromBlocks [[lhsM, rhsM]] - inconsists = findInconsistentRows lhsM augM + inconsists = splitFindInconsistentRows lhsM rhsM -- [[UnitInfo]] is a list of flattened constraints flattenedToMatrix :: SortFn -> [[UnitInfo]] -> (H.Matrix Double, A.Array Int UnitInfo) @@ -231,6 +391,14 @@ (lhsOk, lhsShift) = partition (not . isUnitRHS) lhs (rhsOk, rhsShift) = partition isUnitRHS rhs +-- | Shift terms based on function f (<- True, False ->). +shiftTermsBy :: (UnitInfo -> Bool) -> ([UnitInfo], [UnitInfo]) -> ([UnitInfo], [UnitInfo]) +shiftTermsBy f (lhs, rhs) = (lhsOk ++ negateCons rhsShift, rhsOk ++ negateCons lhsShift) + where + (lhsOk, lhsShift) = partition f lhs + (rhsOk, rhsShift) = partition (not . f) rhs + + -- | Translate all constraints into a LHS, RHS side of units. flattenConstraints :: Constraints -> [([UnitInfo], [UnitInfo])] flattenConstraints = map (\ (ConEq u1 u2) -> (flattenUnits u1, flattenUnits u2)) @@ -244,19 +412,28 @@ where -- (a', den, r) = Flint.rref a +-- Provenance of matrices. +data RRefOp + = ElemRowSwap Int Int -- ^ swapped row with row + | ElemRowMult Int Double -- ^ scaled row by constant + | ElemRowAdds [(Int, Int)] -- ^ set of added row onto row ops + deriving (Show, Eq, Ord) + -- worker function -- invariant: the matrix a is in rref except within the submatrix (j-k,j) to (n,n) +rrefMatrices' :: H.Matrix Double -> Int -> Int -> [(H.Matrix Double, RRefOp)] -> + ([(H.Matrix Double, RRefOp)], H.Matrix Double) rrefMatrices' a j k mats -- Base cases: | j - k == n = (mats, a) | j == m = (mats, a) -- When we haven't yet found the first non-zero number in the row, but we really need one: - | a @@> (j - k, j) == 0 = case findIndex (/= 0) below of + | a `atIndex` (j - k, j) == 0 = case findIndex (/= 0) below of -- this column is all 0s below current row, must move onto the next column Nothing -> rrefMatrices' a (j + 1) (k + 1) mats -- we've found a row that has a non-zero element that can be swapped into this row - Just i' -> rrefMatrices' (swapMat <> a) j k (swapMat:mats) + Just i' -> rrefMatrices' (swapMat <> a) j k ((swapMat, ElemRowSwap i (j - k)):mats) where i = j - k + i' swapMat = elemRowSwap n i (j - k) @@ -269,12 +446,12 @@ n = rows a m = cols a below = getColumnBelow a (j - k, j) - - erm = elemRowMult n (j - k) (recip (a @@> (j - k, j))) + scale = recip (a `atIndex` (j - k, j)) + erm = elemRowMult n (j - k) scale -- scale the row if the cell is not already equal to 1 - (a1, mats1) | a @@> (j - k, j) /= 1 = (erm <> a, erm:mats) - | otherwise = (a, mats) + (a1, mats1) | a `atIndex` (j - k, j) /= 1 = (erm <> a, (erm, ElemRowMult (j - k) scale):mats) + | otherwise = (a, mats) -- Locate any non-zero values in the same column as (j - k, j) and -- cancel them out. Optimisation: instead of constructing a @@ -282,19 +459,19 @@ -- multiplied together, simply build a single matrix that cancels -- all of them out at the same time, using the ST Monad. findAdds _ m ms - | isWritten = (new <> m, new:ms) + | isWritten = (new <> m, (new, ElemRowAdds ops):ms) | otherwise = (m, ms) where - (isWritten, new) = runST $ do + (isWritten, ops, new) = runST $ do new <- newMatrix 0 n n :: ST s (STMatrix s Double) sequence [ writeMatrix new i' i' 1 | i' <- [0 .. (n - 1)] ] - let f w i | i >= n = return w - | i == j - k = f w (i + 1) - | a @@> (i, j) == 0 = f w (i + 1) - | otherwise = writeMatrix new i (j - k) (- (a @@> (i, j))) - >> f True (i + 1) - isWritten <- f False 0 - (isWritten,) `fmap` freezeMatrix new + let f w o i | i >= n = return (w, o) + | i == j - k = f w o (i + 1) + | a `atIndex` (i, j) == 0 = f w o (i + 1) + | otherwise = writeMatrix new i (j - k) (- (a `atIndex` (i, j))) + >> f True ((i, j - k):o) (i + 1) + (isWritten, ops) <- f False [] 0 + (isWritten, ops,) `fmap` freezeMatrix new (a2, mats2) = findAdds 0 a1 mats1 @@ -310,29 +487,54 @@ elemRowSwap n i j | i == j = ident n | i > j = elemRowSwap n j i - | otherwise = extractRows ([0..i-1] ++ [j] ++ [i+1..j-1] ++ [i] ++ [j+1..n-1]) $ ident n - + | otherwise = ident n ? ([0..i-1] ++ [j] ++ [i+1..j-1] ++ [i] ++ [j+1..n-1]) -------------------------------------------------- +type GraphCol = IM.IntMap IS.IntSet -- graph from origin to dest. +type Provenance = IM.IntMap IS.IntSet -- graph from dest. to origin + +opToGraphCol :: RRefOp -> GraphCol +opToGraphCol ElemRowMult{} = IM.empty +opToGraphCol (ElemRowSwap i j) = IM.fromList [ (i, IS.singleton j), (j, IS.singleton i) ] +opToGraphCol (ElemRowAdds l) = IM.fromList $ concat [ [(i, IS.fromList [i,j]), (j, IS.singleton j)] | (i, j) <- l ] + +graphColCombine :: GraphCol -> GraphCol -> GraphCol +graphColCombine g1 g2 = IM.unionWith (curry snd) g1 $ IM.map (IS.fromList . trans . IS.toList) g2 + where + trans = concatMap (\ i -> [i] `fromMaybe` (IS.toList <$> IM.lookup i g1)) + +invertGraphCol g = IM.fromListWith IS.union [ (i, IS.singleton j) | (j, jset) <- IM.toList g, i <- IS.toList jset ] + +provenance :: H.Matrix Double -> (H.Matrix Double, Provenance) +provenance m = (m', p) + where + (matOps, m') = rrefMatrices' m 0 0 [] + p = invertGraphCol . foldl' graphColCombine IM.empty . map opToGraphCol $ map snd matOps + -- Worker functions: findInconsistentRows :: H.Matrix Double -> H.Matrix Double -> [Int] -findInconsistentRows coA augA = [0..(rows augA - 1)] \\ consistent +findInconsistentRows coA augA | rows augA < 2 = [] + | otherwise = inconsistent where - consistent = head (filter (tryRows coA augA) (tails ( [0..(rows augA - 1)])) ++ [[]]) + inconsistent = [0..(rows augA - 1)] \\ consistent + consistent + -- if the space is relatively small, try it all + | rows augA < 16 = head (filter tryRows (powerset $ reverse [0..(rows augA - 1)])) + | otherwise = head (filter tryRows (tails ( [0..(rows augA - 1)])) ++ [[]]) + + powerset = filterM (const [True, False]) + -- Rouché–Capelli theorem is that if the rank of the coefficient -- matrix is not equal to the rank of the augmented matrix then -- the system of linear equations is inconsistent. - tryRows _ _ [] = True - tryRows coA augA ns = (rank coA' == rank augA') + tryRows [] = True + tryRows ns = (rank coA' == rank augA') where - coA' = extractRows ns coA - augA' = extractRows ns augA - -extractRows = flip (?) -- hmatrix 0.17 changed interface -m @@> i = m `atIndex` i + coA' = coA ? ns + augA' = augA ? ns -- | Create unique names for all of the inferred implicit polymorphic -- unit variables. @@ -373,7 +575,9 @@ inconsistentConstraints :: Constraints -> Maybe Constraints inconsistentConstraints [] = Nothing inconsistentConstraints cons - | null inconsists = Nothing - | otherwise = Just [ con | (con, i) <- zip cons [0..], i `elem` inconsists ] + | not (null direct) = Just direct + | null inconsists = Nothing + | otherwise = Just [ con | (con, i) <- zip cons [0..], i `elem` inconsists ] where (_, _, inconsists, _, _) = constraintsToMatrices cons + direct = detectInconsistency $ genUnitAssignments' colSort cons diff --git a/src/Camfort/Specification/Units/InferenceBackendFlint.hs b/src/Camfort/Specification/Units/InferenceBackendFlint.hs --- a/src/Camfort/Specification/Units/InferenceBackendFlint.hs +++ b/src/Camfort/Specification/Units/InferenceBackendFlint.hs @@ -309,7 +309,9 @@ -- divide them out sometimes. normHNF :: H.Matrix Double -> (H.Matrix Double, [Int]) -normHNF m = (m', indices) +normHNF m + | (rows m, cols m) == (1, 1) = (H.ident (if H.atIndex m (0, 0) /= 0 then 1 else 0), []) + | otherwise = (m', indices) where numCols = cols m indexLookup j | j < numCols = j diff --git a/src/Camfort/Specification/Units/ModFile.hs b/src/Camfort/Specification/Units/ModFile.hs --- a/src/Camfort/Specification/Units/ModFile.hs +++ b/src/Camfort/Specification/Units/ModFile.hs @@ -10,12 +10,14 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TupleSections #-} module Camfort.Specification.Units.ModFile ( genUnitsModFile , initializeModFiles , runCompileUnits + , dumpModFileCompiledUnits ) where import Control.Monad.State (get, gets, lift) @@ -24,16 +26,19 @@ import Data.Data (Data) import Data.Generics.Uniplate.Operations (universeBi) import Data.List (partition) -import qualified Data.Map.Strict as M +import Data.Maybe (mapMaybe, catMaybes) +import qualified Data.Map as M +import qualified Data.Set as S import Data.Typeable (Typeable) import GHC.Generics (Generic) import qualified Language.Fortran.AST as F +import qualified Language.Fortran.Analysis as FA import Language.Fortran.Util.ModFile import Camfort.Analysis (analysisModFiles) import Camfort.Specification.Units.Annotation (UA) -import Camfort.Specification.Units.Environment (Constraint(..), foldUnits, UnitInfo(..), colSort) +import Camfort.Specification.Units.Environment (Constraint(..), foldUnits, UnitInfo(..), colSort, Constraints) import Camfort.Specification.Units.InferenceBackend (flattenConstraints, flattenUnits, genUnitAssignments, genUnitAssignments') import Camfort.Specification.Units.Monad @@ -63,7 +68,7 @@ mfCompiledUnits :: ModFile -> CompiledUnits mfCompiledUnits mf = case lookupModFileData unitsCompiledDataLabel mf of Nothing -> emptyCompiledUnits - Just bs -> case decodeOrFail (LB.fromStrict bs) of + Just bs -> case decodeOrFail bs of Left _ -> emptyCompiledUnits Right (_, _, cu) -> cu @@ -79,6 +84,7 @@ runCompileUnits :: UnitSolver CompiledUnits runCompileUnits = do cons <- usConstraints `fmap` get + pf <- usProgramFile `fmap` get let unitAssigns = flattenConstraints cons let epsilon = 0.001 -- arbitrary @@ -87,13 +93,36 @@ let variables = M.fromList [ (NPKVariable var, units) | ([UnitPow (UnitVar var) k], units) <- unitAssigns , k `approxEq` 1 ] - tmap <- M.map optimiseTemplate `fmap` gets usTemplateMap - let npm = variables + -- Create sets of relevant program-unit and variable names. + let getName pu | F.Named n <- FA.puName pu = Just n | otherwise = Nothing + let puNameSet = S.fromList $ catMaybes [ getName pu | pu <- universeBi pf :: [F.ProgramUnit UA] ] ++ + [ FA.varName e | F.BlInterface _ _ (Just e) _ _ _ <- universeBi pf :: [F.Block UA] ] - -- D.traceM $ "npm = " ++ unlines (map show (M.toList npm)) - -- D.traceM $ "tmap = \n" ++ unlines [ f ++ "\n" ++ unlines (map show cons) | (f, cons) <- M.toList tmap ] - pure CompiledUnits { cuTemplateMap = tmap, cuNameParamMap = variables } + let puVarNameSet pu = S.fromList $ + [ (FA.varName v, FA.srcName v) | F.DeclVariable _ _ v _ _ <- universeBi pu :: [F.Declarator UA] ] ++ + [ (FA.varName v, FA.srcName v) | F.DeclArray _ _ v _ _ _ <- universeBi pu :: [F.Declarator UA] ] + -- Map of modules -> associated declared variables + let puVarNameMap :: M.Map F.ProgramUnitName (S.Set VV) + puVarNameMap = M.fromListWith S.union [ (F.getName pu, puVarNameSet pu) + | pu@F.PUModule {} <- universeBi pf :: [F.ProgramUnit UA] ] + + -- Filter functions that cut out any information not having to do + -- with the current modules being compiled. + let filterPUs = M.filterWithKey (const . (`S.member` puNameSet)) + -- FIXME: investigate whether we should include vars that are linked + -- transitively to current pf vars should also be included. + tmap <- (filterPUs . M.map optimiseTemplate) `fmap` gets usTemplateMap + + let findNPK vv = ( (NPKVariable vv), ) <$> M.lookup (NPKVariable vv) variables + + -- 'Name Param Map': module names -> (variables -> unit info) + let npm = M.filter (not . M.null) $ flip M.map puVarNameMap (M.fromList . mapMaybe findNPK . S.toList) + + pure CompiledUnits { cuTemplateMap = tmap, cuNameParamMap = npm } + +-- | Cut out unnecessary constraints in the template using the solver. +optimiseTemplate :: Constraints -> Constraints optimiseTemplate cons = map (\ (l, r) -> ConEq (foldUnits l) r) optimised where unitAssigns = genUnitAssignments' (compileColSort) cons @@ -122,4 +151,24 @@ genUnitsModFile :: F.ProgramFile UA -> CompiledUnits -> ModFile genUnitsModFile pf cu = alterModFileData f unitsCompiledDataLabel $ genModFile pf where - f _ = Just . LB.toStrict $ encode cu + f _ = Just $ encode cu + +-- | Return information about compiled units for debugging purposes +dumpModFileCompiledUnits :: ModFile -> Maybe String +dumpModFileCompiledUnits mf = do + bs <- lookupModFileData unitsCompiledDataLabel mf + cu <- case decodeOrFail bs of + Left _ -> Nothing + Right (_, _, cu) -> Just cu + pure . unlines $ [ "Template Map (size=" ++ show (M.size (cuTemplateMap cu)) ++ "):" + , concat [ unlines (i 2 fname':map (i 4 . show) temp) + | (fname, temp) <- M.toList (cuTemplateMap cu) + , let fname' = "Template for " ++ show fname ] + , "NameParam Map (size=" ++ show (M.size (cuNameParamMap cu)) ++ "):" + , concat [ unlines (i 2 mod':[ i 4 (show ui ++ " :: " ++ show v) + | (NPKVariable (v,_), ui) <- M.toList npkmap ]) + | (mod, npkmap) <- M.toList (cuNameParamMap cu) + , let mod' = "Module " ++ show mod ] + ] + where + i n s = replicate n ' ' ++ s diff --git a/src/Camfort/Specification/Units/MonadTypes.hs b/src/Camfort/Specification/Units/MonadTypes.hs --- a/src/Camfort/Specification/Units/MonadTypes.hs +++ b/src/Camfort/Specification/Units/MonadTypes.hs @@ -72,7 +72,7 @@ instance Binary NameParamKey -- | mapped to a list of units (to be multiplied together) -type NameParamMap = M.Map NameParamKey [UnitInfo] +type NameParamMap = M.Map F.ProgramUnitName (M.Map NameParamKey [UnitInfo]) -- | Variable => unit type VarUnitMap = M.Map VV UnitInfo diff --git a/src/Camfort/Transformation/CommonBlockElim.hs b/src/Camfort/Transformation/CommonBlockElim.hs --- a/src/Camfort/Transformation/CommonBlockElim.hs +++ b/src/Camfort/Transformation/CommonBlockElim.hs @@ -17,6 +17,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MonoLocalBinds #-} module Camfort.Transformation.CommonBlockElim ( commonElimToModules @@ -24,7 +25,7 @@ import Control.Monad import Control.Monad.State.Lazy -import Control.Monad.Writer.Strict (execWriter, tell) +import Control.Monad.Writer.CPS (execWriter, tell) import Data.Data import Data.Void @@ -36,6 +37,7 @@ import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA import qualified Language.Fortran.Analysis.Types as FAT +import qualified Language.Fortran.Analysis.Renaming as FAR import qualified Language.Fortran.Util.Position as FU import qualified Language.Fortran.ParserMonad as PM import qualified Language.Fortran.PrettyPrint as PP @@ -49,7 +51,8 @@ -- Tuple of: -- * a (possible) common block name -- * map from names to their types -type TCommon p = (Maybe F.Name, [(F.Name, F.BaseType)]) +type TypeInfo = (F.BaseType, FA.ConstructType) +type TCommon p = (Maybe F.Name, [(F.Name, TypeInfo)]) -- Typed and "located" common block representation -- Right associated pairs tuple of: @@ -87,7 +90,7 @@ analysePerPF :: F.ProgramFile A -> CommonState (F.ProgramFile A) analysePerPF pf = do - let pf' = FA.initAnalysis pf + let pf' = FAR.analyseRenames . FA.initAnalysis $ pf let (pf'', tenv) = FAT.analyseTypes pf' pf''' <- transformBiM (analysePerPU tenv (F.pfGetFilename pf)) pf'' return (fmap FA.prevAnnotation pf''') @@ -119,15 +122,17 @@ let info = (fname, (punitName pname, (commonNameFromAST cname, tcommon))) modify (\(r, infos) -> (r ++ r', info : infos)) - typeCommonExprs :: F.Expression A1 -> (F.Name, F.BaseType) - typeCommonExprs (F.ExpValue _ sp (F.ValVariable v)) = - case M.lookup v tenv of - Just (FA.IDType (Just t) (Just FA.CTVariable)) -> (v, t) - Just (FA.IDType (Just t) (Just FA.CTArray)) -> (v, t) - _ -> error $ "Variable '" ++ show v - ++ "' is of an unknown or higher-order type at: " ++ show sp - ++ show (M.lookup v tenv) - + typeCommonExprs :: F.Expression A1 -> (F.Name, TypeInfo) + typeCommonExprs e@(F.ExpValue _ sp (F.ValVariable _)) = + case M.lookup var tenv of + Just (FA.IDType (Just t) (Just ct@FA.CTVariable)) -> (src, (t, ct)) + Just (FA.IDType (Just t) (Just ct@FA.CTArray{})) -> (src, (t, ct)) + _ -> error $ "Variable '" ++ src + ++ "' is of an unknown or higher-order type at: " ++ show sp ++ " " + ++ show (M.lookup var tenv) + where + var = FA.varName e + src = FA.srcName e typeCommonExprs e = error $ "Not expecting a non-variable expression \ \in expression at: " ++ show (FU.getSpan e) @@ -175,7 +180,7 @@ let mkRenamerAndCommon (r, tc) (v, t) = let v' = caml (commonName cname) ++ "_" ++ v in (M.insert v (Just v', Nothing) r, (v', t) : tc) - (r, fields') = foldl mkRenamerAndCommon (M.empty, []) fields + (r, fields') = foldl' mkRenamerAndCommon (M.empty, []) fields in ((fname, (pname, (cname, fields'))), Just r) -- From a list of typed and located common blocks group by the common @@ -212,7 +217,7 @@ -- a Nothing for a variable represent a variable-level (renamer) identity -- a Nothing for a type represents a type-level (coercer) identity type RenamerCoercer = - Maybe (M.Map F.Name (Maybe F.Name, Maybe (F.BaseType, F.BaseType))) + Maybe (M.Map F.Name (Maybe F.Name, Maybe (TypeInfo, TypeInfo))) class Renaming r where hasRenaming :: F.Name -> r -> Bool @@ -240,7 +245,7 @@ importIncludeCommons :: PM.FortranVersion -> F.ProgramUnit A -> F.ProgramUnit A importIncludeCommons v p = - foldl (flip (matchPUnit v)) p (reduceCollect inames p) + foldl' (flip (matchPUnit v)) p (reduceCollect inames p) -- Data-type generic reduce traversal reduceCollect :: (Data s, Data t, Uniplate t, Biplate t s) => (s -> Maybe a) -> t -> [a] @@ -285,37 +290,39 @@ -- declaration time (which then need to be turned into separate assignment -- statements) removeDecl :: [RenamerCoercer] - -> F.Statement A -> State [F.Statement A] (F.Statement A) - removeDecl rcs (F.StDeclaration a s@(FU.SrcSpan p1 _) typ attr decls) = do + -> F.Block A -> State [F.Statement A] (F.Block A) + removeDecl rcs (F.BlStatement a s@(FU.SrcSpan p1 _) mlab (F.StDeclaration stA stS typ attr decls)) = do modify (++ assgns) - return $ F.StDeclaration a' (deleteLine s) typ attr decls' + return . F.BlStatement a' s' mlab $ F.StDeclaration stA stS typ attr decls' where (F.AList al sl declsA) = decls decls' = F.AList al' sl declsA' - (assgns, declsA') = foldl matchVar ([],[]) declsA + (assgns, declsA') = foldl' matchVar ([],[]) declsA -- Update annotation if declarations are being added - (a', al') = if length declsA == length declsA' - then (a, al) - else (a {refactored = Just p1, deleteNode = True} - , al {refactored = Just pl1}) - where (FU.SrcSpan pl1 _ ) = sl + ((a', s'), al') + | null declsA' = ((a {refactored = Just p1, deleteNode = True}, deleteLine s), + al {refactored = Just pl1}) + | length declsA' /= length declsA = ((a {refactored = Just p1}, s), al {refactored = Just pl1}) + | otherwise = ((a, s), al) + where FU.SrcSpan pl1 _ = sl matchVar :: ([F.Statement A], [F.Declarator A]) -> F.Declarator A -> ([F.Statement A], [F.Declarator A]) - matchVar (assgns, decls) - dec@(F.DeclVariable _ s - lvar@(F.ExpValue _ _ (F.ValVariable v)) _ init) = - if hasRenaming v rcs - then case init of - -- Renaming exists and no default, then remove - Nothing -> (assgns, decls) - -- Renaming exists but has default, so create an - -- assignment for this - Just initExpr -> - ((F.StExpressionAssign a' s lvar initExpr) : assgns, decls) - else -- no renaming, preserve declaration - (assgns, dec : decls) - matchVar (assgns, decls) _ = (assgns, decls) + -- match on variable or array declaration + matchVar (assgns, decls) dec = case dec of + F.DeclVariable _ _ lvar@(F.ExpValue _ _ (F.ValVariable v)) _ init -> doMatchVar lvar v init + F.DeclArray _ _ lvar@(F.ExpValue _ _ (F.ValVariable v)) _ _ init -> doMatchVar lvar v init + _ -> (assgns, decls) + where + doMatchVar lvar v init + | hasRenaming v rcs = case init of + -- Renaming exists and no default, then remove + Nothing -> (assgns, decls) + -- Renaming exists but has default, so create an + -- assignment for this + Just initExpr -> ((F.StExpressionAssign a' (FU.getSpan dec) lvar initExpr) : assgns, decls) + | otherwise = (assgns, dec : decls) -- no renaming, preserve declaration + removeDecl _ d = return d @@ -356,7 +363,7 @@ renamerToUse Nothing = [] renamerToUse (Just m) = let entryToPair _ (Nothing, _) = [] entryToPair v (Just v', _) = [(v, v')] - in M.foldlWithKey (\xs v e -> entryToPair v e ++ xs) [] m + in M.foldlWithKey' (\xs v e -> entryToPair v e ++ xs) [] m -- make the use statements for a particular program unit's common blocks mkUseStatementBlocks :: FU.SrcSpan -> [(TCommon A, RenamerCoercer)] -> [F.Block A] @@ -366,7 +373,7 @@ (FU.SrcSpan pos pos') = s s' = FU.SrcSpan (toCol0 pos) pos' mkUseStmnt x@((name, _), _) = F.BlStatement a s' Nothing $ - F.StUse a s' useName F.Permissive useListA + F.StUse a s' useName Nothing F.Permissive useListA where useName = F.ExpValue a s' (F.ValVariable (caml (commonName name))) useListA = case useList of [] -> Nothing us -> Just (F.AList a s' (reverse us)) @@ -384,9 +391,8 @@ mkRenamerCoercer :: TCommon A :? source -> TCommon A :? target -> RenamerCoercer mkRenamerCoercer (name1, vtys1) (name2, vtys2) - | name1 == name2 = - if vtys1 == vtys2 then Nothing - else Just $ generate vtys1 vtys2 M.empty + | name1 == name2 = if vtys1 == vtys2 then Nothing + else Just $ generate vtys1 vtys2 M.empty | otherwise = error "Can't generate renamer between different common blocks\n" where @@ -416,16 +422,16 @@ else error $ "Trying to compare differently named common blocks: " ++ show n1 ++ " and " ++ show n2 ++ "\n" -coherentCommons' :: [(F.Name, F.BaseType)] -> [(F.Name, F.BaseType)] -> (String, Bool) +coherentCommons' :: [(F.Name, TypeInfo)] -> [(F.Name, TypeInfo)] -> (String, Bool) coherentCommons' [] [] = ("", True) coherentCommons' ((var1, ty1):xs) ((var2, ty2):ys) | af ty1 == af ty2 = let (r', c) = coherentCommons' xs ys in (r', c && True) | otherwise = let r = var1 ++ ":" - ++ PP.pprintAndRender PM.Fortran90 ty1 Nothing + ++ PP.pprintAndRender PM.Fortran90 (fst ty1) Nothing ++ "(" ++ show (af ty1) ++ ")" ++ " differs from " ++ var2 - ++ ":" ++ PP.pprintAndRender PM.Fortran90 ty2 Nothing + ++ ":" ++ PP.pprintAndRender PM.Fortran90 (fst ty2) Nothing ++ "(" ++ show (af ty2) ++ ")" ++ "\n" (r', _) = coherentCommons' xs ys in (r ++ r', False) @@ -449,17 +455,24 @@ r = "Creating module " ++ modname ++ " at " ++ path ++ "\n" mod = mkModule modname varTys modname -mkModule :: String -> [(F.Name, F.BaseType)] -> String -> F.ProgramUnit A +mkModule :: String -> [(F.Name, TypeInfo)] -> String -> F.ProgramUnit A mkModule name vtys fname = F.PUModule a sp (caml fname) decls Nothing where a = unitAnnotation { refactored = Just loc, newNode = True } - loc = FU.Position 0 0 0 + loc = FU.Position 0 0 0 "" Nothing sp = FU.SrcSpan loc loc toDeclBlock (v, t) = F.BlStatement a sp Nothing (toStmt (v, t)) - toStmt (v, t) = F.StDeclaration a sp (toTypeSpec t) Nothing (toDeclarator v) + toStmt (v, (bt, ct)) = F.StDeclaration a sp (toTypeSpec bt) attrs (toDeclarator (v, ct)) + attrs = Just $ F.AList a sp [F.AttrSave a sp] toTypeSpec t = F.TypeSpec a sp t Nothing - toDeclarator v = F.AList a sp + toDeclarator (v, FA.CTVariable) = F.AList a sp [F.DeclVariable a sp (F.ExpValue a sp (F.ValVariable (caml name ++ "_" ++ v))) Nothing Nothing] + toDeclarator (v, FA.CTArray dims) = F.AList a sp + [F.DeclArray a sp + (F.ExpValue a sp (F.ValVariable (caml name ++ "_" ++ v))) dimDecls Nothing Nothing] + where + dimDecls = F.AList a sp . flip map dims $ \ (lb, ub) -> F.DimensionDeclarator a sp (fmap exp lb) (fmap exp ub) + exp = F.ExpValue a sp . F.ValInteger . show decls = map toDeclBlock vtys diff --git a/src/Camfort/Transformation/EquivalenceElim.hs b/src/Camfort/Transformation/EquivalenceElim.hs --- a/src/Camfort/Transformation/EquivalenceElim.hs +++ b/src/Camfort/Transformation/EquivalenceElim.hs @@ -97,9 +97,9 @@ let pos = afterAligned sp let copies = map (mkCopy tenv pos dstE) eqs' - let (FU.Position ao c l) = s1 + let (FU.Position ao c l f p) = s1 reportSpan i = - let pos = FU.Position (ao + i) c (l + i) + let pos = FU.Position (ao + i) c (l + i) f p in (FU.SrcSpan pos pos) forM_ [n..(n + length copies - 1)] $ \i -> do diff --git a/src/Language/Fortran/Model/Translate.hs b/src/Language/Fortran/Model/Translate.hs --- a/src/Language/Fortran/Model/Translate.hs +++ b/src/Language/Fortran/Model/Translate.hs @@ -16,6 +16,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PolyKinds #-} -- TODO: Implement translation for more unsupported language parts @@ -97,6 +98,7 @@ indices, op, rmap, (.>)) import Control.Monad.Except import Control.Monad.Reader +import Control.Monad.Fail hiding (fail) import Data.Map (Map) import Data.Singletons @@ -238,10 +240,11 @@ , MonadError TranslateError , MonadReader TranslateEnv , MonadLogger e w + , MonadFail ) runTranslateT - :: (Monad m) + :: (Monad m, MonadFail m) => TranslateT m a -> TranslateEnv -> m (Either TranslateError a) @@ -359,7 +362,7 @@ -- | Convert a 'TypeInfo' to its corresponding strong type. translateTypeInfo - :: (Monad m, Show ann) + :: (Monad m, MonadFail m, Show ann) => TypeInfo ann -> TranslateT m SomeType translateTypeInfo ti = do @@ -406,7 +409,7 @@ SomePrimD :: D (PrimS a) -> SomePrimD translateBaseType - :: (Monad m) + :: (Monad m, MonadFail m) => F.BaseType -> Maybe (F.Expression ann) -- ^ Kind -> TranslateT m SomePrimD @@ -428,10 +431,10 @@ -- Get value-level representations of the type's basic type and precision (basicType, prec) <- case bt of - F.TypeInteger -> (BTInt ,) <$> getKindPrec "integer" fsIntegerKinds - F.TypeReal -> (BTReal ,) <$> getKindPrec "real" fsRealKinds - F.TypeCharacter -> (BTChar ,) <$> getKindPrec "character" fsCharacterKinds - F.TypeLogical -> (BTLogical ,) <$> getKindPrec "logical" fsLogicalKinds + F.TypeInteger -> (BTInt ,) <$> getKindPrec "integer" fsIntegerKinds + F.TypeReal -> (BTReal ,) <$> getKindPrec "real" fsRealKinds + F.TypeCharacter{} -> (BTChar ,) <$> getKindPrec "character" fsCharacterKinds + F.TypeLogical -> (BTLogical ,) <$> getKindPrec "logical" fsLogicalKinds -- Double precision is special because it's not always supported as its own -- basic type, being subsumed by the `REAL` basic type. F.TypeDoublePrecision -> @@ -451,7 +454,7 @@ -- | Translate an expression with an unknown type. The return value -- existentially captures the type of the result. -translateExpression :: (Monad m) => F.Expression (F.Analysis ann) -> TranslateT m SomeExpr +translateExpression :: (Monad m, MonadFail m) => F.Expression (F.Analysis ann) -> TranslateT m SomeExpr translateExpression = \case e@(F.ExpValue ann span val) -> translateValue e F.ExpBinary ann span bop e1 e2 -> translateOp2App e1 e2 bop @@ -469,7 +472,7 @@ -- | Translate an expression with a known type. Fails if the actual type does -- not match. translateExpression' - :: (Monad m) => D a -> F.Expression (F.Analysis ann) + :: (Monad m, MonadFail m) => D a -> F.Expression (F.Analysis ann) -> TranslateT m (FortranExpr a) translateExpression' targetD ast = do SomePair sourceD expr <- translateExpression ast @@ -482,7 +485,7 @@ -- | Translate an expression and try to coerce it to a particular type. Fails if -- the actual type cannot be coerced to the given type. translateCoerceExpression - :: (Monad m) => D a -> F.Expression (F.Analysis ann) + :: (Monad m, MonadFail m) => D a -> F.Expression (F.Analysis ann) -> TranslateT m (HFree MetaOp FortranExpr a) translateCoerceExpression targetD ast = do SomePair sourceD expr <- translateExpression ast @@ -497,7 +500,7 @@ translateSubscript - :: (Monad m) + :: (Monad m, MonadFail m) => F.Expression (F.Analysis ann) -> [F.Index (F.Analysis ann)] -> TranslateT m SomeExpr translateSubscript arrAst [F.IxSingle _ _ _ ixAst] = do SomePair arrD arrExp <- translateExpression arrAst @@ -532,7 +535,7 @@ -- annotations of its own. -- -- Do not call on an expression that you don't know to be an 'F.ExpValue'! -translateValue :: (Monad m) => F.Expression (F.Analysis ann) -> TranslateT m SomeExpr +translateValue :: (Monad m, MonadFail m) => F.Expression (F.Analysis ann) -> TranslateT m SomeExpr translateValue e = case e of F.ExpValue _ _ v -> case v of F.ValInteger s -> translateLiteral v PInt64 (fmap fromIntegral . readLitInteger) s @@ -562,7 +565,7 @@ translateLiteral - :: (Monad m) + :: (Monad m, MonadFail m) => F.Value ann -> Prim p k a -> (s -> Maybe a) -> s -> TranslateT m SomeExpr @@ -621,7 +624,7 @@ -- This is way too general for its own good but it was fun to write. translateOpApp - :: (Monad m) + :: (Monad m, MonadFail m) => (Length xs ~ n) => Op n ok -> Rec (Const (F.Expression (F.Analysis ann))) xs -> TranslateT m SomeExpr @@ -641,7 +644,7 @@ translateOp2App - :: (Monad m) + :: (Monad m, MonadFail m) => F.Expression (F.Analysis ann) -> F.Expression (F.Analysis ann) -> F.BinaryOp -> TranslateT m SomeExpr translateOp2App e1 e2 bop = do @@ -652,7 +655,7 @@ translateOp1App - :: (Monad m) + :: (Monad m, MonadFail m) => F.Expression (F.Analysis ann) -> F.UnaryOp -> TranslateT m SomeExpr translateOp1App e uop = do diff --git a/src/Language/Fortran/Model/Vars.hs b/src/Language/Fortran/Model/Vars.hs --- a/src/Language/Fortran/Model/Vars.hs +++ b/src/Language/Fortran/Model/Vars.hs @@ -136,10 +136,10 @@ return $ ARData valReprs arraySymbolicPrim :: (HasPrimReprHandlers r) => Prim p1 k1 i -> Prim p2 k2 a -> String -> r -> Symbolic SArr -arraySymbolicPrim ixPrim valPrim nm = do - k1 <- primSBVKind ixPrim - k2 <- primSBVKind valPrim - return $ newSArr (k1, k2) (\i -> nm ++ "_" ++ show i) +arraySymbolicPrim ixPrim valPrim nm = error "arraySymbolicPrim: bit-rotted in new SBV 8.0 version" -- do + -- k1 <- primSBVKind ixPrim + -- k2 <- primSBVKind valPrim + -- return $ newSArr (k1, k2) (\i -> nm ++ "_" ++ show i) -- pairProxy :: p1 a -> p2 b -> Proxy '(a, b) -- pairProxy _ _ = Proxy diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -23,6 +23,8 @@ import Camfort.Specification.Units.Monad (LiteralsOpt(LitMixed)) import Camfort.Specification.Hoare (PrimReprOption(..)) +import Language.Fortran.ParserMonad (FortranVersion(..), selectFortranVersion) + import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import System.Directory (getCurrentDirectory) @@ -39,10 +41,12 @@ else exitWith $ ExitFailure code where env ro lo = CamfortEnv - { ceInputSources = inputSource ro - , ceIncludeDir = includeDir ro - , ceExcludeFiles = getExcludes ro - , ceLogLevel = logLevel lo + { ceInputSources = inputSource ro + , ceIncludeDir = includeDir ro + , ceExcludeFiles = getExcludes ro + , ceLogLevel = logLevel lo + , ceSourceSnippets = snippets lo + , ceFortranVersion = fortranVersion ro } getExcludes = fromMaybe [] . exclude @@ -64,6 +68,13 @@ lo = ssoLogOptions sso inFile = inputSource ro in runRO ro lo (f (annotationType ao) (getOutputFile inFile wo)) + runDSO dso f = + let ao = dsoAnnotationOptions dso + wo = dsoWriteOptions dso + ro = dsoReadOptions dso + lo = dsoLogOptions dso + inFile = inputSource ro + in runRO ro lo (f (annotationType ao) (getOutputFile inFile wo)) runUO uo f = let ro = uoReadOptions uo lo = uoLogOptions uo @@ -97,16 +108,27 @@ runCommand (CmdStencilsInfer so) = runSIO so stencilsInfer runCommand (CmdStencilsSynth sso) = runSSO sso stencilsSynth runCommand (CmdUnitsSuggest uo) = runUO uo unitsCriticals - runCommand (CmdUnitsCheck uo) = runUO uo unitsCheck - runCommand (CmdUnitsInfer uo) = runUO uo unitsInfer + runCommand (CmdUnitsCheck uo) + | uoDumpMode uo = runUO uo unitsDump + | otherwise = runUO uo unitsCheck + runCommand (CmdUnitsInfer uo) = runUO uo $ unitsInfer (uoShowAST uo) runCommand (CmdUnitsSynth uso) = runUSO uso unitsSynth runCommand (CmdUnitsCompile uo) = runUO uo unitsCompile runCommand (CmdInvariantsCheck io) = runIO io invariantsCheck runCommand (CmdRefactCommon rfo) = runRFO rfo common runCommand (CmdRefactDead rfo) = runRFO rfo dead runCommand (CmdRefactEquivalence rfo) = runRFO rfo equivalences + runCommand (CmdInferDDT ro lo) = runRO ro lo ddtInfer + runCommand (CmdSynthDDT dso) = runDSO dso ddtSynth + runCommand (CmdCheckDDT ro lo) = runRO ro lo ddtCheck + runCommand (CmdRefactDDT rfo) = runRFO rfo ddtRefactor + runCommand (CmdCompileDDT ro lo) = runRO ro lo ddtCompile runCommand (CmdImplicitNone ro lo) = runRO ro lo (implicitNone False) runCommand (CmdImplicitNoneAll ro lo) = runRO ro lo (implicitNone True) + runCommand (CmdAllocCheck ro lo) = runRO ro lo allocCheck + runCommand (CmdFPCheck ro lo) = runRO ro lo fpCheck + runCommand (CmdUseCheck ro lo) = runRO ro lo useCheck + runCommand (CmdArrayCheck ro lo) = runRO ro lo arrayCheck runCommand (CmdInit dir) = camfortInitialize dir >> return 0 runCommand CmdTopVersion = displayVersion >> return 0 @@ -126,8 +148,17 @@ | CmdRefactCommon RefactOptions | CmdRefactDead RefactOptions | CmdRefactEquivalence RefactOptions + | CmdInferDDT ReadOptions LogOptions + | CmdSynthDDT DDTSynthOptions + | CmdCheckDDT ReadOptions LogOptions + | CmdRefactDDT RefactOptions + | CmdCompileDDT ReadOptions LogOptions | CmdImplicitNone ReadOptions LogOptions | CmdImplicitNoneAll ReadOptions LogOptions + | CmdAllocCheck ReadOptions LogOptions + | CmdFPCheck ReadOptions LogOptions + | CmdUseCheck ReadOptions LogOptions + | CmdArrayCheck ReadOptions LogOptions | CmdInit FilePath | CmdTopVersion @@ -137,11 +168,13 @@ { inputSource :: String , includeDir :: Maybe String , exclude :: Maybe [String] + , fortranVersion :: Maybe FortranVersion } data LogOptions = LogOptions { logLevel :: LogLevel + , snippets :: Bool } @@ -158,6 +191,8 @@ { uoReadOptions :: ReadOptions , uoLogOptions :: LogOptions , literals :: LiteralsOpt + , uoDumpMode :: Bool + , uoShowAST :: Bool } @@ -191,6 +226,12 @@ , ssoAnnotationOptions :: AnnotationOptions } +data DDTSynthOptions = DDTSynthOptions + { dsoReadOptions :: ReadOptions + , dsoLogOptions :: LogOptions + , dsoWriteOptions :: WriteOptions + , dsoAnnotationOptions :: AnnotationOptions + } data InvariantsOptions = InvariantsOptions { ioReadOptions :: ReadOptions @@ -228,19 +269,30 @@ (xs', _:cs) -> xs' : splitBy c cs -excludeOption :: Parser (Maybe [String]) -excludeOption = optional $ multiFileOption $ +excludeOption :: Parser [String] +excludeOption = multiFileOption $ long "exclude" <> short 'e' <> help "files to exclude (comma separated list, no spaces)" +fortranVersionOption :: Parser FortranVersion +fortranVersionOption = option parseFortranVersion $ + long "fortranVersion" + <> short 'F' + <> metavar "VERSION" + <> help "version of Fortran to parse" + where + parseFortranVersion = eitherReader $ \ s -> case selectFortranVersion s of + Just v -> Right v + Nothing -> Left "unable to parse the supplied Fortran version string" -- | Parse options for 'ReadOptions'. readOptions :: Parser ReadOptions readOptions = fmap ReadOptions (fileArgument $ help "input file") <*> optional includeDirOption - <*> excludeOption + <*> optional excludeOption + <*> optional fortranVersionOption where dirOption m = strOption (metavar "DIR" <> action "directory" <> m) includeDirOption = dirOption @@ -250,11 +302,12 @@ logOptions :: Parser LogOptions -logOptions = LogOptions <$> logLevelOption +logOptions = LogOptions <$> logLevelOption <*> snippetsOption where logLevelOption = let toLogLevel debug = if debug then LogDebug else LogInfo in toLogLevel <$> switch (long "debug" <> help "enable debug output") + snippetsOption = switch (long "snippets" <> help "show code snippets") -- | User must specify either an ouput file, or say that the file @@ -287,6 +340,8 @@ readOptions <*> logOptions <*> literalsOption + <*> dumpModFileOption + <*> showASTOption where literalsOption = option parseLiterals $ long "units-literals" @@ -295,6 +350,8 @@ <> completeWith ["Unitless", "Poly", "Mixed"] <> value LitMixed <> help "units-of-measure literals mode. ID = Unitless, Poly, or Mixed" + dumpModFileOption = switch (long "dump-mod-file" <> help "show contents of fsmod file") + showASTOption = switch (long "show-ast" <> help "show units at each AST node") parseLiterals = fmap read str @@ -335,6 +392,9 @@ refactOptions = fmap RefactOptions readOptions <*> logOptions <*> writeOptions +ddtSynthOptions :: Parser DDTSynthOptions +ddtSynthOptions = fmap DDTSynthOptions + readOptions <*> logOptions <*> writeOptions <*> annotationOptions cmdCount, cmdAST :: Parser Command cmdCount = fmap CmdCount readOptions <*> logOptions @@ -355,17 +415,27 @@ cmdUnitsSynth = fmap CmdUnitsSynth unitsSynthOptions -cmdImplicitNone, cmdImplicitNoneAll, cmdInvariantsCheck :: Parser Command +cmdImplicitNone, cmdImplicitNoneAll, cmdInvariantsCheck, cmdAllocCheck, cmdFPCheck :: Parser Command cmdInvariantsCheck = fmap CmdInvariantsCheck invariantsOptions cmdImplicitNone = fmap CmdImplicitNone readOptions <*> logOptions cmdImplicitNoneAll = fmap CmdImplicitNoneAll readOptions <*> logOptions - +cmdAllocCheck = fmap CmdAllocCheck readOptions <*> logOptions +cmdFPCheck = fmap CmdFPCheck readOptions <*> logOptions +cmdUseCheck = fmap CmdUseCheck readOptions <*> logOptions +cmdArrayCheck = fmap CmdArrayCheck readOptions <*> logOptions cmdRefactCommon, cmdRefactDead, cmdRefactEquivalence :: Parser Command cmdRefactCommon = fmap CmdRefactCommon refactOptions cmdRefactDead = fmap CmdRefactDead refactOptions cmdRefactEquivalence = fmap CmdRefactEquivalence refactOptions +cmdInferDDT, cmdSynthDDT, cmdCheckDDT, cmdRefactDDT, cmdCompileDDT :: Parser Command +cmdInferDDT = fmap CmdInferDDT readOptions <*> logOptions +cmdSynthDDT = fmap CmdSynthDDT ddtSynthOptions +cmdCheckDDT = fmap CmdCheckDDT readOptions <*> logOptions +cmdRefactDDT = fmap CmdRefactDDT refactOptions +cmdCompileDDT = fmap CmdCompileDDT readOptions <*> logOptions + -- | Helper for building a command alias. -- -- Command aliases will not show up in the help text, nor be subject to completion. @@ -431,6 +501,18 @@ , ("invariants-check", ["invariants-check","check-invariants", "check-hoare", "hoare-check"], cmdInvariantsCheck, "hoare logic invariant checking") + , ("alloc-check", + [], + cmdAllocCheck, "check allocate/deallocate statement usage") + , ("fp-check", + [], + cmdFPCheck, "check floating point usage") + , ("use-check", + [], + cmdUseCheck, "check usage of module USE") + , ("array-check", + [], + cmdArrayCheck, "check usage of arrays") ] @@ -438,10 +520,19 @@ refactoringsParser = commandsParser "Refactoring Commands" refactoringsCommands where refactoringsCommands = - [ ("common", [], cmdRefactCommon, "common block elimination") - , ("equivalence", [], cmdRefactEquivalence, "equivalence elimination") - , ("dead", [], cmdRefactDead, "dead-code elimination") ] + [ ("common", [], cmdRefactCommon, "common block elimination") + , ("equivalence", [], cmdRefactEquivalence, "equivalence elimination") + , ("dead", [], cmdRefactDead, "dead-code elimination") ] +derivedDatatypeParser :: Parser Command +derivedDatatypeParser = commandsParser "Derived Datatype Commands" derivedDatatypeCommands + where + derivedDatatypeCommands = + [ ("ddt-infer", ["infer-ddt"], cmdInferDDT, "infer derived datatypes") + , ("ddt-synth", ["synth-ddt"], cmdSynthDDT, "synthesise comments for derived datatypes") + , ("ddt-check", ["check-ddt"], cmdCheckDDT, "check comments for derived datatypes") + , ("ddt-refactor", ["refactor-ddt"], cmdRefactDDT, "refactor marked derived datatypes from comments") + , ("ddt-compile", ["compile-ddt"], cmdCompileDDT, "compile derived datatypes info")] topLevelCommands :: Parser Command topLevelCommands = versionOption @@ -467,11 +558,12 @@ helper <*> ( projectParser currDir <|> analysesParser <|> refactoringsParser + <|> derivedDatatypeParser <|> topLevelCommands) -- | Current CamFort version. -version = "0.905" +version = "0.906" -- | Full CamFort version string. diff --git a/tests/Camfort/Analysis/CommentAnnotatorSpec.hs b/tests/Camfort/Analysis/CommentAnnotatorSpec.hs --- a/tests/Camfort/Analysis/CommentAnnotatorSpec.hs +++ b/tests/Camfort/Analysis/CommentAnnotatorSpec.hs @@ -18,7 +18,7 @@ import Camfort.Analysis.CommentAnnotator import Camfort.Specification.Parser (mkParser, parseError, SpecParser) -p = SrcSpan (Position 0 1 1) (Position 0 1 1) +p = SrcSpan (Position 0 1 1 "" Nothing) (Position 0 1 1 "" Nothing) annotateWith :: (String -> String) -> ProgramFile A -> ProgramFile A annotateWith s = runIdentity . annotateComments trivialParser ignore diff --git a/tests/Camfort/Analysis/TestUtils.hs b/tests/Camfort/Analysis/TestUtils.hs --- a/tests/Camfort/Analysis/TestUtils.hs +++ b/tests/Camfort/Analysis/TestUtils.hs @@ -54,8 +54,8 @@ Just x -> return x Nothing -> getCurrentDirectory - modFiles <- genModFiles emptyModFiles simpleCompiler () incDir (input ^. tiExcludeFiles) - pfsTexts <- readParseSrcDir modFiles (input ^. tiInputSources) (input ^. tiExcludeFiles) + modFiles <- getModFiles incDir + pfsTexts <- readParseSrcDir Nothing modFiles (input ^. tiInputSources) (input ^. tiExcludeFiles) return (modFiles, pfsTexts) diff --git a/tests/Camfort/ReprintSpec.hs b/tests/Camfort/ReprintSpec.hs --- a/tests/Camfort/ReprintSpec.hs +++ b/tests/Camfort/ReprintSpec.hs @@ -58,15 +58,15 @@ -} it "takeBounds test 1" $ - (fst $ takeBounds (FU.Position 0 2 2, FU.Position 0 5 2) btext) + (fst $ takeBounds (FU.Position 0 2 2 "" Nothing, FU.Position 0 5 2 "" Nothing) btext) `shouldBe` (B.pack "A B") it "takeBounds test 2" $ - (fst $ takeBounds (FU.Position 0 2 2, FU.Position 0 1 3) btext) + (fst $ takeBounds (FU.Position 0 2 2 "" Nothing, FU.Position 0 1 3 "" Nothing) btext) `shouldBe` (B.pack "A B C D\n") it "takeBound test 3" $ - (fst $ takeBounds (FU.Position 1 1 1, FU.Position 1 5 3) btext2) + (fst $ takeBounds (FU.Position 1 1 1 "" Nothing, FU.Position 1 5 3 "" Nothing) btext2) `shouldBe` (B.pack $ unlines $ take 3 text2) -- TODO: Fix this @@ -88,16 +88,16 @@ instance Arbitrary (PlusOne FU.Position) where arbitrary = do - FU.Position offset col line <- arbitrary + FU.Position offset col line f p <- arbitrary let col' = if line == 1 then col+1 else col - return $ PlusOne $ FU.Position offset col' (line + 1) + return $ PlusOne $ FU.Position offset col' (line + 1) f p instance Arbitrary FU.Position where arbitrary = do offset <- arbitrary `suchThat` (>0) line <- arbitrary `suchThat` (\x -> x >= 1 && x <= (length text)) col <- choose (1, orOne $ length (text !! (line - 1))) - return $ FU.Position offset col line + return $ FU.Position offset col line "" Nothing orOne x | x == 0 = 1 | otherwise = x diff --git a/tests/Camfort/Specification/DerivedDataTypeSpec.hs b/tests/Camfort/Specification/DerivedDataTypeSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Camfort/Specification/DerivedDataTypeSpec.hs @@ -0,0 +1,78 @@ +module Camfort.Specification.DerivedDataTypeSpec (spec) where + +import System.FilePath (()) + +import Control.Lens + +import Test.Hspec hiding (Spec) +import qualified Test.Hspec as Test + +import qualified Language.Fortran.AST as F +import Language.Fortran.Util.ModFile (ModFile, emptyModFiles) + +import Camfort.Analysis hiding (describe) +import Camfort.Analysis.ModFile (genModFiles) +import Camfort.Input (readParseSrcDir) +import Camfort.Specification.DerivedDataType + +import qualified Data.Map.Strict as M +import qualified Data.Set as S + +fixturesDir :: String +fixturesDir = "tests" "fixtures" "Specification" "DerivedDataType" + +ddtInferReport :: [String] -> String -> IO DerivedDataTypeReport +ddtInferReport modNames fileName = do + let file = fixturesDir fileName + modPaths = fmap (fixturesDir ) modNames + modFiles <- mapM mkTestModFile modPaths + [(pf,_)] <- readParseSrcDir Nothing modFiles file [] + + let r = runIdentity $ runAnalysisT file (logOutputNone True) LogError modFiles (infer pf) + return $ r ^?! arResult . _ARSuccess + +-- | Helper for producing a basic ModFile from a (terminal) module file. +mkTestModFile :: String -> IO ModFile +mkTestModFile file = head <$> genModFiles Nothing emptyModFiles compile () file [] + +spec :: Test.Spec +spec = do + describe "consistent" $ do + describe "across modfiles" $ do + it "consistent where labels overlap" $ do + r <- ddtInferReport ["consistSpec1b.f90"] "consistSpec1a.f90" + successful r `shouldBe` True + it "starred spec overrides unstarred spec" $ do + r <- ddtInferReport ["consistSpec2b.f90"] "consistSpec2a.f90" + successful r `shouldBe` True + describe "error-finding" $ do + describe "bad dimensions" $ do + it "dim violates min bound" $ do + r <- ddtInferReport [] "badDim1.f90" + map (fmap (fst . head . S.toList)) (M.toList (ddtrBDE r)) `shouldBe` [(("example_d_common", 0), 0)] + it "dim violates max bound" $ do + r <- ddtInferReport [] "badDim2.f90" + map (fmap (fst . head . S.toList)) (M.toList (ddtrBDE r)) `shouldBe` [(("example_d_common", 3), 2)] + describe "bad labelling" $ do + it "dupped index" $ do + r <- ddtInferReport [] "dupIndex1.f90" + S.size (ddtrIDE r) `shouldBe` 1 + it "out-of-bounds index" $ do + r <- ddtInferReport [] "oobIndex1.f90" + S.size (ddtrIDE r) `shouldBe` 1 + it "dupped label" $ do + r <- ddtInferReport [] "badLabel1.f90" + map (fmap (fst . head . S.toList)) (M.toList (ddtrBLE r)) `shouldBe` [(("example_d_common", 2), "label1")] + describe "inconsistent specs" $ do + it "differing type names" $ do + r <- ddtInferReport ["inconsistSpec1b.f90"] "inconsistSpec1a.f90" + map (fmap S.size) (M.toList (ddtrCE r)) `shouldBe` [(("inconsist1_d_common", 2), 2)] + it "clashing label names" $ do + r <- ddtInferReport ["inconsistSpec2b.f90"] "inconsistSpec2a.f90" + map (fmap S.size) (M.toList (ddtrCE r)) `shouldBe` [(("inconsist2_d_common", 2), 2)] + it "disagreeing on label names" $ do + r <- ddtInferReport ["inconsistSpec3b.f90"] "inconsistSpec3a.f90" + map (fmap S.size) (M.toList (ddtrCE r)) `shouldBe` [(("inconsist3_d_common", 2), 2)] + it "when starred specs disagree" $ do + r <- ddtInferReport ["inconsistSpec4b.f90"] "inconsistSpec4a.f90" + map (fmap S.size) (M.toList (ddtrCE r)) `shouldBe` [(("inconsist4_d_common", 2), 2)] diff --git a/tests/Camfort/Specification/Hoare/ParserSpec.hs b/tests/Camfort/Specification/Hoare/ParserSpec.hs --- a/tests/Camfort/Specification/Hoare/ParserSpec.hs +++ b/tests/Camfort/Specification/Hoare/ParserSpec.hs @@ -114,7 +114,7 @@ matches a b = stripSpans a == stripSpans b -defSpan = F.SrcSpan (F.Position 0 0 0) (F.Position 0 0 0) +defSpan = F.SrcSpan (F.Position 0 0 0 "" Nothing) (F.Position 0 0 0 "" Nothing) parse :: String -> Either (Parser.SpecParseError HoareParseError) (SpecOrDecl ()) parse = runParser hoareParser diff --git a/tests/Camfort/Specification/StencilsSpec.hs b/tests/Camfort/Specification/StencilsSpec.hs --- a/tests/Camfort/Specification/StencilsSpec.hs +++ b/tests/Camfort/Specification/StencilsSpec.hs @@ -284,6 +284,13 @@ assertStencilSynthNoWarn "example5.f90" "inserts correct comment types for modern fortran" + describe "integration test on inference for example5a (with constant-prop.)" $ + describe "stencil synth" $ do + assertStencilSynthNoWarn "example5a.f" + "inserts correct comment types for old fortran" + assertStencilSynthNoWarn "example5a.f90" + "inserts correct comment types for modern fortran" + describe "synth on files already containing stencils" $ do assertStencilSynthNoWarn "example6.f" "complements existing stencils (when second missing)" @@ -455,7 +462,7 @@ modPaths = fmap (fixturesDir ) modNames modFiles <- mapM mkTestModFile modPaths - [(pf, _)] <- readParseSrcDir modFiles file [] + [(pf, _)] <- readParseSrcDir Nothing modFiles file [] let report = runIdentity $ runAnalysisT (F.pfGetFilename pf) (logOutputNone True) LogError modFiles (infer False '=' pf) @@ -463,7 +470,7 @@ -- | Helper for producing a basic ModFile from a (terminal) module file. mkTestModFile :: String -> IO ModFile -mkTestModFile file = head <$> genModFiles emptyModFiles compileStencils () file [] +mkTestModFile file = head <$> genModFiles Nothing emptyModFiles compileStencils () file [] crossModuleAUserReport :: [L.Text] crossModuleAUserReport = diff --git a/tests/Camfort/Specification/Units/Analysis/ConsistentSpec.hs b/tests/Camfort/Specification/Units/Analysis/ConsistentSpec.hs --- a/tests/Camfort/Specification/Units/Analysis/ConsistentSpec.hs +++ b/tests/Camfort/Specification/Units/Analysis/ConsistentSpec.hs @@ -60,7 +60,7 @@ let file = fixturesDir fileName modPaths = fmap (fixturesDir ) modNames modFiles <- mapM mkTestModFile modPaths - [(pf,_)] <- readParseSrcDir modFiles file [] + [(pf,_)] <- readParseSrcDir Nothing modFiles file [] let uEnv = UnitEnv { unitOpts = uOpts, unitProgramFile = pf } @@ -82,7 +82,7 @@ -- | Helper for producing a basic ModFile from a (terminal) module file. mkTestModFile :: String -> IO ModFile -mkTestModFile file = head <$> genModFiles emptyModFiles compileUnits unitOpts0 file [] +mkTestModFile file = head <$> genModFiles Nothing emptyModFiles compileUnits unitOpts0 file [] exampleInconsist1CheckReport :: String exampleInconsist1CheckReport = @@ -90,62 +90,54 @@ \ - at 7:7: Units 's' and 'm' should be equal\n" inconsist3LitMixedReport :: String -inconsist3LitMixedReport = inconsist3LitPolyReport +inconsist3LitMixedReport = + "\ntests/fixtures/Specification/Units/inconsist3.f90: Inconsistent:\n\ + \ - at 6:3: 'j**2' should have the same units as 'k'\n" inconsist3LitPolyReport :: String inconsist3LitPolyReport = "\ntests/fixtures/Specification/Units/inconsist3.f90: Inconsistent:\n\ - \ - at 6:3: 'j**2' should have the same units as 'k'\n\ - \ - at 7:7: 'k' should have unit 'a'\n\ - \ - at 8:3: 'j' should have unit '1'\n" + \ - at 6:3: 'j**2' should have the same units as 'k'\n" inconsist3LitUnitlessReport :: String inconsist3LitUnitlessReport = "\ntests/fixtures/Specification/Units/inconsist3.f90: Inconsistent:\n\ - \ - at 5:3: 'j' should have unit '1'\n\ - \ - at 6:3: 'j**2' should have the same units as 'k'\n\ - \ - at 7:7: 'k' should have unit 'a'\n" + \ - at 6:3: 'j**2' should have the same units as 'k'\n" inconsistLitInPolyFunReport :: String inconsistLitInPolyFunReport = "\ntests/fixtures/Specification/Units/inconsistLitInPolyFun.f90: Inconsistent:\n\ - \ - at 10:11: 'parameter 1 to sqr' should have unit 'm'\n\ - \ - at 15:13: 'z' should have unit '1'\n\ - \ - at 16:11: '(parameter 1 to sqr)**2' should have the same units as 'z'\n" + \ - at 10:3: 'a' should have the same units as 'result of sqr'\n\ + \ - at 10:11: 'parameter 1 to sqr' should have unit 'm'\n" inconsistRecMultReport :: String inconsistRecMultReport = "\ntests/fixtures/Specification/Units/inconsistRecMult.f90: Inconsistent:\n\ - \'parameter 2 to recur' should have the same units as 'parameter 2 to recur'\n\ - \'result of recur * parameter 2 to recur' should have the same units as 'result of recur'\n\ - \ - at 4:15: 'parameter 2 to recur' should have unit 'm'\n\ - \ - at 10:8: 'parameter 2 to recur' should have the same units as 'result of recur'\n" + \ - at 4:15: 'parameter 2 to recur' should have unit 'm'\n" crossModuleInconsistBasicReport :: String crossModuleInconsistBasicReport = "\ntests/fixtures/Specification/Units/cross-module-a/crossmoduleuser.f90: Inconsistent:\n\ - \'add' should have the same units as 'parameter 1 to add'\n\ - \'add' should have the same units as 'parameter 2 to add'\n\ - \ - at 9:11: 'parameter 1 to add' should have unit 'm'\n\ - \ - at 9:14: 'parameter 2 to add' should have unit 's'\n" + \ - at 9:11: 'parameter 1 to add' should have unit 'm'\n" literalNonZeroInconsist1Report :: String literalNonZeroInconsist1Report = "\ntests/fixtures/Specification/Units/literal-nonzero-inconsist1.f90: Inconsistent:\n\ - \ - at 11:5: 'f_'a' should have unit '1'\n" + \'literal number' should have unit '1'\n" literalNonZeroInconsist2Report :: String literalNonZeroInconsist2Report = "\ntests/fixtures/Specification/Units/literal-nonzero-inconsist2.f90: Inconsistent:\n\ - \ - at 5:9: 'parameter 1 to f' should have unit 'm'\n\ - \ - at 10:5: 'parameter 1 to f' should have unit '1'\n" + \ - at 6:3: 'b' should have the same units as 'result of f'\n\ + \ - at 6:9: 'parameter 1 to f' should have unit 'm'\n" literalNonZeroInconsist3Report :: String literalNonZeroInconsist3Report = "\ntests/fixtures/Specification/Units/literal-nonzero-inconsist3.f90: Inconsistent:\n\ - \ - at 7:11: 'parameter 1 to sqr' should have unit 's'\n\ - \ - at 12:3: 'i' should have the same units as 'parameter 1 to sqr'\n\ - \ - at 15:8: 'i' should have unit '1'\n" + \ - at 6:3: 'result of sqr' should have unit 'm'\n\ + \ - at 6:11: 'parameter 1 to sqr' should have unit 'm'\n\ + \ - at 7:3: 'result of sqr' should have unit 's'\n\ + \ - at 7:11: 'parameter 1 to sqr' should have unit 's'\n" literalNonZeroInconsist4Report :: String -- fixme literalNonZeroInconsist4Report = @@ -157,7 +149,5 @@ literalNonZeroInconsist5Report :: String literalNonZeroInconsist5Report = "\ntests/fixtures/Specification/Units/literal-nonzero-inconsist5.f90: Inconsistent:\n\ - \ - at 7:11: 'parameter 1 to sqr' should have unit 's'\n\ - \ - at 13:23: 'j' should have unit '1'\n\ - \ - at 15:9: 'i' should have the same units as 'parameter 1 to sqr'\n\ - \ - at 17:12: 'j' should have the same units as 'i'\n" + \ - at 6:3: 'result of sqr' should have unit 'm'\n\ + \ - at 6:11: 'parameter 1 to sqr' should have unit 'm'\n" diff --git a/tests/Camfort/Specification/Units/Analysis/CriticalsSpec.hs b/tests/Camfort/Specification/Units/Analysis/CriticalsSpec.hs --- a/tests/Camfort/Specification/Units/Analysis/CriticalsSpec.hs +++ b/tests/Camfort/Specification/Units/Analysis/CriticalsSpec.hs @@ -32,7 +32,7 @@ unitsCriticalsReportIs fileName expectedReport = do let file = fixturesDir fileName modFiles = emptyModFiles - [(pf,_)] <- readParseSrcDir modFiles file [] + [(pf,_)] <- readParseSrcDir Nothing modFiles file [] let uEnv = UnitEnv { unitOpts = uOpts, unitProgramFile = pf } diff --git a/tests/Camfort/Specification/Units/Analysis/InferSpec.hs b/tests/Camfort/Specification/Units/Analysis/InferSpec.hs --- a/tests/Camfort/Specification/Units/Analysis/InferSpec.hs +++ b/tests/Camfort/Specification/Units/Analysis/InferSpec.hs @@ -7,10 +7,11 @@ import Test.Hspec hiding (Spec) import qualified Test.Hspec as Test -import Language.Fortran.Util.ModFile (emptyModFiles) +import Language.Fortran.Util.ModFile (ModFile, emptyModFiles) import Camfort.Analysis hiding (describe) -import Camfort.Analysis.ModFile (readParseSrcDir) +import Camfort.Analysis.ModFile (genModFiles, readParseSrcDir) +import Camfort.Specification.Units.Analysis (compileUnits) import Camfort.Specification.Units.Analysis.Infer (inferUnits) import Camfort.Specification.Units.Monad (LiteralsOpt(..), unitOpts0, uoLiterals, runUnitAnalysis, UnitEnv(..)) @@ -50,21 +51,34 @@ "literal-zero.f90" `unitsInferReportIs` literalZeroReport it "literal-nonzero" $ "literal-nonzero.f90" `unitsInferReportIs` literalNonZeroReport + it "literal-nonzero" $ + "literal-nonzero2.f90" `unitsInferReportIs` literalNonZero2Report it "do-loop1" $ "do-loop1.f90" `unitsInferReportIs` doLoop1Report it "do-loop2" $ "do-loop2.f90" `unitsInferReportIs` doLoop2Report + describe "cross module analysis" $ do + it "with literals" $ + unitsInferReportWithMod ["cross-module-b/cross-module-b1.f90"] "cross-module-b/cross-module-b2.f90" + crossModuleBReport + fixturesDir :: String fixturesDir = "tests" "fixtures" "Specification" "Units" -- | Assert that the report of performing units inference on a file is as expected. unitsInferReportIs :: String -> String -> Expectation unitsInferReportIs fileName expectedReport = do + unitsInferReportWithMod [] fileName expectedReport + +-- | Assert that the report of performing units inference on a file is as expected (with mod files). +unitsInferReportWithMod :: [String] -> String -> String -> Expectation +unitsInferReportWithMod modNames fileName expectedReport = do let file = fixturesDir fileName - modFiles = emptyModFiles - [(pf,_)] <- readParseSrcDir modFiles file [] + modPaths = fmap (fixturesDir ) modNames + modFiles <- mapM mkTestModFile modPaths + [(pf,_)] <- readParseSrcDir Nothing modFiles file [] let uEnv = UnitEnv { unitOpts = uOpts, unitProgramFile = pf } @@ -74,6 +88,10 @@ show res `shouldBe` expectedReport where uOpts = unitOpts0 { uoLiterals = LitMixed } +-- | Helper for producing a basic ModFile from a (terminal) module file. +mkTestModFile :: String -> IO ModFile +mkTestModFile file = head <$> genModFiles Nothing emptyModFiles compileUnits unitOpts0 file [] + exampleInferSimple1Report :: String exampleInferSimple1Report = "\ntests/fixtures/Specification/Units/example-simple-1.f90:\n\ @@ -89,10 +107,10 @@ \ 5:11 unit s**2 :: y\n\ \ 7:11 unit m :: a\n\ \ 9:11 unit s :: b\n\ - \ 13:3 unit ('a)**2 :: square\n\ - \ 14:13 unit 'a :: n\n\ - \ 17:3 unit ('b)**2 :: squarep\n\ - \ 18:13 unit 'b :: m\n" + \ 13:3 unit ('b)**2 :: square\n\ + \ 14:13 unit 'b :: n\n\ + \ 17:3 unit ('a)**2 :: squarep\n\ + \ 18:13 unit 'a :: m\n" recursive1Report :: String recursive1Report = inferReport "recursive1.f90" @@ -185,6 +203,15 @@ \ 8:3 unit m s :: f\n\ \ 10:13 unit m s :: x\n" +literalNonZero2Report :: String +literalNonZero2Report = inferReport "literal-nonzero2.f90" + " 3:11 unit m :: a\n\ + \ 3:14 unit m :: b\n\ + \ 3:17 unit m :: c\n\ + \ 3:20 unit m :: d\n\ + \ 10:3 unit m :: f\n\ + \ 11:13 unit m :: x\n" + doLoop1Report :: String doLoop1Report = inferReport "do-loop1.f90" " 3:11 unit m :: x\n\ @@ -212,3 +239,10 @@ \ 29:13 unit 'a :: x\n\ \ 29:16 unit 'a :: y\n\ \ 30:16 unit 'a :: i\n" + +crossModuleBReport :: String +crossModuleBReport = + "\ntests/fixtures/Specification/Units/cross-module-b/cross-module-b2.f90:\n\ + \ 6:24 unit c :: foo\n\ + \ 9:13 unit c :: tc\n\ + \ 9:17 unit k :: t\n" diff --git a/tests/Camfort/Transformation/CommonSpec.hs b/tests/Camfort/Transformation/CommonSpec.hs --- a/tests/Camfort/Transformation/CommonSpec.hs +++ b/tests/Camfort/Transformation/CommonSpec.hs @@ -37,6 +37,8 @@ , ceIncludeDir = Just (takeDirectory commonFile) , ceExcludeFiles = [] , ceLogLevel = LogDebug + , ceSourceSnippets = False + , ceFortranVersion = Nothing } runIO $ common outFile env diff --git a/tests/Camfort/Transformation/EquivalenceElimSpec.hs b/tests/Camfort/Transformation/EquivalenceElimSpec.hs --- a/tests/Camfort/Transformation/EquivalenceElimSpec.hs +++ b/tests/Camfort/Transformation/EquivalenceElimSpec.hs @@ -59,6 +59,8 @@ , ceIncludeDir = Nothing , ceExcludeFiles = [] , ceLogLevel = LogInfo + , ceSourceSnippets = False + , ceFortranVersion = Nothing } equivalences outFile env @@ -76,7 +78,7 @@ let infile = samplesBase "equiv.f90" - input = testInputSources infile & tiIncludeDir .~ Just infile + input = testInputSources infile it "log is as expected" $ testSingleFileAnalysis input (generalizePureAnalysis . refactorEquivalences) $ \report -> do @@ -91,7 +93,7 @@ , ((15, 3), addCopyMsg) ] - spanMatches (pl, pc) (FU.SrcSpan (FU.Position _ pc1 pl1) (FU.Position _ pc2 pl2)) = + spanMatches (pl, pc) (FU.SrcSpan (FU.Position _ pc1 pl1 _ _) (FU.Position _ pc2 pl2 _ _)) = pl == pl1 && pl == pl2 && pc == pc1 && pc == pc2 diff --git a/tests/fixtures/Specification/Stencils/example10.expected.f b/tests/fixtures/Specification/Stencils/example10.expected.f new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Stencils/example10.expected.f @@ -0,0 +1,15 @@ + program example10 + + integer i, imax + parameter (imax = 3) + + real a(0:imax), b(0:imax) + + do 1 i = 1, (imax-1) + if (.true.) then +c= stencil readOnce, (pointed(dim=1)) :: b + a(i) = b(i) + end if + 1 continue + + end diff --git a/tests/fixtures/Specification/Stencils/example11.expected.f b/tests/fixtures/Specification/Stencils/example11.expected.f new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Stencils/example11.expected.f @@ -0,0 +1,15 @@ + program example11 + + integer i, imax + parameter (imax = 3) + + real a(0:imax), b(0:imax), x + + do 1 i = 1, (imax-1) + if (.true.) then +c= access readOnce, pointed(dim=1) :: b + x = b(i) + end if + 1 continue + + end diff --git a/tests/fixtures/Specification/Stencils/example13.expected.f b/tests/fixtures/Specification/Stencils/example13.expected.f new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Stencils/example13.expected.f @@ -0,0 +1,15 @@ + program example13 + implicit none + + integer i, imax + parameter (imax = 3) + real a(0:imax) + +c= region :: r1 = pointed(dim=1) + do i = 0, imax +c= stencil readOnce, atLeast, r1 :: a +c= stencil readOnce, atMost, forward(depth=2, dim=1) :: a + a(i) = a(i) + a(i+2) + end do + + end diff --git a/tests/fixtures/Specification/Stencils/example14.expected.f b/tests/fixtures/Specification/Stencils/example14.expected.f new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Stencils/example14.expected.f @@ -0,0 +1,15 @@ + program example14 + implicit none + + integer i, imax + parameter (imax = 3) + real a(0:imax) + + do i = 0, imax +c= stencil readOnce, atLeast, pointed(dim=1) :: a +c= stencil readOnce, atLeast, pointed(dim=1) :: a +c= stencil readOnce, atMost, forward(depth=2, dim=1) :: a + a(i) = a(i) + a(i+2) + end do + + end diff --git a/tests/fixtures/Specification/Stencils/example15.expected.f b/tests/fixtures/Specification/Stencils/example15.expected.f new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Stencils/example15.expected.f @@ -0,0 +1,13 @@ + program example15 + implicit none + + integer i + real a(0:10) + + do i = 0, 10 +c= stencil readOnce, forward(depth=1, dim=1) :: a +c= stencil readOnce, forward(depth=1, dim=1) :: a + a(i) = a(i) + a(i+1) + end do + + end diff --git a/tests/fixtures/Specification/Stencils/example5.expected.f b/tests/fixtures/Specification/Stencils/example5.expected.f new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Stencils/example5.expected.f @@ -0,0 +1,14 @@ + program example5 + implicit none + + integer i, imax + parameter (imax = 3) + real a(0:imax) + + do i = 0, imax +c= stencil readOnce, atLeast, pointed(dim=1) :: a +c= stencil readOnce, atMost, forward(depth=2, dim=1) :: a + a(i) = a(i) + a(i+2) + end do + + end diff --git a/tests/fixtures/Specification/Stencils/example5a.expected.f b/tests/fixtures/Specification/Stencils/example5a.expected.f new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Stencils/example5a.expected.f @@ -0,0 +1,14 @@ + program example5 + implicit none + + integer i, imax, x + parameter (imax = 3, x = (1+1)*imax-2*(1+1)) + real a(0:imax) + + do i = 0, imax +c= stencil readOnce, atLeast, pointed(dim=1) :: a +c= stencil readOnce, atMost, forward(depth=2, dim=1) :: a + a(i) = a(i) + a(i+x) + end do + + end diff --git a/tests/fixtures/Specification/Stencils/example5a.f b/tests/fixtures/Specification/Stencils/example5a.f new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Stencils/example5a.f @@ -0,0 +1,12 @@ + program example5 + implicit none + + integer i, imax, x + parameter (imax = 3, x = (1+1)*imax-2*(1+1)) + real a(0:imax) + + do i = 0, imax + a(i) = a(i) + a(i+x) + end do + + end diff --git a/tests/fixtures/Specification/Stencils/example6.expected.f b/tests/fixtures/Specification/Stencils/example6.expected.f new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Stencils/example6.expected.f @@ -0,0 +1,14 @@ + program example6 + implicit none + + integer i, imax + parameter (imax = 3) + real a(0:imax) + + do i = 0, imax +c= stencil readOnce, atLeast, pointed(dim=1) :: a +c= stencil readOnce, atMost, forward(depth=2, dim=1) :: a + a(i) = a(i) + a(i+2) + end do + + end diff --git a/tests/fixtures/Specification/Stencils/example7.expected.f b/tests/fixtures/Specification/Stencils/example7.expected.f new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Stencils/example7.expected.f @@ -0,0 +1,14 @@ + program example7 + implicit none + + integer i, imax + parameter (imax = 3) + real a(0:imax) + + do i = 0, imax +c= stencil readOnce, atLeast, pointed(dim=1) :: a +c= stencil readOnce, atMost, forward(depth=2, dim=1) :: a + a(i) = a(i) + a(i+2) + end do + + end diff --git a/tests/fixtures/Specification/Stencils/example8.expected.f b/tests/fixtures/Specification/Stencils/example8.expected.f new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Stencils/example8.expected.f @@ -0,0 +1,14 @@ + program example8 + implicit none + + integer i, imax + parameter (imax = 3) + real a(0:imax) + + do i = 0, imax +c= stencil readOnce, atMost, forward(depth=2, dim=1) :: a +c= stencil readOnce, atLeast, pointed(dim=1) :: a + a(i) = a(i) + a(i+2) + end do + + end diff --git a/tests/fixtures/Specification/Stencils/example9.expected.f b/tests/fixtures/Specification/Stencils/example9.expected.f new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Stencils/example9.expected.f @@ -0,0 +1,13 @@ + program example9 + + integer i, imax + parameter (imax = 3) + + real a(0:imax), b(0:imax) + + do 1 i = 1, (imax-1) +c= stencil readOnce, pointed(dim=1) :: b + a(i) = b(i) + 1 continue + + end diff --git a/tests/fixtures/Specification/Units/exp.ex1.f90 b/tests/fixtures/Specification/Units/exp.ex1.f90 new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Units/exp.ex1.f90 @@ -0,0 +1,29 @@ +program energy + != unit :: speed = m/s + + != unit (m / s** (2)) :: gravity + != unit (m) :: height + != unit (kg) :: mass + real, parameter :: mass = 3.00, gravity = 9.81, height = 4.20 + != unit (kg m** (2) / s** (2)) :: potential_energy + real :: potential_energy + + != unit (1) :: half + != unit (speed) :: velocity + real, parameter :: half = 0.5, velocity = 4.00 + != unit (kg m** (2) / s** (2)) :: kinetic_energy + != unit (kg m** (2) / s** (2)) :: total_energy + real :: kinetic_energy, total_energy + + potential_energy = mass * gravity * height + kinetic_energy = half * mass * square(velocity) + + total_energy = potential_energy + kinetic_energy + + contains + + real function square(x) + real x + square = x * x + end function square +end program energy diff --git a/tests/fixtures/Specification/Units/exp.ex2.f90 b/tests/fixtures/Specification/Units/exp.ex2.f90 new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Units/exp.ex2.f90 @@ -0,0 +1,12 @@ +program energy + + != unit (m) :: height + != unit (kg) :: mass + != unit (m / s**2) :: gravity + real, parameter :: mass = 3.00, gravity = .81, height = 4.20 + + != unit (kg m** (2) / s** (2)) :: potential_energy + real :: potential_energy + + potential_energy = mass * gravity * height +end program energy diff --git a/tests/fixtures/Specification/Units/exp.ex3.f90 b/tests/fixtures/Specification/Units/exp.ex3.f90 new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Units/exp.ex3.f90 @@ -0,0 +1,17 @@ +program energy + + != unit (m) :: height + != unit (kg) :: mass + != unit (m / s**2) :: gravity + real, parameter :: mass = 3.00, gravity = .81, height = 4.20 + + != unit (1) :: i + integer :: i = 0 + != unit (1) :: j + integer :: j = i + + != unit (kg m**2 / s**2) :: potential_energy + real :: potential_energy + + potential_energy = mass * gravity * height +end program energy diff --git a/tests/fixtures/Specification/Units/exp.param.f90 b/tests/fixtures/Specification/Units/exp.param.f90 new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Units/exp.param.f90 @@ -0,0 +1,12 @@ + program param + implicit none + != unit(m) :: x, y + real, parameter :: x = 4, y = 5 + != unit(s) :: t + real, parameter :: t = 2 + != unit (m / s) :: v1 + != unit (m / s) :: v2 + real :: v1, v2 + v1 = x / t + v2 = y / t + end program diff --git a/tests/fixtures/Specification/Units/literal-nonzero-inconsist2.f90 b/tests/fixtures/Specification/Units/literal-nonzero-inconsist2.f90 --- a/tests/fixtures/Specification/Units/literal-nonzero-inconsist2.f90 +++ b/tests/fixtures/Specification/Units/literal-nonzero-inconsist2.f90 @@ -1,9 +1,11 @@ program literalnonzero != unit m :: a - real :: a, b + != unit s :: c + real :: a, b, c, d a = 2 b = f(a) - + c = 3 + d = f(c) contains real function f(x) real :: x diff --git a/tests/fixtures/Specification/Units/literal-nonzero-inconsist3.f90 b/tests/fixtures/Specification/Units/literal-nonzero-inconsist3.f90 --- a/tests/fixtures/Specification/Units/literal-nonzero-inconsist3.f90 +++ b/tests/fixtures/Specification/Units/literal-nonzero-inconsist3.f90 @@ -31,6 +31,7 @@ ! ! with it enabled (normal): ! tests/fixtures/Specification/Units/literal-nonzero-inconsist3.f90: Inconsistent: -! - at 7:11: 'parameter 1 to sqr' should have unit 's' -! - at 12:3: 'i' should have the same units as 'parameter 1 to sqr' -! - at 15:8: 'i' should have unit '1' +! - at 6:3: 'result of sqr' should have unit 'm' +! - at 6:11: 'parameter 1 to sqr' should have unit 'm' +! - at 7:3: 'result of sqr' should have unit 's' +! - at 7:11: 'parameter 1 to sqr' should have unit 's' diff --git a/tests/fixtures/Specification/Units/literal-nonzero-inconsist5.f90 b/tests/fixtures/Specification/Units/literal-nonzero-inconsist5.f90 --- a/tests/fixtures/Specification/Units/literal-nonzero-inconsist5.f90 +++ b/tests/fixtures/Specification/Units/literal-nonzero-inconsist5.f90 @@ -34,6 +34,5 @@ ! ! with it enabled (normal): ! tests/fixtures/Specification/Units/literal-nonzero-inconsist5.f90: Inconsistent: -! - at 7:11: 'parameter 1 to sqr' should have unit 's' -! - at 15:9: 'i' should have the same units as 'parameter 1 to sqr' -! - at 17:12: 'i' should have unit '1' +! - at 6:3: 'result of sqr' should have unit 'm' +! - at 6:11: 'parameter 1 to sqr' should have unit 'm' diff --git a/tests/fixtures/Specification/Units/literal-nonzero2.f90 b/tests/fixtures/Specification/Units/literal-nonzero2.f90 new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Units/literal-nonzero2.f90 @@ -0,0 +1,15 @@ +program literalnonzero + != unit m :: a, c + real :: a, b, c, d + real, parameter :: n = 1.0 + a = 2.0 + b = f(a) + c = 3.0 + d = f(c) +contains + real function f(x) + real :: x + x = n + f = x + end function f +end program literalnonzero diff --git a/tests/fixtures/Transformation/cmn.expected.f90 b/tests/fixtures/Transformation/cmn.expected.f90 new file mode 100644 --- /dev/null +++ b/tests/fixtures/Transformation/cmn.expected.f90 @@ -0,0 +1,5 @@ +module Cmn + integer, save :: Cmn_c1 + integer, save :: Cmn_c2 + integer, save :: Cmn_c3 +end module Cmn diff --git a/tests/fixtures/Transformation/common.expected.f90 b/tests/fixtures/Transformation/common.expected.f90 new file mode 100644 --- /dev/null +++ b/tests/fixtures/Transformation/common.expected.f90 @@ -0,0 +1,9 @@ +subroutine test(a,b, c) + +use Cmn, c1 => Cmn_c1, c2 => Cmn_c2, c3 => Cmn_c3 + +real :: a, b, c + +print *, a, b, c + +end subroutine test diff --git a/tests/fixtures/Transformation/equiv.expected.f90 b/tests/fixtures/Transformation/equiv.expected.f90 new file mode 100644 --- /dev/null +++ b/tests/fixtures/Transformation/equiv.expected.f90 @@ -0,0 +1,21 @@ +program wrt + implicit none + integer :: x = 97 + character :: y + character :: z(20) + + z(1) = "c" + + write (*,'(i8,A)') x, y + + + write (*,'(i8,A,A,A)') x, y, z(1), z(2) + + x = 97 + 98 * (2**8) + y = transfer(x, y) + z(2) = transfer(x, z(2)) + + write (*,'(i8,A,A,A,A)') x, y, z(1), z(2), z(3) + + +end program wrt