diff --git a/camfort.cabal b/camfort.cabal --- a/camfort.cabal +++ b/camfort.cabal @@ -1,5 +1,5 @@ name: camfort -version: 0.901 +version: 0.902 synopsis: CamFort - Cambridge Fortran infrastructure description: CamFort is a tool for the analysis, transformation, verification of Fortran code. @@ -34,6 +34,8 @@ 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 @@ -50,6 +52,7 @@ Camfort.Specification.Units.Synthesis Camfort.Transformation.CommonBlockElim Camfort.Transformation.DeadCode + Camfort.Transformation.DataTypeIntroduction Camfort.Transformation.EquivalenceElim Camfort.Helpers Camfort.Helpers.Syntax @@ -76,10 +79,14 @@ transformers >= 0.4, GenericPretty >= 1.2, QuickCheck >= 2.8, - fortran-src >= 0.1.0.4, + fortran-src == 0.1.0.6, filepath, fgl >= 5.5, - bytestring >= 0.10 + bytestring >= 0.10, + binary >= 0.8.3.0, + lattices >= 1.5, + sbv >= 5.14, + partial-order >= 0.1.2 default-language: Haskell2010 library @@ -91,6 +98,8 @@ 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 @@ -107,6 +116,7 @@ Camfort.Specification.Units.Synthesis Camfort.Transformation.CommonBlockElim Camfort.Transformation.DeadCode + Camfort.Transformation.DataTypeIntroduction Camfort.Transformation.EquivalenceElim Camfort.Helpers Camfort.Helpers.Syntax @@ -131,10 +141,14 @@ transformers >= 0.4, vector >= 0.1, GenericPretty >= 1.2, - fortran-src >= 0.1.0.4, + fortran-src == 0.1.0.6, filepath, bytestring >= 0.10, - fgl >= 5.5 + fgl >= 5.5, + binary >= 0.8.3.0, + lattices >= 1.5, + sbv >= 5.14, + partial-order >= 0.1.2 default-language: Haskell2010 test-suite spec @@ -142,9 +156,11 @@ main-is: Spec.hs hs-source-dirs: tests other-modules: Camfort.Analysis.CommentAnnotatorSpec - Camfort.Helpers.VecSpec Camfort.Specification.Stencils.CheckSpec + Camfort.Specification.Stencils.ConsistencySpec + Camfort.Specification.Stencils.DenotationalSemanticsSpec Camfort.Specification.Stencils.GrammarSpec + Camfort.Specification.Stencils.InferenceBackendSpec Camfort.Specification.Stencils.ModelSpec Camfort.Specification.StencilsSpec Camfort.Specification.UnitsSpec @@ -156,12 +172,16 @@ directory >= 1.2, hspec >= 2.2, QuickCheck >= 2.8, - fortran-src >= 0.1.0.4, + fortran-src == 0.1.0.6, uniplate >= 1.6.10, mtl >= 2.1, bytestring >= 0.10, array >= 0.4, hmatrix >= 0.15, text >= 0.11.2.3, + binary >= 0.8.3.0, + lattices >= 1.5, + sbv >= 5.14, + partial-order >= 0.1.2, camfort default-language: Haskell2010 diff --git a/dist/build/Camfort/Specification/Stencils/Grammar.hs b/dist/build/Camfort/Specification/Stencils/Grammar.hs deleted file mode 100644 --- a/dist/build/Camfort/Specification/Stencils/Grammar.hs +++ /dev/null @@ -1,980 +0,0 @@ -{-# OPTIONS_GHC -w #-} -{-# OPTIONS -fglasgow-exts -cpp #-} --- -*- Mode: Haskell -*- -{-# LANGUAGE DeriveDataTypeable, PatternGuards #-} -module Camfort.Specification.Stencils.Grammar -( specParser, Specification(..), Region(..), Spec(..), Mod(..), lexer ) where - -import Data.Char (isLetter, isNumber, isAlphaNum, toLower, isAlpha, isSpace) -import Data.List (intersect, sort, isPrefixOf) -import Data.Data -import qualified Data.Text as T - -import Debug.Trace - -import Camfort.Analysis.CommentAnnotator -import Camfort.Specification.Stencils.Syntax (showL) -import qualified Data.Array as Happy_Data_Array -import qualified GHC.Exts as Happy_GHC_Exts -import Control.Applicative(Applicative(..)) -import Control.Monad (ap) - --- parser produced by Happy Version 1.19.5 - -newtype HappyAbsSyn = HappyAbsSyn HappyAny -#if __GLASGOW_HASKELL__ >= 607 -type HappyAny = Happy_GHC_Exts.Any -#else -type HappyAny = forall a . a -#endif -happyIn4 :: (Specification) -> (HappyAbsSyn ) -happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn4 #-} -happyOut4 :: (HappyAbsSyn ) -> (Specification) -happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut4 #-} -happyIn5 :: ((String, Region)) -> (HappyAbsSyn ) -happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn5 #-} -happyOut5 :: (HappyAbsSyn ) -> ((String, Region)) -happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut5 #-} -happyIn6 :: (Region) -> (HappyAbsSyn ) -happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn6 #-} -happyOut6 :: (HappyAbsSyn ) -> (Region) -happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut6 #-} -happyIn7 :: ((Depth Int, Dim Int, Bool)) -> (HappyAbsSyn ) -happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn7 #-} -happyOut7 :: (HappyAbsSyn ) -> ((Depth Int, Dim Int, Bool)) -happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut7 #-} -happyIn8 :: ((Dim Int, Bool)) -> (HappyAbsSyn ) -happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn8 #-} -happyOut8 :: (HappyAbsSyn ) -> ((Dim Int, Bool)) -happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut8 #-} -happyIn9 :: ((Depth Int, Bool)) -> (HappyAbsSyn ) -happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn9 #-} -happyOut9 :: (HappyAbsSyn ) -> ((Depth Int, Bool)) -happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut9 #-} -happyIn10 :: (Depth Int) -> (HappyAbsSyn ) -happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn10 #-} -happyOut10 :: (HappyAbsSyn ) -> (Depth Int) -happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut10 #-} -happyIn11 :: (Dim Int) -> (HappyAbsSyn ) -happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn11 #-} -happyOut11 :: (HappyAbsSyn ) -> (Dim Int) -happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut11 #-} -happyIn12 :: (Bool) -> (HappyAbsSyn ) -happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn12 #-} -happyOut12 :: (HappyAbsSyn ) -> (Bool) -happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut12 #-} -happyIn13 :: (Spec) -> (HappyAbsSyn ) -happyIn13 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn13 #-} -happyOut13 :: (HappyAbsSyn ) -> (Spec) -happyOut13 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut13 #-} -happyIn14 :: (Mod) -> (HappyAbsSyn ) -happyIn14 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn14 #-} -happyOut14 :: (HappyAbsSyn ) -> (Mod) -happyOut14 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut14 #-} -happyIn15 :: ([Mod]) -> (HappyAbsSyn ) -happyIn15 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn15 #-} -happyOut15 :: (HappyAbsSyn ) -> ([Mod]) -happyOut15 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut15 #-} -happyIn16 :: (Mod) -> (HappyAbsSyn ) -happyIn16 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn16 #-} -happyOut16 :: (HappyAbsSyn ) -> (Mod) -happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut16 #-} -happyIn17 :: ([String]) -> (HappyAbsSyn ) -happyIn17 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn17 #-} -happyOut17 :: (HappyAbsSyn ) -> ([String]) -happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut17 #-} -happyInTok :: (Token) -> (HappyAbsSyn ) -happyInTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyInTok #-} -happyOutTok :: (HappyAbsSyn ) -> (Token) -happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOutTok #-} - - -happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x51\x00\x71\x00\x00\x00\x74\x00\x50\x00\xfe\xff\x41\x00\x73\x00\x0c\x00\x79\x00\x08\x00\x00\x00\x70\x00\x00\x00\x00\x00\x6f\x00\x6d\x00\x6c\x00\x00\x00\x0c\x00\x6e\x00\x6b\x00\x25\x00\x35\x00\x35\x00\x35\x00\x69\x00\x41\x00\x00\x00\x47\x00\x0c\x00\x3c\x00\x68\x00\x0c\x00\x0c\x00\x00\x00\x6a\x00\x00\x00\x67\x00\x3c\x00\x66\x00\x65\x00\x3d\x00\x36\x00\x40\x00\x00\x00\x64\x00\x4d\x00\x63\x00\x4c\x00\x00\x00\x0c\x00\x37\x00\x00\x00\x00\x00\x62\x00\x60\x00\x61\x00\x5f\x00\x00\x00\x5e\x00\x5d\x00\x00\x00\x5c\x00\x5a\x00\x00\x00\x56\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\x2e\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x59\x00\x53\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x30\x00\x2a\x00\x24\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x57\x00\x00\x00\x4b\x00\x55\x00\x54\x00\x00\x00\x00\x00\x00\x00\x48\x00\x00\x00\x00\x00\x00\x00\xff\xff\x3b\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x49\x00\x00\x00\x42\x00\x3e\x00\x00\x00\x34\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyDefActions :: HappyAddr -happyDefActions = HappyA# "\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\x00\x00\xe3\xff\x00\x00\x00\x00\x00\x00\xe0\xff\xe2\xff\x00\x00\xdf\xff\xde\xff\x00\x00\x00\x00\x00\x00\xf4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\xff\xe1\xff\xe0\xff\x00\x00\xe5\xff\x00\x00\x00\x00\x00\x00\xf6\xff\xf7\xff\xfd\xff\xdc\xff\xe6\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf5\xff\x00\x00\xfc\xff\xf9\xff\xfa\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xff\xea\xff\x00\x00\xf3\xff\xed\xff\x00\x00\xfb\xff\x00\x00\xdd\xff\x00\x00\xef\xff\xee\xff\xeb\xff\xec\xff\xf0\xff\xf1\xff\xe8\xff\xe9\xff\xf8\xff"# - -happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x03\x00\x04\x00\x04\x00\x06\x00\x07\x00\x07\x00\x08\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x04\x00\x07\x00\x06\x00\x07\x00\x04\x00\x13\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x02\x00\x13\x00\x02\x00\x06\x00\x07\x00\x13\x00\x07\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0b\x00\x0c\x00\x03\x00\x0b\x00\x0c\x00\x06\x00\x07\x00\x08\x00\x03\x00\x00\x00\x01\x00\x06\x00\x07\x00\x08\x00\x03\x00\x0f\x00\x10\x00\x06\x00\x07\x00\x08\x00\x14\x00\x05\x00\x05\x00\x08\x00\x08\x00\x09\x00\x09\x00\x05\x00\x06\x00\x05\x00\x08\x00\x06\x00\x08\x00\x0f\x00\x10\x00\x08\x00\x09\x00\x08\x00\x0f\x00\x10\x00\x06\x00\x07\x00\x06\x00\x0f\x00\x10\x00\x01\x00\x02\x00\x02\x00\x0d\x00\x02\x00\x02\x00\x0d\x00\x02\x00\x02\x00\x02\x00\x01\x00\x0a\x00\x14\x00\x12\x00\x14\x00\x05\x00\x08\x00\x05\x00\x0e\x00\x15\x00\x09\x00\xff\xff\x09\x00\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x00\xff\xff\x0e\x00\x08\x00\xff\xff\x02\x00\x0d\x00\x0d\x00\x12\x00\x14\x00\x12\x00\x14\x00\x10\x00\x0d\x00\x03\x00\x12\x00\xff\xff\x13\x00\x13\x00\xff\xff\x13\x00\x13\x00\x11\x00\x11\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x0c\x00\x0d\x00\x3e\x00\x0e\x00\x0f\x00\x3f\x00\x40\x00\x10\x00\x11\x00\x12\x00\x13\x00\x0d\x00\x45\x00\x0e\x00\x0f\x00\x0d\x00\x14\x00\x10\x00\x11\x00\x12\x00\x13\x00\x10\x00\x11\x00\x12\x00\x13\x00\x06\x00\x14\x00\x1b\x00\x39\x00\x3a\x00\x14\x00\x4a\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x1c\x00\x1d\x00\x29\x00\x1c\x00\x1d\x00\x2a\x00\x2b\x00\x2c\x00\x30\x00\x04\x00\x02\x00\x2a\x00\x2b\x00\x2c\x00\x31\x00\x22\x00\x23\x00\x2a\x00\x2b\x00\x2c\x00\x33\x00\x2e\x00\x2e\x00\x46\x00\x2f\x00\x30\x00\x30\x00\x3b\x00\x3c\x00\x2e\x00\x3d\x00\x47\x00\x2f\x00\x22\x00\x23\x00\x2f\x00\x30\x00\x48\x00\x22\x00\x23\x00\x0e\x00\x0f\x00\x49\x00\x22\x00\x23\x00\x06\x00\x04\x00\x34\x00\x43\x00\x23\x00\x24\x00\x25\x00\x27\x00\x16\x00\x1f\x00\x02\x00\x1e\x00\x4e\x00\x38\x00\x36\x00\x2e\x00\x2f\x00\x2e\x00\x45\x00\xff\xff\x30\x00\x00\x00\x30\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x4d\x00\x29\x00\x00\x00\x04\x00\x27\x00\x27\x00\x39\x00\x37\x00\x43\x00\x42\x00\x23\x00\x16\x00\x0c\x00\x34\x00\x00\x00\x18\x00\x19\x00\x00\x00\x1a\x00\x1b\x00\x21\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyReduceArr = Happy_Data_Array.array (1, 35) [ - (1 , happyReduce_1), - (2 , happyReduce_2), - (3 , happyReduce_3), - (4 , happyReduce_4), - (5 , happyReduce_5), - (6 , happyReduce_6), - (7 , happyReduce_7), - (8 , happyReduce_8), - (9 , happyReduce_9), - (10 , happyReduce_10), - (11 , happyReduce_11), - (12 , happyReduce_12), - (13 , happyReduce_13), - (14 , happyReduce_14), - (15 , happyReduce_15), - (16 , happyReduce_16), - (17 , happyReduce_17), - (18 , happyReduce_18), - (19 , happyReduce_19), - (20 , happyReduce_20), - (21 , happyReduce_21), - (22 , happyReduce_22), - (23 , happyReduce_23), - (24 , happyReduce_24), - (25 , happyReduce_25), - (26 , happyReduce_26), - (27 , happyReduce_27), - (28 , happyReduce_28), - (29 , happyReduce_29), - (30 , happyReduce_30), - (31 , happyReduce_31), - (32 , happyReduce_32), - (33 , happyReduce_33), - (34 , happyReduce_34), - (35 , happyReduce_35) - ] - -happy_n_terms = 22 :: Int -happy_n_nonterms = 14 :: Int - -happyReduce_1 = happySpecReduce_1 0# happyReduction_1 -happyReduction_1 happy_x_1 - = case happyOut5 happy_x_1 of { happy_var_1 -> - happyIn4 - (RegionDec (fst happy_var_1) (snd happy_var_1) - )} - -happyReduce_2 = happyReduce 4# 0# happyReduction_2 -happyReduction_2 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut13 happy_x_2 of { happy_var_2 -> - case happyOut17 happy_x_4 of { happy_var_4 -> - happyIn4 - (SpecDec happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_3 = happyReduce 5# 1# happyReduction_3 -happyReduction_3 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_3 of { (TId happy_var_3) -> - case happyOut6 happy_x_5 of { happy_var_5 -> - happyIn5 - ((happy_var_3, happy_var_5) - ) `HappyStk` happyRest}} - -happyReduce_4 = happyReduce 4# 2# happyReduction_4 -happyReduction_4 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut7 happy_x_3 of { happy_var_3 -> - happyIn6 - (applyAttr Forward happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_5 = happyReduce 4# 2# happyReduction_5 -happyReduction_5 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut7 happy_x_3 of { happy_var_3 -> - happyIn6 - (applyAttr Backward happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_6 = happyReduce 4# 2# happyReduction_6 -happyReduction_6 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut7 happy_x_3 of { happy_var_3 -> - happyIn6 - (applyAttr Centered happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_7 = happyReduce 6# 2# happyReduction_7 -happyReduction_7 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_5 of { (TNum happy_var_5) -> - happyIn6 - (Centered 0 (read happy_var_5) True - ) `HappyStk` happyRest} - -happyReduce_8 = happySpecReduce_3 2# happyReduction_8 -happyReduction_8 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut6 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn6 - (Or happy_var_1 happy_var_3 - )}} - -happyReduce_9 = happySpecReduce_3 2# happyReduction_9 -happyReduction_9 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut6 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn6 - (And happy_var_1 happy_var_3 - )}} - -happyReduce_10 = happySpecReduce_3 2# happyReduction_10 -happyReduction_10 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn6 - (happy_var_2 - )} - -happyReduce_11 = happySpecReduce_1 2# happyReduction_11 -happyReduction_11 happy_x_1 - = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - happyIn6 - (Var happy_var_1 - )} - -happyReduce_12 = happySpecReduce_2 3# happyReduction_12 -happyReduction_12 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut8 happy_x_2 of { happy_var_2 -> - happyIn7 - ((happy_var_1, fst happy_var_2, snd happy_var_2) - )}} - -happyReduce_13 = happySpecReduce_2 3# happyReduction_13 -happyReduction_13 happy_x_2 - happy_x_1 - = case happyOut11 happy_x_1 of { happy_var_1 -> - case happyOut9 happy_x_2 of { happy_var_2 -> - happyIn7 - ((fst happy_var_2, happy_var_1, snd happy_var_2) - )}} - -happyReduce_14 = happySpecReduce_3 3# happyReduction_14 -happyReduction_14 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut12 happy_x_1 of { happy_var_1 -> - case happyOut10 happy_x_2 of { happy_var_2 -> - case happyOut11 happy_x_3 of { happy_var_3 -> - happyIn7 - ((happy_var_2, happy_var_3, happy_var_1) - )}}} - -happyReduce_15 = happySpecReduce_3 3# happyReduction_15 -happyReduction_15 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut12 happy_x_1 of { happy_var_1 -> - case happyOut11 happy_x_2 of { happy_var_2 -> - case happyOut10 happy_x_3 of { happy_var_3 -> - happyIn7 - ((happy_var_3, happy_var_2, happy_var_1) - )}}} - -happyReduce_16 = happySpecReduce_2 4# happyReduction_16 -happyReduction_16 happy_x_2 - happy_x_1 - = case happyOut12 happy_x_1 of { happy_var_1 -> - case happyOut11 happy_x_2 of { happy_var_2 -> - happyIn8 - ((happy_var_2, happy_var_1) - )}} - -happyReduce_17 = happySpecReduce_2 4# happyReduction_17 -happyReduction_17 happy_x_2 - happy_x_1 - = case happyOut11 happy_x_1 of { happy_var_1 -> - case happyOut12 happy_x_2 of { happy_var_2 -> - happyIn8 - ((happy_var_1, happy_var_2) - )}} - -happyReduce_18 = happySpecReduce_1 4# happyReduction_18 -happyReduction_18 happy_x_1 - = case happyOut11 happy_x_1 of { happy_var_1 -> - happyIn8 - ((happy_var_1, True) - )} - -happyReduce_19 = happySpecReduce_2 5# happyReduction_19 -happyReduction_19 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut12 happy_x_2 of { happy_var_2 -> - happyIn9 - ((happy_var_1, happy_var_2) - )}} - -happyReduce_20 = happySpecReduce_2 5# happyReduction_20 -happyReduction_20 happy_x_2 - happy_x_1 - = case happyOut12 happy_x_1 of { happy_var_1 -> - case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn9 - ((happy_var_2, happy_var_1) - )}} - -happyReduce_21 = happySpecReduce_1 5# happyReduction_21 -happyReduction_21 happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - happyIn9 - ((happy_var_1, True) - )} - -happyReduce_22 = happySpecReduce_3 6# happyReduction_22 -happyReduction_22 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_3 of { (TNum happy_var_3) -> - happyIn10 - (Depth $ read happy_var_3 - )} - -happyReduce_23 = happySpecReduce_3 7# happyReduction_23 -happyReduction_23 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_3 of { (TNum happy_var_3) -> - happyIn11 - (Dim $ read happy_var_3 - )} - -happyReduce_24 = happySpecReduce_1 8# happyReduction_24 -happyReduction_24 happy_x_1 - = happyIn12 - (False - ) - -happyReduce_25 = happySpecReduce_3 9# happyReduction_25 -happyReduction_25 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut15 happy_x_1 of { happy_var_1 -> - case happyOut14 happy_x_2 of { happy_var_2 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn13 - (Spatial (happy_var_1 ++ [happy_var_2]) happy_var_3 - )}}} - -happyReduce_26 = happySpecReduce_2 9# happyReduction_26 -happyReduction_26 happy_x_2 - happy_x_1 - = case happyOut14 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn13 - (Spatial [happy_var_1] happy_var_2 - )}} - -happyReduce_27 = happySpecReduce_2 9# happyReduction_27 -happyReduction_27 happy_x_2 - happy_x_1 - = case happyOut16 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn13 - (Spatial [happy_var_1] happy_var_2 - )}} - -happyReduce_28 = happySpecReduce_1 9# happyReduction_28 -happyReduction_28 happy_x_1 - = case happyOut6 happy_x_1 of { happy_var_1 -> - happyIn13 - (Spatial [] happy_var_1 - )} - -happyReduce_29 = happySpecReduce_1 10# happyReduction_29 -happyReduction_29 happy_x_1 - = happyIn14 - (ReadOnce - ) - -happyReduce_30 = happySpecReduce_2 11# happyReduction_30 -happyReduction_30 happy_x_2 - happy_x_1 - = case happyOut16 happy_x_1 of { happy_var_1 -> - case happyOut15 happy_x_2 of { happy_var_2 -> - happyIn15 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_31 = happySpecReduce_1 11# happyReduction_31 -happyReduction_31 happy_x_1 - = case happyOut16 happy_x_1 of { happy_var_1 -> - happyIn15 - ([happy_var_1] - )} - -happyReduce_32 = happySpecReduce_1 12# happyReduction_32 -happyReduction_32 happy_x_1 - = happyIn16 - (AtMost - ) - -happyReduce_33 = happySpecReduce_1 12# happyReduction_33 -happyReduction_33 happy_x_1 - = happyIn16 - (AtLeast - ) - -happyReduce_34 = happySpecReduce_2 13# happyReduction_34 -happyReduction_34 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - case happyOut17 happy_x_2 of { happy_var_2 -> - happyIn17 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_35 = happySpecReduce_1 13# happyReduction_35 -happyReduction_35 happy_x_1 - = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - happyIn17 - ([happy_var_1] - )} - -happyNewToken action sts stk [] = - happyDoAction 21# notHappyAtAll action sts stk [] - -happyNewToken action sts stk (tk:tks) = - let cont i = happyDoAction i tk action sts stk tks in - case tk of { - TId "stencil" -> cont 1#; - TId "region" -> cont 2#; - TId "readonce" -> cont 3#; - TId "reflexive" -> cont 4#; - TId "irreflexive" -> cont 5#; - TId "atmost" -> cont 6#; - TId "atleast" -> cont 7#; - TId "dim" -> cont 8#; - TId "depth" -> cont 9#; - TId "forward" -> cont 10#; - TId "backward" -> cont 11#; - TId "centered" -> cont 12#; - TId happy_dollar_dollar -> cont 13#; - TNum happy_dollar_dollar -> cont 14#; - TPlus -> cont 15#; - TStar -> cont 16#; - TDoubleColon -> cont 17#; - TEqual -> cont 18#; - TLParen -> cont 19#; - TRParen -> cont 20#; - _ -> happyError' (tk:tks) - } - -happyError_ 21# tk tks = happyError' tks -happyError_ _ tk tks = happyError' (tk:tks) - -happyThen :: () => Either AnnotationParseError a -> (a -> Either AnnotationParseError b) -> Either AnnotationParseError b -happyThen = (>>=) -happyReturn :: () => a -> Either AnnotationParseError a -happyReturn = (return) -happyThen1 m k tks = (>>=) m (\a -> k a tks) -happyReturn1 :: () => a -> b -> Either AnnotationParseError a -happyReturn1 = \a tks -> (return) a -happyError' :: () => [(Token)] -> Either AnnotationParseError a -happyError' = happyError - -parseSpec tks = happySomeParser where - happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x)) - -happySeq = happyDontSeq - - -newtype Depth a = Depth a -newtype Dim a = Dim a - -applyAttr :: (Int -> Int -> Bool -> Region) - -> (Depth Int, Dim Int, Bool) - -> Region -applyAttr constr (Depth d, Dim dim, irrefl) = constr d dim irrefl - -data Specification - = RegionDec String Region - | SpecDec Spec [String] - deriving (Show, Eq, Ord, Typeable, Data) - -data Region - = Forward Int Int Bool - | Backward Int Int Bool - | Centered Int Int Bool - | Or Region Region - | And Region Region - | Var String - deriving (Show, Eq, Ord, Typeable, Data) - -data Spec = Spatial [Mod] Region - deriving (Show, Eq, Ord, Typeable, Data) - -data Mod - = AtLeast - | AtMost - | ReadOnce - deriving (Show, Eq, Ord, Typeable, Data) - --------------------------------------------------- - -data Token - = TDoubleColon - | TStar - | TPlus - | TEqual - | TComma - | TLParen - | TRParen - | TId String - | TNum String - deriving (Show) - -addToTokens :: Token -> String -> Either AnnotationParseError [ Token ] -addToTokens tok rest = do - tokens <- lexer' rest - return $ tok : tokens - -lexer :: String -> Either AnnotationParseError [ Token ] -lexer input | length (stripLeadingWhiteSpace input) >= 2 = - case stripLeadingWhiteSpace input of - -- Check the leading character is '=' for specification - '=':input' -> testAnnotation input' - '!':input' -> testAnnotation input' - '>':input' -> testAnnotation input' - '<':input' -> testAnnotation input' - _ -> Left NotAnnotation - where - stripLeadingWhiteSpace = T.unpack . T.strip . T.pack - testAnnotation inp = - -- First test to see if the input looks like an actual - -- specification of either a stencil or region - if (inp `hasPrefix` "stencil" || inp `hasPrefix` "region") - then lexer' inp - else Left NotAnnotation - hasPrefix [] str = False - hasPrefix (' ':xs) str = hasPrefix xs str - hasPrefix xs str = isPrefixOf str xs -lexer _ = Left NotAnnotation - - -lexer' :: String -> Either AnnotationParseError [ Token ] -lexer' [] = return [] -lexer' (' ':xs) = lexer' xs -lexer' ('\t':xs) = lexer' xs -lexer' (':':':':xs) = addToTokens TDoubleColon xs -lexer' ('*':xs) = addToTokens TStar xs -lexer' ('+':xs) = addToTokens TPlus xs -lexer' ('=':xs) = addToTokens TEqual xs --- Comma hack: drop commas that are not separating numbers, in order to avoid need for 2-token lookahead. -lexer' (',':xs) - | x':xs' <- dropWhile isSpace xs, not (isNumber x') = lexer' (x':xs') - | otherwise = addToTokens TComma xs -lexer' ('(':xs) = addToTokens TLParen xs -lexer' (')':xs) = addToTokens TRParen xs -lexer' (x:xs) - | isLetter x = aux TId $ \ c -> isAlphaNum c || c == '_' - | isNumber x = aux TNum isNumber - | otherwise - = failWith $ "Not an indentifier " ++ show x - where - aux f p = (f target :) `fmap` lexer' rest - where (target, rest) = span p (x:xs) -lexer' x - = failWith $ "Not a valid piece of stencil syntax " ++ show x - --------------------------------------------------- - --- specParser :: String -> Either AnnotationParseError Specification -specParser :: AnnotationParser Specification -specParser src = do - tokens <- lexer src - parseSpec tokens >>= modValidate - --- Check whether modifiers are used correctly -modValidate :: Specification -> Either AnnotationParseError Specification -modValidate (SpecDec (Spatial mods r) vars) = - do mods' <- modValidate' $ sort mods - return $ SpecDec (Spatial mods' r) vars - - where modValidate' [] = return $ [] - - modValidate' (AtLeast : AtLeast : xs) - = failWith "Duplicate 'atLeast' modifier; use at most one." - - modValidate' (AtMost : AtMost : xs) - = failWith "Duplicate 'atMost' modifier; use at most one." - - modValidate' (ReadOnce : ReadOnce : xs) - = failWith "Duplicate 'readOnce' modifier; use at most one." - - modValidate' (AtLeast : AtMost : xs) - = failWith $ "Conflicting modifiers: cannot use 'atLeast' and " - ++ "'atMost' together" - - modValidate' (x : xs) - = do xs' <- modValidate' xs - return $ x : xs' -modValidate x = return x - -happyError :: [ Token ] -> Either AnnotationParseError a -happyError t = failWith $ "Could not parse specification at: " ++ show t -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 19 "" #-} -{-# LINE 1 "/usr/local/lib/ghc-7.10.2/include/ghcversion.h" #-} - - - - - - - - - - - - - - - - - - -{-# LINE 20 "" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} --- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp - - -{-# LINE 13 "templates/GenericTemplate.hs" #-} - - - - - --- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. -#if __GLASGOW_HASKELL__ > 706 -#define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool) -#define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool) -#define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Bool) -#else -#define LT(n,m) (n Happy_GHC_Exts.<# m) -#define GTE(n,m) (n Happy_GHC_Exts.>=# m) -#define EQ(n,m) (n Happy_GHC_Exts.==# m) -#endif - -{-# LINE 46 "templates/GenericTemplate.hs" #-} - - -data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList - - - - - - -{-# LINE 67 "templates/GenericTemplate.hs" #-} - - -{-# LINE 77 "templates/GenericTemplate.hs" #-} - - - - - - - - - - -infixr 9 `HappyStk` -data HappyStk a = HappyStk a (HappyStk a) - ------------------------------------------------------------------------------ --- starting the parse - -happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll - ------------------------------------------------------------------------------ --- Accepting the parse - --- If the current token is 0#, it means we've just accepted a partial --- parse (a %partial parser). We must ignore the saved token on the top of --- the stack in this case. -happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = - happyReturn1 ans -happyAccept j tk st sts (HappyStk ans _) = - (happyTcHack j (happyTcHack st)) (happyReturn1 ans) - ------------------------------------------------------------------------------ --- Arrays only: do the next action - - - -happyDoAction i tk st - = {- nothing -} - - - case action of - 0# -> {- nothing -} - happyFail i tk st - -1# -> {- nothing -} - happyAccept i tk st - n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} - - (happyReduceArr Happy_Data_Array.! rule) i tk st - where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) - n -> {- nothing -} - - - happyShift new_state i tk st - where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) - where off = indexShortOffAddr happyActOffsets st - off_i = (off Happy_GHC_Exts.+# i) - check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#)) - then EQ(indexShortOffAddr happyCheck off_i, i) - else False - action - | check = indexShortOffAddr happyTable off_i - | otherwise = indexShortOffAddr happyDefActions st - - -indexShortOffAddr (HappyA# arr) off = - Happy_GHC_Exts.narrow16Int# i - where - i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) - high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) - low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) - off' = off Happy_GHC_Exts.*# 2# - - - - - -data HappyAddr = HappyA# Happy_GHC_Exts.Addr# - - - - ------------------------------------------------------------------------------ --- HappyState data type (not arrays) - - -{-# LINE 170 "templates/GenericTemplate.hs" #-} - ------------------------------------------------------------------------------ --- Shifting a token - -happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = - let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in --- trace "shifting the error token" $ - happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) - -happyShift new_state i tk st sts stk = - happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) - --- happyReduce is specialised for the common cases. - -happySpecReduce_0 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_0 nt fn j tk st@((action)) sts stk - = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) - -happySpecReduce_1 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') - = let r = fn v1 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_2 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') - = let r = fn v1 v2 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_3 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') - = let r = fn v1 v2 v3 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happyReduce k i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyReduce k nt fn j tk st sts stk - = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of - sts1@((HappyCons (st1@(action)) (_))) -> - let r = fn stk in -- it doesn't hurt to always seq here... - happyDoSeq r (happyGoto nt j tk st1 sts1 r) - -happyMonadReduce k nt fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyMonadReduce k nt fn j tk st sts stk = - case happyDrop k (HappyCons (st) (sts)) of - sts1@((HappyCons (st1@(action)) (_))) -> - let drop_stk = happyDropStk k stk in - happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) - -happyMonad2Reduce k nt fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyMonad2Reduce k nt fn j tk st sts stk = - case happyDrop k (HappyCons (st) (sts)) of - sts1@((HappyCons (st1@(action)) (_))) -> - let drop_stk = happyDropStk k stk - - off = indexShortOffAddr happyGotoOffsets st1 - off_i = (off Happy_GHC_Exts.+# nt) - new_state = indexShortOffAddr happyTable off_i - - - - in - happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) - -happyDrop 0# l = l -happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t - -happyDropStk 0# l = l -happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs - ------------------------------------------------------------------------------ --- Moving to a new state after a reduction - - -happyGoto nt j tk st = - {- nothing -} - happyDoAction j tk new_state - where off = indexShortOffAddr happyGotoOffsets st - off_i = (off Happy_GHC_Exts.+# nt) - new_state = indexShortOffAddr happyTable off_i - - - - ------------------------------------------------------------------------------ --- Error recovery (0# is the error token) - --- parse error if we are in recovery and we fail again -happyFail 0# tk old_st _ stk@(x `HappyStk` _) = - let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in --- trace "failing" $ - happyError_ i tk - -{- We don't need state discarding for our restricted implementation of - "error". In fact, it can cause some bogus parses, so I've disabled it - for now --SDM - --- discard a state -happyFail 0# tk old_st (HappyCons ((action)) (sts)) - (saved_tok `HappyStk` _ `HappyStk` stk) = --- trace ("discarding state, depth " ++ show (length stk)) $ - happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) --} - --- Enter error recovery: generate an error token, --- save the old token and carry on. -happyFail i tk (action) sts stk = --- trace "entering error recovery" $ - happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) - --- Internal happy errors: - -notHappyAtAll :: a -notHappyAtAll = error "Internal Happy error\n" - ------------------------------------------------------------------------------ --- Hack to get the typechecker to accept our action functions - - -happyTcHack :: Happy_GHC_Exts.Int# -> a -> a -happyTcHack x y = y -{-# INLINE happyTcHack #-} - - ------------------------------------------------------------------------------ --- Seq-ing. If the --strict flag is given, then Happy emits --- happySeq = happyDoSeq --- otherwise it emits --- happySeq = happyDontSeq - -happyDoSeq, happyDontSeq :: a -> b -> b -happyDoSeq a b = a `seq` b -happyDontSeq a b = b - ------------------------------------------------------------------------------ --- Don't inline any functions from the template. GHC has a nasty habit --- of deciding to inline happyGoto everywhere, which increases the size of --- the generated parser quite a bit. - - -{-# NOINLINE happyDoAction #-} -{-# NOINLINE happyTable #-} -{-# NOINLINE happyCheck #-} -{-# NOINLINE happyActOffsets #-} -{-# NOINLINE happyGotoOffsets #-} -{-# NOINLINE happyDefActions #-} - -{-# NOINLINE happyShift #-} -{-# NOINLINE happySpecReduce_0 #-} -{-# NOINLINE happySpecReduce_1 #-} -{-# NOINLINE happySpecReduce_2 #-} -{-# NOINLINE happySpecReduce_3 #-} -{-# NOINLINE happyReduce #-} -{-# NOINLINE happyMonadReduce #-} -{-# NOINLINE happyGoto #-} -{-# NOINLINE happyFail #-} - --- end of Happy Template. - diff --git a/dist/build/Camfort/Specification/Units/Parser.hs b/dist/build/Camfort/Specification/Units/Parser.hs deleted file mode 100644 --- a/dist/build/Camfort/Specification/Units/Parser.hs +++ /dev/null @@ -1,766 +0,0 @@ -{-# OPTIONS_GHC -w #-} -{-# OPTIONS -fglasgow-exts -cpp #-} --- -*- Mode: Haskell -*- - -{-# LANGUAGE DeriveDataTypeable #-} -module Camfort.Specification.Units.Parser ( unitParser - , UnitStatement(..) - , UnitOfMeasure(..) - , UnitPower(..) - ) where - -import Camfort.Analysis.CommentAnnotator -import Data.Data -import Data.List -import Data.Char (isLetter, isNumber, isAlphaNum, toLower) -import qualified Data.Text as T -import qualified Data.Array as Happy_Data_Array -import qualified GHC.Exts as Happy_GHC_Exts -import Control.Applicative(Applicative(..)) -import Control.Monad (ap) - --- parser produced by Happy Version 1.19.5 - -newtype HappyAbsSyn = HappyAbsSyn HappyAny -#if __GLASGOW_HASKELL__ >= 607 -type HappyAny = Happy_GHC_Exts.Any -#else -type HappyAny = forall a . a -#endif -happyIn4 :: (UnitStatement) -> (HappyAbsSyn ) -happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn4 #-} -happyOut4 :: (HappyAbsSyn ) -> (UnitStatement) -happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut4 #-} -happyIn5 :: (Maybe [String]) -> (HappyAbsSyn ) -happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn5 #-} -happyOut5 :: (HappyAbsSyn ) -> (Maybe [String]) -happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut5 #-} -happyIn6 :: ([String]) -> (HappyAbsSyn ) -happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn6 #-} -happyOut6 :: (HappyAbsSyn ) -> ([String]) -happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut6 #-} -happyIn7 :: (UnitOfMeasure) -> (HappyAbsSyn ) -happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn7 #-} -happyOut7 :: (HappyAbsSyn ) -> (UnitOfMeasure) -happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut7 #-} -happyIn8 :: (UnitOfMeasure) -> (HappyAbsSyn ) -happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn8 #-} -happyOut8 :: (HappyAbsSyn ) -> (UnitOfMeasure) -happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut8 #-} -happyIn9 :: (UnitOfMeasure) -> (HappyAbsSyn ) -happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn9 #-} -happyOut9 :: (HappyAbsSyn ) -> (UnitOfMeasure) -happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut9 #-} -happyIn10 :: (UnitPower) -> (HappyAbsSyn ) -happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn10 #-} -happyOut10 :: (HappyAbsSyn ) -> (UnitPower) -happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut10 #-} -happyIn11 :: (Integer) -> (HappyAbsSyn ) -happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn11 #-} -happyOut11 :: (HappyAbsSyn ) -> (Integer) -happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut11 #-} -happyIn12 :: (String) -> (HappyAbsSyn ) -happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn12 #-} -happyOut12 :: (HappyAbsSyn ) -> (String) -happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut12 #-} -happyInTok :: (Token) -> (HappyAbsSyn ) -happyInTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyInTok #-} -happyOutTok :: (HappyAbsSyn ) -> (Token) -happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOutTok #-} - - -happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x44\x00\x41\x00\x0f\x00\x3c\x00\x05\x00\x2b\x00\x04\x00\x3d\x00\x00\x00\x00\x00\x3f\x00\xff\xff\x3b\x00\x01\x00\x34\x00\x00\x00\x35\x00\x10\x00\x36\x00\x0f\x00\x00\x00\x04\x00\x3a\x00\x00\x00\x39\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x19\x00\x0f\x00\x00\x00\x00\x00\x33\x00\xfd\xff\x00\x00\x38\x00\x00\x00\x19\x00\x00\x00\x2c\x00\x00\x00\x00\x00"# - -happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\x37\x00\x00\x00\x27\x00\x00\x00\x27\x00\x22\x00\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x31\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x1d\x00\x00\x00\x30\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x28\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x26\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyDefActions :: HappyAddr -happyDefActions = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfb\xff\xf8\xff\xf2\xff\xef\xff\xf7\xff\x00\x00\x00\x00\x00\x00\xf8\xff\xf7\xff\xf5\xff\x00\x00\x00\x00\xf4\xff\x00\x00\xfe\xff\x00\x00\x00\x00\xfc\xff\xf9\xff\xf3\xff\xf1\xff\xee\xff\xeb\xff\xe8\xff\xe9\xff\x00\x00\x00\x00\x00\x00\xf6\xff\xf0\xff\xfd\xff\x00\x00\xea\xff\x00\x00\xfa\xff\x00\x00\xed\xff\x00\x00\xec\xff"# - -happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x02\x00\x03\x00\x02\x00\x02\x00\x08\x00\x02\x00\x02\x00\x03\x00\x0c\x00\x0b\x00\x0c\x00\x0b\x00\x0c\x00\x09\x00\x0b\x00\x0b\x00\x02\x00\x03\x00\x03\x00\x04\x00\x08\x00\x06\x00\x03\x00\x04\x00\x05\x00\x0b\x00\x0b\x00\x03\x00\x04\x00\x02\x00\x06\x00\x03\x00\x04\x00\x05\x00\x01\x00\x06\x00\x07\x00\x08\x00\x03\x00\x04\x00\x05\x00\x03\x00\x04\x00\x05\x00\x07\x00\x08\x00\x07\x00\x08\x00\x03\x00\x04\x00\x08\x00\x09\x00\x05\x00\x05\x00\x00\x00\x0c\x00\x07\x00\x02\x00\x08\x00\x02\x00\x07\x00\x05\x00\x0a\x00\x0c\x00\x02\x00\x01\x00\x08\x00\x07\x00\x01\x00\xff\xff\xff\xff\xff\xff\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x09\x00\x0f\x00\x09\x00\x28\x00\x2a\x00\x09\x00\x09\x00\x0a\x00\x2b\x00\x0c\x00\x10\x00\x14\x00\x24\x00\x0b\x00\x14\x00\x0c\x00\x09\x00\x0a\x00\x1e\x00\x1f\x00\x26\x00\x20\x00\x24\x00\x06\x00\x07\x00\x0c\x00\x21\x00\x1e\x00\x1f\x00\x17\x00\x20\x00\x0c\x00\x0d\x00\x07\x00\x14\x00\x1a\x00\x1b\x00\x1c\x00\x0c\x00\x0d\x00\x07\x00\x05\x00\x06\x00\x07\x00\x2b\x00\x1c\x00\x25\x00\x1c\x00\x1e\x00\x1f\x00\x16\x00\x17\x00\x19\x00\x12\x00\x03\x00\x2d\x00\x12\x00\x19\x00\x16\x00\x19\x00\x12\x00\x28\x00\x22\x00\x23\x00\x11\x00\x03\x00\x16\x00\x12\x00\x05\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyReduceArr = Happy_Data_Array.array (1, 23) [ - (1 , happyReduce_1), - (2 , happyReduce_2), - (3 , happyReduce_3), - (4 , happyReduce_4), - (5 , happyReduce_5), - (6 , happyReduce_6), - (7 , happyReduce_7), - (8 , happyReduce_8), - (9 , happyReduce_9), - (10 , happyReduce_10), - (11 , happyReduce_11), - (12 , happyReduce_12), - (13 , happyReduce_13), - (14 , happyReduce_14), - (15 , happyReduce_15), - (16 , happyReduce_16), - (17 , happyReduce_17), - (18 , happyReduce_18), - (19 , happyReduce_19), - (20 , happyReduce_20), - (21 , happyReduce_21), - (22 , happyReduce_22), - (23 , happyReduce_23) - ] - -happy_n_terms = 14 :: Int -happy_n_nonterms = 9 :: Int - -happyReduce_1 = happySpecReduce_3 0# happyReduction_1 -happyReduction_1 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut7 happy_x_2 of { happy_var_2 -> - case happyOut5 happy_x_3 of { happy_var_3 -> - happyIn4 - (UnitAssignment happy_var_3 happy_var_2 - )}} - -happyReduce_2 = happyReduce 5# 0# happyReduction_2 -happyReduction_2 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_3 of { (TId happy_var_3) -> - case happyOut7 happy_x_5 of { happy_var_5 -> - happyIn4 - (UnitAlias happy_var_3 happy_var_5 - ) `HappyStk` happyRest}} - -happyReduce_3 = happySpecReduce_2 1# happyReduction_3 -happyReduction_3 happy_x_2 - happy_x_1 - = case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn5 - (Just happy_var_2 - )} - -happyReduce_4 = happySpecReduce_0 1# happyReduction_4 -happyReduction_4 = happyIn5 - (Nothing - ) - -happyReduce_5 = happySpecReduce_3 2# happyReduction_5 -happyReduction_5 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn6 - (happy_var_1 : happy_var_3 - )}} - -happyReduce_6 = happySpecReduce_1 2# happyReduction_6 -happyReduction_6 happy_x_1 - = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - happyIn6 - ([happy_var_1] - )} - -happyReduce_7 = happySpecReduce_1 3# happyReduction_7 -happyReduction_7 happy_x_1 - = case happyOut8 happy_x_1 of { happy_var_1 -> - happyIn7 - (happy_var_1 - )} - -happyReduce_8 = happySpecReduce_1 3# happyReduction_8 -happyReduction_8 happy_x_1 - = happyIn7 - (Unitless - ) - -happyReduce_9 = happySpecReduce_3 3# happyReduction_9 -happyReduction_9 happy_x_3 - happy_x_2 - happy_x_1 - = happyIn7 - (Unitless - ) - -happyReduce_10 = happySpecReduce_2 3# happyReduction_10 -happyReduction_10 happy_x_2 - happy_x_1 - = happyIn7 - (Unitless - ) - -happyReduce_11 = happySpecReduce_2 4# happyReduction_11 -happyReduction_11 happy_x_2 - happy_x_1 - = case happyOut8 happy_x_1 of { happy_var_1 -> - case happyOut9 happy_x_2 of { happy_var_2 -> - happyIn8 - (UnitProduct happy_var_1 happy_var_2 - )}} - -happyReduce_12 = happySpecReduce_3 4# happyReduction_12 -happyReduction_12 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut7 happy_x_1 of { happy_var_1 -> - case happyOut9 happy_x_3 of { happy_var_3 -> - happyIn8 - (UnitQuotient happy_var_1 happy_var_3 - )}} - -happyReduce_13 = happySpecReduce_1 4# happyReduction_13 -happyReduction_13 happy_x_1 - = case happyOut9 happy_x_1 of { happy_var_1 -> - happyIn8 - (happy_var_1 - )} - -happyReduce_14 = happySpecReduce_3 5# happyReduction_14 -happyReduction_14 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut9 happy_x_1 of { happy_var_1 -> - case happyOut10 happy_x_3 of { happy_var_3 -> - happyIn9 - (UnitExponentiation happy_var_1 happy_var_3 - )}} - -happyReduce_15 = happySpecReduce_3 5# happyReduction_15 -happyReduction_15 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut8 happy_x_2 of { happy_var_2 -> - happyIn9 - (happy_var_2 - )} - -happyReduce_16 = happySpecReduce_1 5# happyReduction_16 -happyReduction_16 happy_x_1 - = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - happyIn9 - (UnitBasic happy_var_1 - )} - -happyReduce_17 = happySpecReduce_1 6# happyReduction_17 -happyReduction_17 happy_x_1 - = case happyOut11 happy_x_1 of { happy_var_1 -> - happyIn10 - (UnitPowerInteger happy_var_1 - )} - -happyReduce_18 = happySpecReduce_3 6# happyReduction_18 -happyReduction_18 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut11 happy_x_2 of { happy_var_2 -> - happyIn10 - (UnitPowerInteger happy_var_2 - )} - -happyReduce_19 = happyReduce 5# 6# happyReduction_19 -happyReduction_19 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut11 happy_x_2 of { happy_var_2 -> - case happyOut11 happy_x_4 of { happy_var_4 -> - happyIn10 - (UnitPowerRational happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_20 = happySpecReduce_1 7# happyReduction_20 -happyReduction_20 happy_x_1 - = case happyOut12 happy_x_1 of { happy_var_1 -> - happyIn11 - (read happy_var_1 - )} - -happyReduce_21 = happySpecReduce_2 7# happyReduction_21 -happyReduction_21 happy_x_2 - happy_x_1 - = case happyOut12 happy_x_2 of { happy_var_2 -> - happyIn11 - (read $ '-' : happy_var_2 - )} - -happyReduce_22 = happySpecReduce_1 8# happyReduction_22 -happyReduction_22 happy_x_1 - = case happyOutTok happy_x_1 of { (TNum happy_var_1) -> - happyIn12 - (happy_var_1 - )} - -happyReduce_23 = happySpecReduce_1 8# happyReduction_23 -happyReduction_23 happy_x_1 - = happyIn12 - ("1" - ) - -happyNewToken action sts stk [] = - happyDoAction 13# notHappyAtAll action sts stk [] - -happyNewToken action sts stk (tk:tks) = - let cont i = happyDoAction i tk action sts stk tks in - case tk of { - TId "unit" -> cont 1#; - TId happy_dollar_dollar -> cont 2#; - TNum "1" -> cont 3#; - TNum happy_dollar_dollar -> cont 4#; - TComma -> cont 5#; - TMinus -> cont 6#; - TExponentiation -> cont 7#; - TDivision -> cont 8#; - TDoubleColon -> cont 9#; - TEqual -> cont 10#; - TLeftPar -> cont 11#; - TRightPar -> cont 12#; - _ -> happyError' (tk:tks) - } - -happyError_ 13# tk tks = happyError' tks -happyError_ _ tk tks = happyError' (tk:tks) - -happyThen :: () => Either AnnotationParseError a -> (a -> Either AnnotationParseError b) -> Either AnnotationParseError b -happyThen = (>>=) -happyReturn :: () => a -> Either AnnotationParseError a -happyReturn = (return) -happyThen1 m k tks = (>>=) m (\a -> k a tks) -happyReturn1 :: () => a -> b -> Either AnnotationParseError a -happyReturn1 = \a tks -> (return) a -happyError' :: () => [(Token)] -> Either AnnotationParseError a -happyError' = happyError - -parseUnit tks = happySomeParser where - happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x)) - -happySeq = happyDontSeq - - -data UnitStatement = - UnitAssignment (Maybe [String]) UnitOfMeasure - | UnitAlias String UnitOfMeasure - deriving Data - -instance Show UnitStatement where - show (UnitAssignment (Just ss) uom) = "= unit (" ++ show uom ++ ") :: " ++ (intercalate "," ss) - show (UnitAssignment Nothing uom) = "= unit (" ++ show uom ++ ")" - show (UnitAlias s uom) = "= unit :: " ++ s ++ " = " ++ show uom - -data UnitOfMeasure = - Unitless - | UnitBasic String - | UnitProduct UnitOfMeasure UnitOfMeasure - | UnitQuotient UnitOfMeasure UnitOfMeasure - | UnitExponentiation UnitOfMeasure UnitPower - deriving Data - -instance Show UnitOfMeasure where - show Unitless = "1" - show (UnitBasic s) = s - show (UnitProduct uom1 uom2) = show uom1 ++ " " ++ show uom2 - show (UnitQuotient uom1 uom2) = show uom1 ++ " / " ++ show uom2 - show (UnitExponentiation uom exp) = show uom ++ "** (" ++ show exp ++ ")" - -data UnitPower = - UnitPowerInteger Integer - | UnitPowerRational Integer Integer - deriving Data - -instance Show UnitPower where - show (UnitPowerInteger i) = show i - show (UnitPowerRational i1 i2) = show i1 ++ "/" ++ show i2 - -data Token = - TUnit - | TComma - | TDoubleColon - | TExponentiation - | TDivision - | TMinus - | TEqual - | TLeftPar - | TRightPar - | TId String - | TNum String - deriving (Show) - -lexer :: String -> Either AnnotationParseError [ Token ] -lexer [] = Left NotAnnotation -lexer (c:xs) - | c `elem` ['=', '!', '>', '<'] = - -- First test to see if the input looks like an actual unit specification - if "unit" `isPrefixOf` (T.unpack . T.strip . T.toLower . T.pack $ xs) - then lexer' xs - else Left NotAnnotation - | otherwise = Left NotAnnotation - -addToTokens :: Token -> String -> Either AnnotationParseError [ Token ] -addToTokens tok rest = do - tokens <- lexer' rest - return $ tok : tokens - -lexer' :: String -> Either AnnotationParseError [ 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 TExponentiation xs -lexer' (',':xs) = addToTokens TComma xs -lexer' ('/':xs) = addToTokens TDivision xs -lexer' ('-':xs) = addToTokens TMinus xs -lexer' ('=':xs) = addToTokens TEqual xs -lexer' ('(':xs) = addToTokens TLeftPar xs -lexer' (')':xs) = addToTokens TRightPar xs -lexer' (x:xs) - | isLetter x = aux (\c -> isAlphaNum c || c `elem` ['\'','_','-']) TId - | isNumber x = aux isNumber TNum - | otherwise = failWith $ "Not valid unit syntax at " ++ show (x:xs) ++ "\n" - where - aux p cons = - let (target, rest) = span p xs - in lexer' rest >>= (\tokens -> return $ cons (x:target) : tokens) - -unitParser :: String -> Either AnnotationParseError UnitStatement -unitParser src = do - tokens <- lexer $ map toLower src - parseUnit tokens - -happyError :: [ Token ] -> Either AnnotationParseError a -happyError t = failWith $ "Could not parse unit specification at: " ++ show t ++ "\n" -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 19 "" #-} -{-# LINE 1 "/usr/local/lib/ghc-7.10.2/include/ghcversion.h" #-} - - - - - - - - - - - - - - - - - - -{-# LINE 20 "" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} --- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp - - -{-# LINE 13 "templates/GenericTemplate.hs" #-} - - - - - --- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. -#if __GLASGOW_HASKELL__ > 706 -#define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool) -#define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool) -#define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Bool) -#else -#define LT(n,m) (n Happy_GHC_Exts.<# m) -#define GTE(n,m) (n Happy_GHC_Exts.>=# m) -#define EQ(n,m) (n Happy_GHC_Exts.==# m) -#endif - -{-# LINE 46 "templates/GenericTemplate.hs" #-} - - -data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList - - - - - - -{-# LINE 67 "templates/GenericTemplate.hs" #-} - - -{-# LINE 77 "templates/GenericTemplate.hs" #-} - - - - - - - - - - -infixr 9 `HappyStk` -data HappyStk a = HappyStk a (HappyStk a) - ------------------------------------------------------------------------------ --- starting the parse - -happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll - ------------------------------------------------------------------------------ --- Accepting the parse - --- If the current token is 0#, it means we've just accepted a partial --- parse (a %partial parser). We must ignore the saved token on the top of --- the stack in this case. -happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = - happyReturn1 ans -happyAccept j tk st sts (HappyStk ans _) = - (happyTcHack j (happyTcHack st)) (happyReturn1 ans) - ------------------------------------------------------------------------------ --- Arrays only: do the next action - - - -happyDoAction i tk st - = {- nothing -} - - - case action of - 0# -> {- nothing -} - happyFail i tk st - -1# -> {- nothing -} - happyAccept i tk st - n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} - - (happyReduceArr Happy_Data_Array.! rule) i tk st - where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) - n -> {- nothing -} - - - happyShift new_state i tk st - where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) - where off = indexShortOffAddr happyActOffsets st - off_i = (off Happy_GHC_Exts.+# i) - check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#)) - then EQ(indexShortOffAddr happyCheck off_i, i) - else False - action - | check = indexShortOffAddr happyTable off_i - | otherwise = indexShortOffAddr happyDefActions st - - -indexShortOffAddr (HappyA# arr) off = - Happy_GHC_Exts.narrow16Int# i - where - i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) - high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) - low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) - off' = off Happy_GHC_Exts.*# 2# - - - - - -data HappyAddr = HappyA# Happy_GHC_Exts.Addr# - - - - ------------------------------------------------------------------------------ --- HappyState data type (not arrays) - - -{-# LINE 170 "templates/GenericTemplate.hs" #-} - ------------------------------------------------------------------------------ --- Shifting a token - -happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = - let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in --- trace "shifting the error token" $ - happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) - -happyShift new_state i tk st sts stk = - happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) - --- happyReduce is specialised for the common cases. - -happySpecReduce_0 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_0 nt fn j tk st@((action)) sts stk - = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) - -happySpecReduce_1 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') - = let r = fn v1 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_2 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') - = let r = fn v1 v2 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_3 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') - = let r = fn v1 v2 v3 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happyReduce k i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyReduce k nt fn j tk st sts stk - = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of - sts1@((HappyCons (st1@(action)) (_))) -> - let r = fn stk in -- it doesn't hurt to always seq here... - happyDoSeq r (happyGoto nt j tk st1 sts1 r) - -happyMonadReduce k nt fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyMonadReduce k nt fn j tk st sts stk = - case happyDrop k (HappyCons (st) (sts)) of - sts1@((HappyCons (st1@(action)) (_))) -> - let drop_stk = happyDropStk k stk in - happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) - -happyMonad2Reduce k nt fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyMonad2Reduce k nt fn j tk st sts stk = - case happyDrop k (HappyCons (st) (sts)) of - sts1@((HappyCons (st1@(action)) (_))) -> - let drop_stk = happyDropStk k stk - - off = indexShortOffAddr happyGotoOffsets st1 - off_i = (off Happy_GHC_Exts.+# nt) - new_state = indexShortOffAddr happyTable off_i - - - - in - happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) - -happyDrop 0# l = l -happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t - -happyDropStk 0# l = l -happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs - ------------------------------------------------------------------------------ --- Moving to a new state after a reduction - - -happyGoto nt j tk st = - {- nothing -} - happyDoAction j tk new_state - where off = indexShortOffAddr happyGotoOffsets st - off_i = (off Happy_GHC_Exts.+# nt) - new_state = indexShortOffAddr happyTable off_i - - - - ------------------------------------------------------------------------------ --- Error recovery (0# is the error token) - --- parse error if we are in recovery and we fail again -happyFail 0# tk old_st _ stk@(x `HappyStk` _) = - let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in --- trace "failing" $ - happyError_ i tk - -{- We don't need state discarding for our restricted implementation of - "error". In fact, it can cause some bogus parses, so I've disabled it - for now --SDM - --- discard a state -happyFail 0# tk old_st (HappyCons ((action)) (sts)) - (saved_tok `HappyStk` _ `HappyStk` stk) = --- trace ("discarding state, depth " ++ show (length stk)) $ - happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) --} - --- Enter error recovery: generate an error token, --- save the old token and carry on. -happyFail i tk (action) sts stk = --- trace "entering error recovery" $ - happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) - --- Internal happy errors: - -notHappyAtAll :: a -notHappyAtAll = error "Internal Happy error\n" - ------------------------------------------------------------------------------ --- Hack to get the typechecker to accept our action functions - - -happyTcHack :: Happy_GHC_Exts.Int# -> a -> a -happyTcHack x y = y -{-# INLINE happyTcHack #-} - - ------------------------------------------------------------------------------ --- Seq-ing. If the --strict flag is given, then Happy emits --- happySeq = happyDoSeq --- otherwise it emits --- happySeq = happyDontSeq - -happyDoSeq, happyDontSeq :: a -> b -> b -happyDoSeq a b = a `seq` b -happyDontSeq a b = b - ------------------------------------------------------------------------------ --- Don't inline any functions from the template. GHC has a nasty habit --- of deciding to inline happyGoto everywhere, which increases the size of --- the generated parser quite a bit. - - -{-# NOINLINE happyDoAction #-} -{-# NOINLINE happyTable #-} -{-# NOINLINE happyCheck #-} -{-# NOINLINE happyActOffsets #-} -{-# NOINLINE happyGotoOffsets #-} -{-# NOINLINE happyDefActions #-} - -{-# NOINLINE happyShift #-} -{-# NOINLINE happySpecReduce_0 #-} -{-# NOINLINE happySpecReduce_1 #-} -{-# NOINLINE happySpecReduce_2 #-} -{-# NOINLINE happySpecReduce_3 #-} -{-# NOINLINE happyReduce #-} -{-# NOINLINE happyMonadReduce #-} -{-# NOINLINE happyGoto #-} -{-# NOINLINE happyFail #-} - --- end of Happy Template. - diff --git a/dist/build/Camfort/camfort-tmp/Camfort/Specification/Stencils/Grammar.hs b/dist/build/Camfort/camfort-tmp/Camfort/Specification/Stencils/Grammar.hs deleted file mode 100644 --- a/dist/build/Camfort/camfort-tmp/Camfort/Specification/Stencils/Grammar.hs +++ /dev/null @@ -1,980 +0,0 @@ -{-# OPTIONS_GHC -w #-} -{-# OPTIONS -fglasgow-exts -cpp #-} --- -*- Mode: Haskell -*- -{-# LANGUAGE DeriveDataTypeable, PatternGuards #-} -module Camfort.Specification.Stencils.Grammar -( specParser, Specification(..), Region(..), Spec(..), Mod(..), lexer ) where - -import Data.Char (isLetter, isNumber, isAlphaNum, toLower, isAlpha, isSpace) -import Data.List (intersect, sort, isPrefixOf) -import Data.Data -import qualified Data.Text as T - -import Debug.Trace - -import Camfort.Analysis.CommentAnnotator -import Camfort.Specification.Stencils.Syntax (showL) -import qualified Data.Array as Happy_Data_Array -import qualified GHC.Exts as Happy_GHC_Exts -import Control.Applicative(Applicative(..)) -import Control.Monad (ap) - --- parser produced by Happy Version 1.19.5 - -newtype HappyAbsSyn = HappyAbsSyn HappyAny -#if __GLASGOW_HASKELL__ >= 607 -type HappyAny = Happy_GHC_Exts.Any -#else -type HappyAny = forall a . a -#endif -happyIn4 :: (Specification) -> (HappyAbsSyn ) -happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn4 #-} -happyOut4 :: (HappyAbsSyn ) -> (Specification) -happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut4 #-} -happyIn5 :: ((String, Region)) -> (HappyAbsSyn ) -happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn5 #-} -happyOut5 :: (HappyAbsSyn ) -> ((String, Region)) -happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut5 #-} -happyIn6 :: (Region) -> (HappyAbsSyn ) -happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn6 #-} -happyOut6 :: (HappyAbsSyn ) -> (Region) -happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut6 #-} -happyIn7 :: ((Depth Int, Dim Int, Bool)) -> (HappyAbsSyn ) -happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn7 #-} -happyOut7 :: (HappyAbsSyn ) -> ((Depth Int, Dim Int, Bool)) -happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut7 #-} -happyIn8 :: ((Dim Int, Bool)) -> (HappyAbsSyn ) -happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn8 #-} -happyOut8 :: (HappyAbsSyn ) -> ((Dim Int, Bool)) -happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut8 #-} -happyIn9 :: ((Depth Int, Bool)) -> (HappyAbsSyn ) -happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn9 #-} -happyOut9 :: (HappyAbsSyn ) -> ((Depth Int, Bool)) -happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut9 #-} -happyIn10 :: (Depth Int) -> (HappyAbsSyn ) -happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn10 #-} -happyOut10 :: (HappyAbsSyn ) -> (Depth Int) -happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut10 #-} -happyIn11 :: (Dim Int) -> (HappyAbsSyn ) -happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn11 #-} -happyOut11 :: (HappyAbsSyn ) -> (Dim Int) -happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut11 #-} -happyIn12 :: (Bool) -> (HappyAbsSyn ) -happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn12 #-} -happyOut12 :: (HappyAbsSyn ) -> (Bool) -happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut12 #-} -happyIn13 :: (Spec) -> (HappyAbsSyn ) -happyIn13 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn13 #-} -happyOut13 :: (HappyAbsSyn ) -> (Spec) -happyOut13 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut13 #-} -happyIn14 :: (Mod) -> (HappyAbsSyn ) -happyIn14 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn14 #-} -happyOut14 :: (HappyAbsSyn ) -> (Mod) -happyOut14 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut14 #-} -happyIn15 :: ([Mod]) -> (HappyAbsSyn ) -happyIn15 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn15 #-} -happyOut15 :: (HappyAbsSyn ) -> ([Mod]) -happyOut15 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut15 #-} -happyIn16 :: (Mod) -> (HappyAbsSyn ) -happyIn16 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn16 #-} -happyOut16 :: (HappyAbsSyn ) -> (Mod) -happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut16 #-} -happyIn17 :: ([String]) -> (HappyAbsSyn ) -happyIn17 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn17 #-} -happyOut17 :: (HappyAbsSyn ) -> ([String]) -happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut17 #-} -happyInTok :: (Token) -> (HappyAbsSyn ) -happyInTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyInTok #-} -happyOutTok :: (HappyAbsSyn ) -> (Token) -happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOutTok #-} - - -happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x51\x00\x71\x00\x00\x00\x74\x00\x50\x00\xfe\xff\x41\x00\x73\x00\x0c\x00\x79\x00\x08\x00\x00\x00\x70\x00\x00\x00\x00\x00\x6f\x00\x6d\x00\x6c\x00\x00\x00\x0c\x00\x6e\x00\x6b\x00\x25\x00\x35\x00\x35\x00\x35\x00\x69\x00\x41\x00\x00\x00\x47\x00\x0c\x00\x3c\x00\x68\x00\x0c\x00\x0c\x00\x00\x00\x6a\x00\x00\x00\x67\x00\x3c\x00\x66\x00\x65\x00\x3d\x00\x36\x00\x40\x00\x00\x00\x64\x00\x4d\x00\x63\x00\x4c\x00\x00\x00\x0c\x00\x37\x00\x00\x00\x00\x00\x62\x00\x60\x00\x61\x00\x5f\x00\x00\x00\x5e\x00\x5d\x00\x00\x00\x5c\x00\x5a\x00\x00\x00\x56\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\x2e\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x59\x00\x53\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x30\x00\x2a\x00\x24\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x57\x00\x00\x00\x4b\x00\x55\x00\x54\x00\x00\x00\x00\x00\x00\x00\x48\x00\x00\x00\x00\x00\x00\x00\xff\xff\x3b\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x49\x00\x00\x00\x42\x00\x3e\x00\x00\x00\x34\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyDefActions :: HappyAddr -happyDefActions = HappyA# "\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\x00\x00\xe3\xff\x00\x00\x00\x00\x00\x00\xe0\xff\xe2\xff\x00\x00\xdf\xff\xde\xff\x00\x00\x00\x00\x00\x00\xf4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\xff\xe1\xff\xe0\xff\x00\x00\xe5\xff\x00\x00\x00\x00\x00\x00\xf6\xff\xf7\xff\xfd\xff\xdc\xff\xe6\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf5\xff\x00\x00\xfc\xff\xf9\xff\xfa\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xff\xea\xff\x00\x00\xf3\xff\xed\xff\x00\x00\xfb\xff\x00\x00\xdd\xff\x00\x00\xef\xff\xee\xff\xeb\xff\xec\xff\xf0\xff\xf1\xff\xe8\xff\xe9\xff\xf8\xff"# - -happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x03\x00\x04\x00\x04\x00\x06\x00\x07\x00\x07\x00\x08\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x04\x00\x07\x00\x06\x00\x07\x00\x04\x00\x13\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x02\x00\x13\x00\x02\x00\x06\x00\x07\x00\x13\x00\x07\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0b\x00\x0c\x00\x03\x00\x0b\x00\x0c\x00\x06\x00\x07\x00\x08\x00\x03\x00\x00\x00\x01\x00\x06\x00\x07\x00\x08\x00\x03\x00\x0f\x00\x10\x00\x06\x00\x07\x00\x08\x00\x14\x00\x05\x00\x05\x00\x08\x00\x08\x00\x09\x00\x09\x00\x05\x00\x06\x00\x05\x00\x08\x00\x06\x00\x08\x00\x0f\x00\x10\x00\x08\x00\x09\x00\x08\x00\x0f\x00\x10\x00\x06\x00\x07\x00\x06\x00\x0f\x00\x10\x00\x01\x00\x02\x00\x02\x00\x0d\x00\x02\x00\x02\x00\x0d\x00\x02\x00\x02\x00\x02\x00\x01\x00\x0a\x00\x14\x00\x12\x00\x14\x00\x05\x00\x08\x00\x05\x00\x0e\x00\x15\x00\x09\x00\xff\xff\x09\x00\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x00\xff\xff\x0e\x00\x08\x00\xff\xff\x02\x00\x0d\x00\x0d\x00\x12\x00\x14\x00\x12\x00\x14\x00\x10\x00\x0d\x00\x03\x00\x12\x00\xff\xff\x13\x00\x13\x00\xff\xff\x13\x00\x13\x00\x11\x00\x11\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x0c\x00\x0d\x00\x3e\x00\x0e\x00\x0f\x00\x3f\x00\x40\x00\x10\x00\x11\x00\x12\x00\x13\x00\x0d\x00\x45\x00\x0e\x00\x0f\x00\x0d\x00\x14\x00\x10\x00\x11\x00\x12\x00\x13\x00\x10\x00\x11\x00\x12\x00\x13\x00\x06\x00\x14\x00\x1b\x00\x39\x00\x3a\x00\x14\x00\x4a\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x1c\x00\x1d\x00\x29\x00\x1c\x00\x1d\x00\x2a\x00\x2b\x00\x2c\x00\x30\x00\x04\x00\x02\x00\x2a\x00\x2b\x00\x2c\x00\x31\x00\x22\x00\x23\x00\x2a\x00\x2b\x00\x2c\x00\x33\x00\x2e\x00\x2e\x00\x46\x00\x2f\x00\x30\x00\x30\x00\x3b\x00\x3c\x00\x2e\x00\x3d\x00\x47\x00\x2f\x00\x22\x00\x23\x00\x2f\x00\x30\x00\x48\x00\x22\x00\x23\x00\x0e\x00\x0f\x00\x49\x00\x22\x00\x23\x00\x06\x00\x04\x00\x34\x00\x43\x00\x23\x00\x24\x00\x25\x00\x27\x00\x16\x00\x1f\x00\x02\x00\x1e\x00\x4e\x00\x38\x00\x36\x00\x2e\x00\x2f\x00\x2e\x00\x45\x00\xff\xff\x30\x00\x00\x00\x30\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x4d\x00\x29\x00\x00\x00\x04\x00\x27\x00\x27\x00\x39\x00\x37\x00\x43\x00\x42\x00\x23\x00\x16\x00\x0c\x00\x34\x00\x00\x00\x18\x00\x19\x00\x00\x00\x1a\x00\x1b\x00\x21\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyReduceArr = Happy_Data_Array.array (1, 35) [ - (1 , happyReduce_1), - (2 , happyReduce_2), - (3 , happyReduce_3), - (4 , happyReduce_4), - (5 , happyReduce_5), - (6 , happyReduce_6), - (7 , happyReduce_7), - (8 , happyReduce_8), - (9 , happyReduce_9), - (10 , happyReduce_10), - (11 , happyReduce_11), - (12 , happyReduce_12), - (13 , happyReduce_13), - (14 , happyReduce_14), - (15 , happyReduce_15), - (16 , happyReduce_16), - (17 , happyReduce_17), - (18 , happyReduce_18), - (19 , happyReduce_19), - (20 , happyReduce_20), - (21 , happyReduce_21), - (22 , happyReduce_22), - (23 , happyReduce_23), - (24 , happyReduce_24), - (25 , happyReduce_25), - (26 , happyReduce_26), - (27 , happyReduce_27), - (28 , happyReduce_28), - (29 , happyReduce_29), - (30 , happyReduce_30), - (31 , happyReduce_31), - (32 , happyReduce_32), - (33 , happyReduce_33), - (34 , happyReduce_34), - (35 , happyReduce_35) - ] - -happy_n_terms = 22 :: Int -happy_n_nonterms = 14 :: Int - -happyReduce_1 = happySpecReduce_1 0# happyReduction_1 -happyReduction_1 happy_x_1 - = case happyOut5 happy_x_1 of { happy_var_1 -> - happyIn4 - (RegionDec (fst happy_var_1) (snd happy_var_1) - )} - -happyReduce_2 = happyReduce 4# 0# happyReduction_2 -happyReduction_2 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut13 happy_x_2 of { happy_var_2 -> - case happyOut17 happy_x_4 of { happy_var_4 -> - happyIn4 - (SpecDec happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_3 = happyReduce 5# 1# happyReduction_3 -happyReduction_3 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_3 of { (TId happy_var_3) -> - case happyOut6 happy_x_5 of { happy_var_5 -> - happyIn5 - ((happy_var_3, happy_var_5) - ) `HappyStk` happyRest}} - -happyReduce_4 = happyReduce 4# 2# happyReduction_4 -happyReduction_4 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut7 happy_x_3 of { happy_var_3 -> - happyIn6 - (applyAttr Forward happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_5 = happyReduce 4# 2# happyReduction_5 -happyReduction_5 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut7 happy_x_3 of { happy_var_3 -> - happyIn6 - (applyAttr Backward happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_6 = happyReduce 4# 2# happyReduction_6 -happyReduction_6 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut7 happy_x_3 of { happy_var_3 -> - happyIn6 - (applyAttr Centered happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_7 = happyReduce 6# 2# happyReduction_7 -happyReduction_7 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_5 of { (TNum happy_var_5) -> - happyIn6 - (Centered 0 (read happy_var_5) True - ) `HappyStk` happyRest} - -happyReduce_8 = happySpecReduce_3 2# happyReduction_8 -happyReduction_8 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut6 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn6 - (Or happy_var_1 happy_var_3 - )}} - -happyReduce_9 = happySpecReduce_3 2# happyReduction_9 -happyReduction_9 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut6 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn6 - (And happy_var_1 happy_var_3 - )}} - -happyReduce_10 = happySpecReduce_3 2# happyReduction_10 -happyReduction_10 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn6 - (happy_var_2 - )} - -happyReduce_11 = happySpecReduce_1 2# happyReduction_11 -happyReduction_11 happy_x_1 - = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - happyIn6 - (Var happy_var_1 - )} - -happyReduce_12 = happySpecReduce_2 3# happyReduction_12 -happyReduction_12 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut8 happy_x_2 of { happy_var_2 -> - happyIn7 - ((happy_var_1, fst happy_var_2, snd happy_var_2) - )}} - -happyReduce_13 = happySpecReduce_2 3# happyReduction_13 -happyReduction_13 happy_x_2 - happy_x_1 - = case happyOut11 happy_x_1 of { happy_var_1 -> - case happyOut9 happy_x_2 of { happy_var_2 -> - happyIn7 - ((fst happy_var_2, happy_var_1, snd happy_var_2) - )}} - -happyReduce_14 = happySpecReduce_3 3# happyReduction_14 -happyReduction_14 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut12 happy_x_1 of { happy_var_1 -> - case happyOut10 happy_x_2 of { happy_var_2 -> - case happyOut11 happy_x_3 of { happy_var_3 -> - happyIn7 - ((happy_var_2, happy_var_3, happy_var_1) - )}}} - -happyReduce_15 = happySpecReduce_3 3# happyReduction_15 -happyReduction_15 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut12 happy_x_1 of { happy_var_1 -> - case happyOut11 happy_x_2 of { happy_var_2 -> - case happyOut10 happy_x_3 of { happy_var_3 -> - happyIn7 - ((happy_var_3, happy_var_2, happy_var_1) - )}}} - -happyReduce_16 = happySpecReduce_2 4# happyReduction_16 -happyReduction_16 happy_x_2 - happy_x_1 - = case happyOut12 happy_x_1 of { happy_var_1 -> - case happyOut11 happy_x_2 of { happy_var_2 -> - happyIn8 - ((happy_var_2, happy_var_1) - )}} - -happyReduce_17 = happySpecReduce_2 4# happyReduction_17 -happyReduction_17 happy_x_2 - happy_x_1 - = case happyOut11 happy_x_1 of { happy_var_1 -> - case happyOut12 happy_x_2 of { happy_var_2 -> - happyIn8 - ((happy_var_1, happy_var_2) - )}} - -happyReduce_18 = happySpecReduce_1 4# happyReduction_18 -happyReduction_18 happy_x_1 - = case happyOut11 happy_x_1 of { happy_var_1 -> - happyIn8 - ((happy_var_1, True) - )} - -happyReduce_19 = happySpecReduce_2 5# happyReduction_19 -happyReduction_19 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut12 happy_x_2 of { happy_var_2 -> - happyIn9 - ((happy_var_1, happy_var_2) - )}} - -happyReduce_20 = happySpecReduce_2 5# happyReduction_20 -happyReduction_20 happy_x_2 - happy_x_1 - = case happyOut12 happy_x_1 of { happy_var_1 -> - case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn9 - ((happy_var_2, happy_var_1) - )}} - -happyReduce_21 = happySpecReduce_1 5# happyReduction_21 -happyReduction_21 happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - happyIn9 - ((happy_var_1, True) - )} - -happyReduce_22 = happySpecReduce_3 6# happyReduction_22 -happyReduction_22 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_3 of { (TNum happy_var_3) -> - happyIn10 - (Depth $ read happy_var_3 - )} - -happyReduce_23 = happySpecReduce_3 7# happyReduction_23 -happyReduction_23 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_3 of { (TNum happy_var_3) -> - happyIn11 - (Dim $ read happy_var_3 - )} - -happyReduce_24 = happySpecReduce_1 8# happyReduction_24 -happyReduction_24 happy_x_1 - = happyIn12 - (False - ) - -happyReduce_25 = happySpecReduce_3 9# happyReduction_25 -happyReduction_25 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut15 happy_x_1 of { happy_var_1 -> - case happyOut14 happy_x_2 of { happy_var_2 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn13 - (Spatial (happy_var_1 ++ [happy_var_2]) happy_var_3 - )}}} - -happyReduce_26 = happySpecReduce_2 9# happyReduction_26 -happyReduction_26 happy_x_2 - happy_x_1 - = case happyOut14 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn13 - (Spatial [happy_var_1] happy_var_2 - )}} - -happyReduce_27 = happySpecReduce_2 9# happyReduction_27 -happyReduction_27 happy_x_2 - happy_x_1 - = case happyOut16 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn13 - (Spatial [happy_var_1] happy_var_2 - )}} - -happyReduce_28 = happySpecReduce_1 9# happyReduction_28 -happyReduction_28 happy_x_1 - = case happyOut6 happy_x_1 of { happy_var_1 -> - happyIn13 - (Spatial [] happy_var_1 - )} - -happyReduce_29 = happySpecReduce_1 10# happyReduction_29 -happyReduction_29 happy_x_1 - = happyIn14 - (ReadOnce - ) - -happyReduce_30 = happySpecReduce_2 11# happyReduction_30 -happyReduction_30 happy_x_2 - happy_x_1 - = case happyOut16 happy_x_1 of { happy_var_1 -> - case happyOut15 happy_x_2 of { happy_var_2 -> - happyIn15 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_31 = happySpecReduce_1 11# happyReduction_31 -happyReduction_31 happy_x_1 - = case happyOut16 happy_x_1 of { happy_var_1 -> - happyIn15 - ([happy_var_1] - )} - -happyReduce_32 = happySpecReduce_1 12# happyReduction_32 -happyReduction_32 happy_x_1 - = happyIn16 - (AtMost - ) - -happyReduce_33 = happySpecReduce_1 12# happyReduction_33 -happyReduction_33 happy_x_1 - = happyIn16 - (AtLeast - ) - -happyReduce_34 = happySpecReduce_2 13# happyReduction_34 -happyReduction_34 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - case happyOut17 happy_x_2 of { happy_var_2 -> - happyIn17 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_35 = happySpecReduce_1 13# happyReduction_35 -happyReduction_35 happy_x_1 - = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - happyIn17 - ([happy_var_1] - )} - -happyNewToken action sts stk [] = - happyDoAction 21# notHappyAtAll action sts stk [] - -happyNewToken action sts stk (tk:tks) = - let cont i = happyDoAction i tk action sts stk tks in - case tk of { - TId "stencil" -> cont 1#; - TId "region" -> cont 2#; - TId "readonce" -> cont 3#; - TId "reflexive" -> cont 4#; - TId "irreflexive" -> cont 5#; - TId "atmost" -> cont 6#; - TId "atleast" -> cont 7#; - TId "dim" -> cont 8#; - TId "depth" -> cont 9#; - TId "forward" -> cont 10#; - TId "backward" -> cont 11#; - TId "centered" -> cont 12#; - TId happy_dollar_dollar -> cont 13#; - TNum happy_dollar_dollar -> cont 14#; - TPlus -> cont 15#; - TStar -> cont 16#; - TDoubleColon -> cont 17#; - TEqual -> cont 18#; - TLParen -> cont 19#; - TRParen -> cont 20#; - _ -> happyError' (tk:tks) - } - -happyError_ 21# tk tks = happyError' tks -happyError_ _ tk tks = happyError' (tk:tks) - -happyThen :: () => Either AnnotationParseError a -> (a -> Either AnnotationParseError b) -> Either AnnotationParseError b -happyThen = (>>=) -happyReturn :: () => a -> Either AnnotationParseError a -happyReturn = (return) -happyThen1 m k tks = (>>=) m (\a -> k a tks) -happyReturn1 :: () => a -> b -> Either AnnotationParseError a -happyReturn1 = \a tks -> (return) a -happyError' :: () => [(Token)] -> Either AnnotationParseError a -happyError' = happyError - -parseSpec tks = happySomeParser where - happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x)) - -happySeq = happyDontSeq - - -newtype Depth a = Depth a -newtype Dim a = Dim a - -applyAttr :: (Int -> Int -> Bool -> Region) - -> (Depth Int, Dim Int, Bool) - -> Region -applyAttr constr (Depth d, Dim dim, irrefl) = constr d dim irrefl - -data Specification - = RegionDec String Region - | SpecDec Spec [String] - deriving (Show, Eq, Ord, Typeable, Data) - -data Region - = Forward Int Int Bool - | Backward Int Int Bool - | Centered Int Int Bool - | Or Region Region - | And Region Region - | Var String - deriving (Show, Eq, Ord, Typeable, Data) - -data Spec = Spatial [Mod] Region - deriving (Show, Eq, Ord, Typeable, Data) - -data Mod - = AtLeast - | AtMost - | ReadOnce - deriving (Show, Eq, Ord, Typeable, Data) - --------------------------------------------------- - -data Token - = TDoubleColon - | TStar - | TPlus - | TEqual - | TComma - | TLParen - | TRParen - | TId String - | TNum String - deriving (Show) - -addToTokens :: Token -> String -> Either AnnotationParseError [ Token ] -addToTokens tok rest = do - tokens <- lexer' rest - return $ tok : tokens - -lexer :: String -> Either AnnotationParseError [ Token ] -lexer input | length (stripLeadingWhiteSpace input) >= 2 = - case stripLeadingWhiteSpace input of - -- Check the leading character is '=' for specification - '=':input' -> testAnnotation input' - '!':input' -> testAnnotation input' - '>':input' -> testAnnotation input' - '<':input' -> testAnnotation input' - _ -> Left NotAnnotation - where - stripLeadingWhiteSpace = T.unpack . T.strip . T.pack - testAnnotation inp = - -- First test to see if the input looks like an actual - -- specification of either a stencil or region - if (inp `hasPrefix` "stencil" || inp `hasPrefix` "region") - then lexer' inp - else Left NotAnnotation - hasPrefix [] str = False - hasPrefix (' ':xs) str = hasPrefix xs str - hasPrefix xs str = isPrefixOf str xs -lexer _ = Left NotAnnotation - - -lexer' :: String -> Either AnnotationParseError [ Token ] -lexer' [] = return [] -lexer' (' ':xs) = lexer' xs -lexer' ('\t':xs) = lexer' xs -lexer' (':':':':xs) = addToTokens TDoubleColon xs -lexer' ('*':xs) = addToTokens TStar xs -lexer' ('+':xs) = addToTokens TPlus xs -lexer' ('=':xs) = addToTokens TEqual xs --- Comma hack: drop commas that are not separating numbers, in order to avoid need for 2-token lookahead. -lexer' (',':xs) - | x':xs' <- dropWhile isSpace xs, not (isNumber x') = lexer' (x':xs') - | otherwise = addToTokens TComma xs -lexer' ('(':xs) = addToTokens TLParen xs -lexer' (')':xs) = addToTokens TRParen xs -lexer' (x:xs) - | isLetter x = aux TId $ \ c -> isAlphaNum c || c == '_' - | isNumber x = aux TNum isNumber - | otherwise - = failWith $ "Not an indentifier " ++ show x - where - aux f p = (f target :) `fmap` lexer' rest - where (target, rest) = span p (x:xs) -lexer' x - = failWith $ "Not a valid piece of stencil syntax " ++ show x - --------------------------------------------------- - --- specParser :: String -> Either AnnotationParseError Specification -specParser :: AnnotationParser Specification -specParser src = do - tokens <- lexer src - parseSpec tokens >>= modValidate - --- Check whether modifiers are used correctly -modValidate :: Specification -> Either AnnotationParseError Specification -modValidate (SpecDec (Spatial mods r) vars) = - do mods' <- modValidate' $ sort mods - return $ SpecDec (Spatial mods' r) vars - - where modValidate' [] = return $ [] - - modValidate' (AtLeast : AtLeast : xs) - = failWith "Duplicate 'atLeast' modifier; use at most one." - - modValidate' (AtMost : AtMost : xs) - = failWith "Duplicate 'atMost' modifier; use at most one." - - modValidate' (ReadOnce : ReadOnce : xs) - = failWith "Duplicate 'readOnce' modifier; use at most one." - - modValidate' (AtLeast : AtMost : xs) - = failWith $ "Conflicting modifiers: cannot use 'atLeast' and " - ++ "'atMost' together" - - modValidate' (x : xs) - = do xs' <- modValidate' xs - return $ x : xs' -modValidate x = return x - -happyError :: [ Token ] -> Either AnnotationParseError a -happyError t = failWith $ "Could not parse specification at: " ++ show t -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 19 "" #-} -{-# LINE 1 "/usr/local/lib/ghc-7.10.2/include/ghcversion.h" #-} - - - - - - - - - - - - - - - - - - -{-# LINE 20 "" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} --- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp - - -{-# LINE 13 "templates/GenericTemplate.hs" #-} - - - - - --- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. -#if __GLASGOW_HASKELL__ > 706 -#define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool) -#define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool) -#define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Bool) -#else -#define LT(n,m) (n Happy_GHC_Exts.<# m) -#define GTE(n,m) (n Happy_GHC_Exts.>=# m) -#define EQ(n,m) (n Happy_GHC_Exts.==# m) -#endif - -{-# LINE 46 "templates/GenericTemplate.hs" #-} - - -data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList - - - - - - -{-# LINE 67 "templates/GenericTemplate.hs" #-} - - -{-# LINE 77 "templates/GenericTemplate.hs" #-} - - - - - - - - - - -infixr 9 `HappyStk` -data HappyStk a = HappyStk a (HappyStk a) - ------------------------------------------------------------------------------ --- starting the parse - -happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll - ------------------------------------------------------------------------------ --- Accepting the parse - --- If the current token is 0#, it means we've just accepted a partial --- parse (a %partial parser). We must ignore the saved token on the top of --- the stack in this case. -happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = - happyReturn1 ans -happyAccept j tk st sts (HappyStk ans _) = - (happyTcHack j (happyTcHack st)) (happyReturn1 ans) - ------------------------------------------------------------------------------ --- Arrays only: do the next action - - - -happyDoAction i tk st - = {- nothing -} - - - case action of - 0# -> {- nothing -} - happyFail i tk st - -1# -> {- nothing -} - happyAccept i tk st - n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} - - (happyReduceArr Happy_Data_Array.! rule) i tk st - where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) - n -> {- nothing -} - - - happyShift new_state i tk st - where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) - where off = indexShortOffAddr happyActOffsets st - off_i = (off Happy_GHC_Exts.+# i) - check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#)) - then EQ(indexShortOffAddr happyCheck off_i, i) - else False - action - | check = indexShortOffAddr happyTable off_i - | otherwise = indexShortOffAddr happyDefActions st - - -indexShortOffAddr (HappyA# arr) off = - Happy_GHC_Exts.narrow16Int# i - where - i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) - high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) - low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) - off' = off Happy_GHC_Exts.*# 2# - - - - - -data HappyAddr = HappyA# Happy_GHC_Exts.Addr# - - - - ------------------------------------------------------------------------------ --- HappyState data type (not arrays) - - -{-# LINE 170 "templates/GenericTemplate.hs" #-} - ------------------------------------------------------------------------------ --- Shifting a token - -happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = - let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in --- trace "shifting the error token" $ - happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) - -happyShift new_state i tk st sts stk = - happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) - --- happyReduce is specialised for the common cases. - -happySpecReduce_0 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_0 nt fn j tk st@((action)) sts stk - = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) - -happySpecReduce_1 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') - = let r = fn v1 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_2 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') - = let r = fn v1 v2 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_3 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') - = let r = fn v1 v2 v3 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happyReduce k i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyReduce k nt fn j tk st sts stk - = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of - sts1@((HappyCons (st1@(action)) (_))) -> - let r = fn stk in -- it doesn't hurt to always seq here... - happyDoSeq r (happyGoto nt j tk st1 sts1 r) - -happyMonadReduce k nt fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyMonadReduce k nt fn j tk st sts stk = - case happyDrop k (HappyCons (st) (sts)) of - sts1@((HappyCons (st1@(action)) (_))) -> - let drop_stk = happyDropStk k stk in - happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) - -happyMonad2Reduce k nt fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyMonad2Reduce k nt fn j tk st sts stk = - case happyDrop k (HappyCons (st) (sts)) of - sts1@((HappyCons (st1@(action)) (_))) -> - let drop_stk = happyDropStk k stk - - off = indexShortOffAddr happyGotoOffsets st1 - off_i = (off Happy_GHC_Exts.+# nt) - new_state = indexShortOffAddr happyTable off_i - - - - in - happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) - -happyDrop 0# l = l -happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t - -happyDropStk 0# l = l -happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs - ------------------------------------------------------------------------------ --- Moving to a new state after a reduction - - -happyGoto nt j tk st = - {- nothing -} - happyDoAction j tk new_state - where off = indexShortOffAddr happyGotoOffsets st - off_i = (off Happy_GHC_Exts.+# nt) - new_state = indexShortOffAddr happyTable off_i - - - - ------------------------------------------------------------------------------ --- Error recovery (0# is the error token) - --- parse error if we are in recovery and we fail again -happyFail 0# tk old_st _ stk@(x `HappyStk` _) = - let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in --- trace "failing" $ - happyError_ i tk - -{- We don't need state discarding for our restricted implementation of - "error". In fact, it can cause some bogus parses, so I've disabled it - for now --SDM - --- discard a state -happyFail 0# tk old_st (HappyCons ((action)) (sts)) - (saved_tok `HappyStk` _ `HappyStk` stk) = --- trace ("discarding state, depth " ++ show (length stk)) $ - happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) --} - --- Enter error recovery: generate an error token, --- save the old token and carry on. -happyFail i tk (action) sts stk = --- trace "entering error recovery" $ - happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) - --- Internal happy errors: - -notHappyAtAll :: a -notHappyAtAll = error "Internal Happy error\n" - ------------------------------------------------------------------------------ --- Hack to get the typechecker to accept our action functions - - -happyTcHack :: Happy_GHC_Exts.Int# -> a -> a -happyTcHack x y = y -{-# INLINE happyTcHack #-} - - ------------------------------------------------------------------------------ --- Seq-ing. If the --strict flag is given, then Happy emits --- happySeq = happyDoSeq --- otherwise it emits --- happySeq = happyDontSeq - -happyDoSeq, happyDontSeq :: a -> b -> b -happyDoSeq a b = a `seq` b -happyDontSeq a b = b - ------------------------------------------------------------------------------ --- Don't inline any functions from the template. GHC has a nasty habit --- of deciding to inline happyGoto everywhere, which increases the size of --- the generated parser quite a bit. - - -{-# NOINLINE happyDoAction #-} -{-# NOINLINE happyTable #-} -{-# NOINLINE happyCheck #-} -{-# NOINLINE happyActOffsets #-} -{-# NOINLINE happyGotoOffsets #-} -{-# NOINLINE happyDefActions #-} - -{-# NOINLINE happyShift #-} -{-# NOINLINE happySpecReduce_0 #-} -{-# NOINLINE happySpecReduce_1 #-} -{-# NOINLINE happySpecReduce_2 #-} -{-# NOINLINE happySpecReduce_3 #-} -{-# NOINLINE happyReduce #-} -{-# NOINLINE happyMonadReduce #-} -{-# NOINLINE happyGoto #-} -{-# NOINLINE happyFail #-} - --- end of Happy Template. - diff --git a/dist/build/Camfort/camfort-tmp/Camfort/Specification/Units/Parser.hs b/dist/build/Camfort/camfort-tmp/Camfort/Specification/Units/Parser.hs deleted file mode 100644 --- a/dist/build/Camfort/camfort-tmp/Camfort/Specification/Units/Parser.hs +++ /dev/null @@ -1,766 +0,0 @@ -{-# OPTIONS_GHC -w #-} -{-# OPTIONS -fglasgow-exts -cpp #-} --- -*- Mode: Haskell -*- - -{-# LANGUAGE DeriveDataTypeable #-} -module Camfort.Specification.Units.Parser ( unitParser - , UnitStatement(..) - , UnitOfMeasure(..) - , UnitPower(..) - ) where - -import Camfort.Analysis.CommentAnnotator -import Data.Data -import Data.List -import Data.Char (isLetter, isNumber, isAlphaNum, toLower) -import qualified Data.Text as T -import qualified Data.Array as Happy_Data_Array -import qualified GHC.Exts as Happy_GHC_Exts -import Control.Applicative(Applicative(..)) -import Control.Monad (ap) - --- parser produced by Happy Version 1.19.5 - -newtype HappyAbsSyn = HappyAbsSyn HappyAny -#if __GLASGOW_HASKELL__ >= 607 -type HappyAny = Happy_GHC_Exts.Any -#else -type HappyAny = forall a . a -#endif -happyIn4 :: (UnitStatement) -> (HappyAbsSyn ) -happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn4 #-} -happyOut4 :: (HappyAbsSyn ) -> (UnitStatement) -happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut4 #-} -happyIn5 :: (Maybe [String]) -> (HappyAbsSyn ) -happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn5 #-} -happyOut5 :: (HappyAbsSyn ) -> (Maybe [String]) -happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut5 #-} -happyIn6 :: ([String]) -> (HappyAbsSyn ) -happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn6 #-} -happyOut6 :: (HappyAbsSyn ) -> ([String]) -happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut6 #-} -happyIn7 :: (UnitOfMeasure) -> (HappyAbsSyn ) -happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn7 #-} -happyOut7 :: (HappyAbsSyn ) -> (UnitOfMeasure) -happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut7 #-} -happyIn8 :: (UnitOfMeasure) -> (HappyAbsSyn ) -happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn8 #-} -happyOut8 :: (HappyAbsSyn ) -> (UnitOfMeasure) -happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut8 #-} -happyIn9 :: (UnitOfMeasure) -> (HappyAbsSyn ) -happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn9 #-} -happyOut9 :: (HappyAbsSyn ) -> (UnitOfMeasure) -happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut9 #-} -happyIn10 :: (UnitPower) -> (HappyAbsSyn ) -happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn10 #-} -happyOut10 :: (HappyAbsSyn ) -> (UnitPower) -happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut10 #-} -happyIn11 :: (Integer) -> (HappyAbsSyn ) -happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn11 #-} -happyOut11 :: (HappyAbsSyn ) -> (Integer) -happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut11 #-} -happyIn12 :: (String) -> (HappyAbsSyn ) -happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn12 #-} -happyOut12 :: (HappyAbsSyn ) -> (String) -happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut12 #-} -happyInTok :: (Token) -> (HappyAbsSyn ) -happyInTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyInTok #-} -happyOutTok :: (HappyAbsSyn ) -> (Token) -happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOutTok #-} - - -happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x44\x00\x41\x00\x0f\x00\x3c\x00\x05\x00\x2b\x00\x04\x00\x3d\x00\x00\x00\x00\x00\x3f\x00\xff\xff\x3b\x00\x01\x00\x34\x00\x00\x00\x35\x00\x10\x00\x36\x00\x0f\x00\x00\x00\x04\x00\x3a\x00\x00\x00\x39\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x19\x00\x0f\x00\x00\x00\x00\x00\x33\x00\xfd\xff\x00\x00\x38\x00\x00\x00\x19\x00\x00\x00\x2c\x00\x00\x00\x00\x00"# - -happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\x37\x00\x00\x00\x27\x00\x00\x00\x27\x00\x22\x00\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x31\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x1d\x00\x00\x00\x30\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x28\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x26\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyDefActions :: HappyAddr -happyDefActions = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfb\xff\xf8\xff\xf2\xff\xef\xff\xf7\xff\x00\x00\x00\x00\x00\x00\xf8\xff\xf7\xff\xf5\xff\x00\x00\x00\x00\xf4\xff\x00\x00\xfe\xff\x00\x00\x00\x00\xfc\xff\xf9\xff\xf3\xff\xf1\xff\xee\xff\xeb\xff\xe8\xff\xe9\xff\x00\x00\x00\x00\x00\x00\xf6\xff\xf0\xff\xfd\xff\x00\x00\xea\xff\x00\x00\xfa\xff\x00\x00\xed\xff\x00\x00\xec\xff"# - -happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x02\x00\x03\x00\x02\x00\x02\x00\x08\x00\x02\x00\x02\x00\x03\x00\x0c\x00\x0b\x00\x0c\x00\x0b\x00\x0c\x00\x09\x00\x0b\x00\x0b\x00\x02\x00\x03\x00\x03\x00\x04\x00\x08\x00\x06\x00\x03\x00\x04\x00\x05\x00\x0b\x00\x0b\x00\x03\x00\x04\x00\x02\x00\x06\x00\x03\x00\x04\x00\x05\x00\x01\x00\x06\x00\x07\x00\x08\x00\x03\x00\x04\x00\x05\x00\x03\x00\x04\x00\x05\x00\x07\x00\x08\x00\x07\x00\x08\x00\x03\x00\x04\x00\x08\x00\x09\x00\x05\x00\x05\x00\x00\x00\x0c\x00\x07\x00\x02\x00\x08\x00\x02\x00\x07\x00\x05\x00\x0a\x00\x0c\x00\x02\x00\x01\x00\x08\x00\x07\x00\x01\x00\xff\xff\xff\xff\xff\xff\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x09\x00\x0f\x00\x09\x00\x28\x00\x2a\x00\x09\x00\x09\x00\x0a\x00\x2b\x00\x0c\x00\x10\x00\x14\x00\x24\x00\x0b\x00\x14\x00\x0c\x00\x09\x00\x0a\x00\x1e\x00\x1f\x00\x26\x00\x20\x00\x24\x00\x06\x00\x07\x00\x0c\x00\x21\x00\x1e\x00\x1f\x00\x17\x00\x20\x00\x0c\x00\x0d\x00\x07\x00\x14\x00\x1a\x00\x1b\x00\x1c\x00\x0c\x00\x0d\x00\x07\x00\x05\x00\x06\x00\x07\x00\x2b\x00\x1c\x00\x25\x00\x1c\x00\x1e\x00\x1f\x00\x16\x00\x17\x00\x19\x00\x12\x00\x03\x00\x2d\x00\x12\x00\x19\x00\x16\x00\x19\x00\x12\x00\x28\x00\x22\x00\x23\x00\x11\x00\x03\x00\x16\x00\x12\x00\x05\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyReduceArr = Happy_Data_Array.array (1, 23) [ - (1 , happyReduce_1), - (2 , happyReduce_2), - (3 , happyReduce_3), - (4 , happyReduce_4), - (5 , happyReduce_5), - (6 , happyReduce_6), - (7 , happyReduce_7), - (8 , happyReduce_8), - (9 , happyReduce_9), - (10 , happyReduce_10), - (11 , happyReduce_11), - (12 , happyReduce_12), - (13 , happyReduce_13), - (14 , happyReduce_14), - (15 , happyReduce_15), - (16 , happyReduce_16), - (17 , happyReduce_17), - (18 , happyReduce_18), - (19 , happyReduce_19), - (20 , happyReduce_20), - (21 , happyReduce_21), - (22 , happyReduce_22), - (23 , happyReduce_23) - ] - -happy_n_terms = 14 :: Int -happy_n_nonterms = 9 :: Int - -happyReduce_1 = happySpecReduce_3 0# happyReduction_1 -happyReduction_1 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut7 happy_x_2 of { happy_var_2 -> - case happyOut5 happy_x_3 of { happy_var_3 -> - happyIn4 - (UnitAssignment happy_var_3 happy_var_2 - )}} - -happyReduce_2 = happyReduce 5# 0# happyReduction_2 -happyReduction_2 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_3 of { (TId happy_var_3) -> - case happyOut7 happy_x_5 of { happy_var_5 -> - happyIn4 - (UnitAlias happy_var_3 happy_var_5 - ) `HappyStk` happyRest}} - -happyReduce_3 = happySpecReduce_2 1# happyReduction_3 -happyReduction_3 happy_x_2 - happy_x_1 - = case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn5 - (Just happy_var_2 - )} - -happyReduce_4 = happySpecReduce_0 1# happyReduction_4 -happyReduction_4 = happyIn5 - (Nothing - ) - -happyReduce_5 = happySpecReduce_3 2# happyReduction_5 -happyReduction_5 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn6 - (happy_var_1 : happy_var_3 - )}} - -happyReduce_6 = happySpecReduce_1 2# happyReduction_6 -happyReduction_6 happy_x_1 - = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - happyIn6 - ([happy_var_1] - )} - -happyReduce_7 = happySpecReduce_1 3# happyReduction_7 -happyReduction_7 happy_x_1 - = case happyOut8 happy_x_1 of { happy_var_1 -> - happyIn7 - (happy_var_1 - )} - -happyReduce_8 = happySpecReduce_1 3# happyReduction_8 -happyReduction_8 happy_x_1 - = happyIn7 - (Unitless - ) - -happyReduce_9 = happySpecReduce_3 3# happyReduction_9 -happyReduction_9 happy_x_3 - happy_x_2 - happy_x_1 - = happyIn7 - (Unitless - ) - -happyReduce_10 = happySpecReduce_2 3# happyReduction_10 -happyReduction_10 happy_x_2 - happy_x_1 - = happyIn7 - (Unitless - ) - -happyReduce_11 = happySpecReduce_2 4# happyReduction_11 -happyReduction_11 happy_x_2 - happy_x_1 - = case happyOut8 happy_x_1 of { happy_var_1 -> - case happyOut9 happy_x_2 of { happy_var_2 -> - happyIn8 - (UnitProduct happy_var_1 happy_var_2 - )}} - -happyReduce_12 = happySpecReduce_3 4# happyReduction_12 -happyReduction_12 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut7 happy_x_1 of { happy_var_1 -> - case happyOut9 happy_x_3 of { happy_var_3 -> - happyIn8 - (UnitQuotient happy_var_1 happy_var_3 - )}} - -happyReduce_13 = happySpecReduce_1 4# happyReduction_13 -happyReduction_13 happy_x_1 - = case happyOut9 happy_x_1 of { happy_var_1 -> - happyIn8 - (happy_var_1 - )} - -happyReduce_14 = happySpecReduce_3 5# happyReduction_14 -happyReduction_14 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut9 happy_x_1 of { happy_var_1 -> - case happyOut10 happy_x_3 of { happy_var_3 -> - happyIn9 - (UnitExponentiation happy_var_1 happy_var_3 - )}} - -happyReduce_15 = happySpecReduce_3 5# happyReduction_15 -happyReduction_15 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut8 happy_x_2 of { happy_var_2 -> - happyIn9 - (happy_var_2 - )} - -happyReduce_16 = happySpecReduce_1 5# happyReduction_16 -happyReduction_16 happy_x_1 - = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - happyIn9 - (UnitBasic happy_var_1 - )} - -happyReduce_17 = happySpecReduce_1 6# happyReduction_17 -happyReduction_17 happy_x_1 - = case happyOut11 happy_x_1 of { happy_var_1 -> - happyIn10 - (UnitPowerInteger happy_var_1 - )} - -happyReduce_18 = happySpecReduce_3 6# happyReduction_18 -happyReduction_18 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut11 happy_x_2 of { happy_var_2 -> - happyIn10 - (UnitPowerInteger happy_var_2 - )} - -happyReduce_19 = happyReduce 5# 6# happyReduction_19 -happyReduction_19 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut11 happy_x_2 of { happy_var_2 -> - case happyOut11 happy_x_4 of { happy_var_4 -> - happyIn10 - (UnitPowerRational happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_20 = happySpecReduce_1 7# happyReduction_20 -happyReduction_20 happy_x_1 - = case happyOut12 happy_x_1 of { happy_var_1 -> - happyIn11 - (read happy_var_1 - )} - -happyReduce_21 = happySpecReduce_2 7# happyReduction_21 -happyReduction_21 happy_x_2 - happy_x_1 - = case happyOut12 happy_x_2 of { happy_var_2 -> - happyIn11 - (read $ '-' : happy_var_2 - )} - -happyReduce_22 = happySpecReduce_1 8# happyReduction_22 -happyReduction_22 happy_x_1 - = case happyOutTok happy_x_1 of { (TNum happy_var_1) -> - happyIn12 - (happy_var_1 - )} - -happyReduce_23 = happySpecReduce_1 8# happyReduction_23 -happyReduction_23 happy_x_1 - = happyIn12 - ("1" - ) - -happyNewToken action sts stk [] = - happyDoAction 13# notHappyAtAll action sts stk [] - -happyNewToken action sts stk (tk:tks) = - let cont i = happyDoAction i tk action sts stk tks in - case tk of { - TId "unit" -> cont 1#; - TId happy_dollar_dollar -> cont 2#; - TNum "1" -> cont 3#; - TNum happy_dollar_dollar -> cont 4#; - TComma -> cont 5#; - TMinus -> cont 6#; - TExponentiation -> cont 7#; - TDivision -> cont 8#; - TDoubleColon -> cont 9#; - TEqual -> cont 10#; - TLeftPar -> cont 11#; - TRightPar -> cont 12#; - _ -> happyError' (tk:tks) - } - -happyError_ 13# tk tks = happyError' tks -happyError_ _ tk tks = happyError' (tk:tks) - -happyThen :: () => Either AnnotationParseError a -> (a -> Either AnnotationParseError b) -> Either AnnotationParseError b -happyThen = (>>=) -happyReturn :: () => a -> Either AnnotationParseError a -happyReturn = (return) -happyThen1 m k tks = (>>=) m (\a -> k a tks) -happyReturn1 :: () => a -> b -> Either AnnotationParseError a -happyReturn1 = \a tks -> (return) a -happyError' :: () => [(Token)] -> Either AnnotationParseError a -happyError' = happyError - -parseUnit tks = happySomeParser where - happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x)) - -happySeq = happyDontSeq - - -data UnitStatement = - UnitAssignment (Maybe [String]) UnitOfMeasure - | UnitAlias String UnitOfMeasure - deriving Data - -instance Show UnitStatement where - show (UnitAssignment (Just ss) uom) = "= unit (" ++ show uom ++ ") :: " ++ (intercalate "," ss) - show (UnitAssignment Nothing uom) = "= unit (" ++ show uom ++ ")" - show (UnitAlias s uom) = "= unit :: " ++ s ++ " = " ++ show uom - -data UnitOfMeasure = - Unitless - | UnitBasic String - | UnitProduct UnitOfMeasure UnitOfMeasure - | UnitQuotient UnitOfMeasure UnitOfMeasure - | UnitExponentiation UnitOfMeasure UnitPower - deriving Data - -instance Show UnitOfMeasure where - show Unitless = "1" - show (UnitBasic s) = s - show (UnitProduct uom1 uom2) = show uom1 ++ " " ++ show uom2 - show (UnitQuotient uom1 uom2) = show uom1 ++ " / " ++ show uom2 - show (UnitExponentiation uom exp) = show uom ++ "** (" ++ show exp ++ ")" - -data UnitPower = - UnitPowerInteger Integer - | UnitPowerRational Integer Integer - deriving Data - -instance Show UnitPower where - show (UnitPowerInteger i) = show i - show (UnitPowerRational i1 i2) = show i1 ++ "/" ++ show i2 - -data Token = - TUnit - | TComma - | TDoubleColon - | TExponentiation - | TDivision - | TMinus - | TEqual - | TLeftPar - | TRightPar - | TId String - | TNum String - deriving (Show) - -lexer :: String -> Either AnnotationParseError [ Token ] -lexer [] = Left NotAnnotation -lexer (c:xs) - | c `elem` ['=', '!', '>', '<'] = - -- First test to see if the input looks like an actual unit specification - if "unit" `isPrefixOf` (T.unpack . T.strip . T.toLower . T.pack $ xs) - then lexer' xs - else Left NotAnnotation - | otherwise = Left NotAnnotation - -addToTokens :: Token -> String -> Either AnnotationParseError [ Token ] -addToTokens tok rest = do - tokens <- lexer' rest - return $ tok : tokens - -lexer' :: String -> Either AnnotationParseError [ 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 TExponentiation xs -lexer' (',':xs) = addToTokens TComma xs -lexer' ('/':xs) = addToTokens TDivision xs -lexer' ('-':xs) = addToTokens TMinus xs -lexer' ('=':xs) = addToTokens TEqual xs -lexer' ('(':xs) = addToTokens TLeftPar xs -lexer' (')':xs) = addToTokens TRightPar xs -lexer' (x:xs) - | isLetter x = aux (\c -> isAlphaNum c || c `elem` ['\'','_','-']) TId - | isNumber x = aux isNumber TNum - | otherwise = failWith $ "Not valid unit syntax at " ++ show (x:xs) ++ "\n" - where - aux p cons = - let (target, rest) = span p xs - in lexer' rest >>= (\tokens -> return $ cons (x:target) : tokens) - -unitParser :: String -> Either AnnotationParseError UnitStatement -unitParser src = do - tokens <- lexer $ map toLower src - parseUnit tokens - -happyError :: [ Token ] -> Either AnnotationParseError a -happyError t = failWith $ "Could not parse unit specification at: " ++ show t ++ "\n" -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 19 "" #-} -{-# LINE 1 "/usr/local/lib/ghc-7.10.2/include/ghcversion.h" #-} - - - - - - - - - - - - - - - - - - -{-# LINE 20 "" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} --- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp - - -{-# LINE 13 "templates/GenericTemplate.hs" #-} - - - - - --- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. -#if __GLASGOW_HASKELL__ > 706 -#define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool) -#define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool) -#define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Bool) -#else -#define LT(n,m) (n Happy_GHC_Exts.<# m) -#define GTE(n,m) (n Happy_GHC_Exts.>=# m) -#define EQ(n,m) (n Happy_GHC_Exts.==# m) -#endif - -{-# LINE 46 "templates/GenericTemplate.hs" #-} - - -data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList - - - - - - -{-# LINE 67 "templates/GenericTemplate.hs" #-} - - -{-# LINE 77 "templates/GenericTemplate.hs" #-} - - - - - - - - - - -infixr 9 `HappyStk` -data HappyStk a = HappyStk a (HappyStk a) - ------------------------------------------------------------------------------ --- starting the parse - -happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll - ------------------------------------------------------------------------------ --- Accepting the parse - --- If the current token is 0#, it means we've just accepted a partial --- parse (a %partial parser). We must ignore the saved token on the top of --- the stack in this case. -happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = - happyReturn1 ans -happyAccept j tk st sts (HappyStk ans _) = - (happyTcHack j (happyTcHack st)) (happyReturn1 ans) - ------------------------------------------------------------------------------ --- Arrays only: do the next action - - - -happyDoAction i tk st - = {- nothing -} - - - case action of - 0# -> {- nothing -} - happyFail i tk st - -1# -> {- nothing -} - happyAccept i tk st - n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} - - (happyReduceArr Happy_Data_Array.! rule) i tk st - where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) - n -> {- nothing -} - - - happyShift new_state i tk st - where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) - where off = indexShortOffAddr happyActOffsets st - off_i = (off Happy_GHC_Exts.+# i) - check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#)) - then EQ(indexShortOffAddr happyCheck off_i, i) - else False - action - | check = indexShortOffAddr happyTable off_i - | otherwise = indexShortOffAddr happyDefActions st - - -indexShortOffAddr (HappyA# arr) off = - Happy_GHC_Exts.narrow16Int# i - where - i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) - high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) - low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) - off' = off Happy_GHC_Exts.*# 2# - - - - - -data HappyAddr = HappyA# Happy_GHC_Exts.Addr# - - - - ------------------------------------------------------------------------------ --- HappyState data type (not arrays) - - -{-# LINE 170 "templates/GenericTemplate.hs" #-} - ------------------------------------------------------------------------------ --- Shifting a token - -happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = - let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in --- trace "shifting the error token" $ - happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) - -happyShift new_state i tk st sts stk = - happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) - --- happyReduce is specialised for the common cases. - -happySpecReduce_0 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_0 nt fn j tk st@((action)) sts stk - = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) - -happySpecReduce_1 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') - = let r = fn v1 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_2 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') - = let r = fn v1 v2 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_3 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') - = let r = fn v1 v2 v3 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happyReduce k i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyReduce k nt fn j tk st sts stk - = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of - sts1@((HappyCons (st1@(action)) (_))) -> - let r = fn stk in -- it doesn't hurt to always seq here... - happyDoSeq r (happyGoto nt j tk st1 sts1 r) - -happyMonadReduce k nt fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyMonadReduce k nt fn j tk st sts stk = - case happyDrop k (HappyCons (st) (sts)) of - sts1@((HappyCons (st1@(action)) (_))) -> - let drop_stk = happyDropStk k stk in - happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) - -happyMonad2Reduce k nt fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyMonad2Reduce k nt fn j tk st sts stk = - case happyDrop k (HappyCons (st) (sts)) of - sts1@((HappyCons (st1@(action)) (_))) -> - let drop_stk = happyDropStk k stk - - off = indexShortOffAddr happyGotoOffsets st1 - off_i = (off Happy_GHC_Exts.+# nt) - new_state = indexShortOffAddr happyTable off_i - - - - in - happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) - -happyDrop 0# l = l -happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t - -happyDropStk 0# l = l -happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs - ------------------------------------------------------------------------------ --- Moving to a new state after a reduction - - -happyGoto nt j tk st = - {- nothing -} - happyDoAction j tk new_state - where off = indexShortOffAddr happyGotoOffsets st - off_i = (off Happy_GHC_Exts.+# nt) - new_state = indexShortOffAddr happyTable off_i - - - - ------------------------------------------------------------------------------ --- Error recovery (0# is the error token) - --- parse error if we are in recovery and we fail again -happyFail 0# tk old_st _ stk@(x `HappyStk` _) = - let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in --- trace "failing" $ - happyError_ i tk - -{- We don't need state discarding for our restricted implementation of - "error". In fact, it can cause some bogus parses, so I've disabled it - for now --SDM - --- discard a state -happyFail 0# tk old_st (HappyCons ((action)) (sts)) - (saved_tok `HappyStk` _ `HappyStk` stk) = --- trace ("discarding state, depth " ++ show (length stk)) $ - happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) --} - --- Enter error recovery: generate an error token, --- save the old token and carry on. -happyFail i tk (action) sts stk = --- trace "entering error recovery" $ - happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) - --- Internal happy errors: - -notHappyAtAll :: a -notHappyAtAll = error "Internal Happy error\n" - ------------------------------------------------------------------------------ --- Hack to get the typechecker to accept our action functions - - -happyTcHack :: Happy_GHC_Exts.Int# -> a -> a -happyTcHack x y = y -{-# INLINE happyTcHack #-} - - ------------------------------------------------------------------------------ --- Seq-ing. If the --strict flag is given, then Happy emits --- happySeq = happyDoSeq --- otherwise it emits --- happySeq = happyDontSeq - -happyDoSeq, happyDontSeq :: a -> b -> b -happyDoSeq a b = a `seq` b -happyDontSeq a b = b - ------------------------------------------------------------------------------ --- Don't inline any functions from the template. GHC has a nasty habit --- of deciding to inline happyGoto everywhere, which increases the size of --- the generated parser quite a bit. - - -{-# NOINLINE happyDoAction #-} -{-# NOINLINE happyTable #-} -{-# NOINLINE happyCheck #-} -{-# NOINLINE happyActOffsets #-} -{-# NOINLINE happyGotoOffsets #-} -{-# NOINLINE happyDefActions #-} - -{-# NOINLINE happyShift #-} -{-# NOINLINE happySpecReduce_0 #-} -{-# NOINLINE happySpecReduce_1 #-} -{-# NOINLINE happySpecReduce_2 #-} -{-# NOINLINE happySpecReduce_3 #-} -{-# NOINLINE happyReduce #-} -{-# NOINLINE happyMonadReduce #-} -{-# NOINLINE happyGoto #-} -{-# NOINLINE happyFail #-} - --- end of Happy Template. - diff --git a/src/Camfort/Analysis/Annotations.hs b/src/Camfort/Analysis/Annotations.hs --- a/src/Camfort/Analysis/Annotations.hs +++ b/src/Camfort/Analysis/Annotations.hs @@ -86,6 +86,11 @@ link ann (b@(F.BlStatement _ _ _ F.StDeclaration {})) = onPrev (\ ann -> ann { unitBlock = Just b }) ann link ann b = ann + linkPU ann (pu@(F.PUFunction {})) = + onPrev (\ ann -> ann { unitPU = Just pu }) ann + linkPU ann (pu@(F.PUSubroutine {})) = + onPrev (\ ann -> ann { unitPU = Just pu }) ann + linkPU ann b = ann -- Helpers for transforming the 'previous' annotation onPrev :: (a -> a) -> FA.Analysis a -> FA.Analysis a diff --git a/src/Camfort/Analysis/CommentAnnotator.hs b/src/Camfort/Analysis/CommentAnnotator.hs --- a/src/Camfort/Analysis/CommentAnnotator.hs +++ b/src/Camfort/Analysis/CommentAnnotator.hs @@ -52,22 +52,28 @@ -> ProgramFile a -> Logger (ProgramFile a) annotateComments parse pf = do - pf' <- transformBiM (writeAST parse) pf - return $ descendBi linkBlocks pf' + pf' <- transformBiM (writeASTProgramUnits parse) =<< transformBiM (writeASTBlocks parse) pf + return . descendBi linkProgramUnits $ descendBi linkBlocks pf' where - writeAST :: (Data a, ASTEmbeddable a ast) - => AnnotationParser ast -> Block a -> Logger (Block a) - writeAST parse b@(BlComment a srcSpan comment) = + writeASTBlocks :: (Data a, ASTEmbeddable a ast) => AnnotationParser ast -> Block a -> Logger (Block a) + writeASTBlocks parse b@(BlComment a srcSpan (Comment comment)) = case parse comment of Right ast -> return $ setAnnotation (annotateWithAST a ast) b Left NotAnnotation -> return b Left (ProbablyAnnotation err) -> parserWarn srcSpan err >> return b - writeAST _ b = return b + writeASTBlocks _ b = return b + writeASTProgramUnits :: (Data a, ASTEmbeddable a ast) => AnnotationParser ast -> ProgramUnit a -> Logger (ProgramUnit a) + writeASTProgramUnits parse pu@(PUComment a srcSpan (Comment comment)) = + case parse comment of + Right ast -> return $ setAnnotation (annotateWithAST a ast) pu + Left NotAnnotation -> return pu + Left (ProbablyAnnotation err) -> parserWarn srcSpan err >> return pu + writeASTProgramUnits _ pu = return pu + {-| Link all comment blocks to first non-comment block in the list. |-} linkBlocks :: (Data a, Linkable a) => [ Block a ] -> [ Block a ] linkBlocks [ ] = [ ] - --linkBlocks [ x ] = [ x ] linkBlocks blocks@(b:bs) | BlComment{} <- b = let (comments, rest) = span isComment blocks @@ -78,13 +84,29 @@ | otherwise = (descendBi linkBlocks b) : linkBlocks bs where isComment BlComment{} = True - isComment _ = False + isComment _ = False + {-| Link all comment 'program units' to first non-comment program unit in the list. |-} + linkProgramUnits :: (Data a, Linkable a) => [ ProgramUnit a ] -> [ ProgramUnit a ] + linkProgramUnits [ ] = [ ] + linkProgramUnits programUnits@(pu:pus) + | PUComment{} <- pu = + let (comments, rest) = span isComment programUnits + in if null rest -- Does the group of blocks end with comments + then comments + else let (procPUs, unprocPUs) = linkMultiplePUs comments rest + in procPUs ++ linkProgramUnits unprocPUs + | otherwise = (descendBi linkProgramUnits pu) : linkProgramUnits pus + where + isComment PUComment{} = True + isComment _ = False + class ASTEmbeddable a ast where annotateWithAST :: a -> ast -> a class Linkable a where - link :: a -> Block a -> a + link :: a -> Block a -> a + linkPU :: a -> ProgramUnit a -> a -- Given a list of comments and a list of non-comment blocks which occur -- afterward in the code, then link them together (either forward or backward) @@ -96,6 +118,10 @@ linkMultiple :: [Block a] -> [Block a] -> ([Block a], [Block a]) linkMultiple comments blocks = (map (fmap $ flip link (head blocks)) comments, blocks) + + linkMultiplePUs :: [ProgramUnit a] -> [ProgramUnit a] -> ([ProgramUnit a], [ProgramUnit a]) + linkMultiplePUs comments pus = -- trace (show (map (fmap (const ())) comments, (map (fmap (const ())) pus))) $ + (map (fmap $ flip linkPU (head pus)) comments, pus) parserWarn :: SrcSpan -> String -> Logger () parserWarn srcSpan err = tell [ "Error " ++ show srcSpan ++ ": " ++ err ] diff --git a/src/Camfort/Functionality.hs b/src/Camfort/Functionality.hs --- a/src/Camfort/Functionality.hs +++ b/src/Camfort/Functionality.hs @@ -24,49 +24,43 @@ module Camfort.Functionality where -import System.Console.GetOpt -import System.Directory -import System.Environment import System.FilePath -import System.IO +import Control.Monad -import Data.Monoid import Data.Generics.Uniplate.Operations import Data.Data -import Data.List (foldl', intercalate) -import qualified Debug.Trace as D +import Data.Binary +import Data.Text (pack, unpack, split) -import Camfort.Analysis.Annotations import Camfort.Analysis.Simple +import Camfort.Transformation.DataTypeIntroduction import Camfort.Transformation.DeadCode import Camfort.Transformation.CommonBlockElim import Camfort.Transformation.EquivalenceElim import qualified Camfort.Specification.Units as LU -import Camfort.Specification.Units.Environment import Camfort.Specification.Units.Monad -import Camfort.Helpers.Syntax import Camfort.Helpers -import Camfort.Output import Camfort.Input import qualified Language.Fortran.Parser.Any as FP -import qualified Language.Fortran.AST as F -import Language.Fortran.Analysis.Renaming - (renameAndStrip, analyseRenames, unrename, NameMap) -import Language.Fortran.Analysis(initAnalysis) +import Language.Fortran.Util.ModFile import qualified Camfort.Specification.Stencils as Stencils +import qualified Data.Map.Strict as M -- CamFort optional flags data Flag = Version | Input String | Output String | Excludes String + | IncludeDir String | Literals LiteralsOpt | StencilInferMode Stencils.InferMode | Doxygen | Ford + | FVersion String + | RefactorInPlace | Debug deriving (Data, Show, Eq) type Options = [Flag] @@ -75,8 +69,12 @@ instance Default String where defaultValue = "" getExcludes :: Options -> String -getExcludes = getOption +getExcludes opts = head ([ e | Excludes e <- universeBi opts ] ++ [""]) +-- Separates the comma-separated filenames +getExcludedFiles :: Options -> [String] +getExcludedFiles = map unpack . split (==',') . pack . getExcludes + -- * Wrappers on all of the features ast d excludes _ _ = do xs <- readParseSrcDir d excludes @@ -94,7 +92,6 @@ common inSrc excludes outSrc _ = do putStrLn $ "Refactoring common blocks in '" ++ inSrc ++ "'" isDir <- isDirectory inSrc - let dir = if isDir then inSrc ++ "/" else "" let rfun = commonElimToModules (takeDirectory outSrc ++ "/") report <- doRefactorAndCreate rfun inSrc excludes outSrc putStrLn report @@ -104,38 +101,90 @@ report <- doRefactor (mapM refactorEquivalences) inSrc excludes outSrc putStrLn report +datatypes inSrc excludes outSrc _ = do + putStrLn $ "Introducing derived data types in '" ++ inSrc ++ "'" + report <- doRefactor dataTypeIntro inSrc excludes outSrc + putStrLn report + {- Units feature -} -optsToUnitOpts :: [Flag] -> UnitOpts -optsToUnitOpts = foldl' (\ o f -> case f of Literals m -> o { uoLiterals = m } - Debug -> o { uoDebug = True } - _ -> o) unitOpts0 +optsToUnitOpts :: [Flag] -> IO UnitOpts +optsToUnitOpts = foldM (\ o f -> do + case f of + Literals m -> return $ o { uoLiterals = m } + Debug -> return $ o { uoDebug = True } + IncludeDir d -> do + -- Figure out the camfort mod files and parse them. + modFileNames <- filter isModFile `fmap` rGetDirContents' d + assocList <- forM modFileNames $ \ modFileName -> do + eResult <- decodeFileOrFail (d ++ "/" ++ modFileName) -- FIXME, directory manipulation + case eResult of + Left (offset, msg) -> do + putStrLn $ modFileName ++ ": Error at offset " ++ show offset ++ ": " ++ msg + return (modFileName, emptyModFile) + Right modFile -> do + putStrLn $ modFileName ++ ": successfully parsed precompiled file." + return (modFileName, modFile) + return $ o { uoModFiles = M.fromList assocList `M.union` uoModFiles o } + _ -> return o + ) unitOpts0 -unitsCheck inSrc excludes outSrc opt = do +getModFiles :: [Flag] -> IO ModFiles +getModFiles = foldM (\ modFiles f -> do + case f of + IncludeDir d -> do + -- Figure out the camfort mod files and parse them. + modFileNames <- filter isModFile `fmap` rGetDirContents' d + addedModFiles <- forM modFileNames $ \ modFileName -> do + eResult <- decodeFileOrFail (d ++ "/" ++ modFileName) -- FIXME, directory manipulation + case eResult of + Left (offset, msg) -> do + putStrLn $ modFileName ++ ": Error at offset " ++ show offset ++ ": " ++ msg + return emptyModFile + Right modFile -> do + putStrLn $ modFileName ++ ": successfully parsed precompiled file." + return modFile + return $ addedModFiles ++ modFiles + _ -> return modFiles + ) emptyModFiles + +isModFile = (== modFileSuffix) . fileExt + +unitsCheck inSrc excludes _ opt = do putStrLn $ "Checking units for '" ++ inSrc ++ "'" - let rfun = concatMap (LU.checkUnits (optsToUnitOpts opt)) - doAnalysisReport rfun putStrLn inSrc excludes + uo <- optsToUnitOpts opt + let rfun = concatMap (LU.checkUnits uo) + doAnalysisReportWithModFiles rfun putStrLn inSrc excludes =<< getModFiles opt -unitsInfer inSrc excludes outSrc opt = do +unitsInfer inSrc excludes _ opt = do putStrLn $ "Inferring units for '" ++ inSrc ++ "'" - let rfun = concatMap (LU.inferUnits (optsToUnitOpts opt)) - doAnalysisReport rfun putStrLn inSrc excludes + uo <- optsToUnitOpts opt + let rfun = concatMap (LU.inferUnits uo) + doAnalysisReportWithModFiles rfun putStrLn inSrc excludes =<< getModFiles opt +unitsCompile inSrc excludes outSrc opt = do + putStrLn $ "Compiling units for '" ++ inSrc ++ "'" + uo <- optsToUnitOpts opt + let rfun = LU.compileUnits uo + putStrLn =<< doCreateBinary rfun inSrc excludes outSrc =<< getModFiles opt + unitsSynth inSrc excludes outSrc opt = do putStrLn $ "Synthesising units for '" ++ inSrc ++ "'" let marker | Doxygen `elem` opt = '<' | Ford `elem` opt = '!' | otherwise = '=' + uo <- optsToUnitOpts opt let rfun = - mapM (LU.synthesiseUnits (optsToUnitOpts opt) marker) - report <- doRefactor rfun inSrc excludes outSrc + mapM (LU.synthesiseUnits uo marker) + report <- doRefactorWithModFiles rfun inSrc excludes outSrc =<< getModFiles opt putStrLn report -unitsCriticals inSrc excludes outSrc opt = do +unitsCriticals inSrc excludes _ opt = do putStrLn $ "Suggesting variables to annotate with unit specifications in '" ++ inSrc ++ "'" - let rfun = mapM (LU.inferCriticalVariables (optsToUnitOpts opt)) - doAnalysisReport rfun (putStrLn . fst) inSrc excludes + uo <- optsToUnitOpts opt + let rfun = mapM (LU.inferCriticalVariables uo) + doAnalysisReportWithModFiles rfun (putStrLn . fst) inSrc excludes =<< getModFiles opt {- Stencils feature -} stencilsCheck inSrc excludes _ _ = do diff --git a/src/Camfort/Helpers.hs b/src/Camfort/Helpers.hs --- a/src/Camfort/Helpers.hs +++ b/src/Camfort/Helpers.hs @@ -17,6 +17,7 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-} module Camfort.Helpers where @@ -24,8 +25,8 @@ import GHC.Generics import Data.Generics.Zipper import Data.Generics.Aliases -import Data.Generics.Str import Data.Generics.Uniplate.Operations +import qualified Data.Generics.Str as Str import Data.Data import Data.Maybe import Data.Monoid @@ -179,3 +180,32 @@ zfmap :: Data a => (a -> a) -> Zipper (d a) -> Zipper (d a) zfmap f x = zeverywhere (mkT f) x + +-- Data-generic generic descend but processes children in reverse order +-- (good for backwards analysis) +data Reverse f a = Reverse { unwrapReverse :: f a } + +instance Functor (Reverse Str.Str) where + fmap f (Reverse s) = Reverse (fmap f s) + +instance Foldable (Reverse Str.Str) where + foldMap f (Reverse x) = foldMap f x + +instance Traversable (Reverse Str.Str) where + traverse f (Reverse Str.Zero) = pure $ Reverse Str.Zero + traverse f (Reverse (Str.One x)) = (Reverse . Str.One) <$> f x + traverse f (Reverse (Str.Two x y)) = (\y x -> Reverse $ Str.Two x y) + <$> (fmap unwrapReverse . traverse f . Reverse $ y) + <*> (fmap unwrapReverse . traverse f . Reverse $ x) + + +-- Custom version of descend that process tree in reverse order +descendReverseM :: (Data on, Monad m, Uniplate on) => (on -> m on) -> on -> m on +descendReverseM f x = + liftM generate . fmap unwrapReverse . traverse f . Reverse $ current + where (current, generate) = uniplate x + +descendBiReverseM :: (Data from, Data to, Monad m, Biplate from to) => (to -> m to) -> from -> m from +descendBiReverseM f x = + liftM generate . fmap unwrapReverse . traverse f . Reverse $ current + where (current, generate) = biplate x diff --git a/src/Camfort/Helpers/Vec.hs b/src/Camfort/Helpers/Vec.hs --- a/src/Camfort/Helpers/Vec.hs +++ b/src/Camfort/Helpers/Vec.hs @@ -23,11 +23,16 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} module Camfort.Helpers.Vec where -import Data.Data +import Prelude hiding (length, zipWith, take, drop, (!!)) +import Data.Proxy + +import Unsafe.Coerce + data Nat = Z | S Nat -- Indexed natural number type @@ -49,6 +54,7 @@ class IsNatural (n :: Nat) where fromNat :: Proxy n -> Int + instance IsNatural Z where fromNat Proxy = 0 instance IsNatural n => IsNatural (S n) where @@ -59,41 +65,123 @@ Nil :: Vec Z a Cons :: a -> Vec n a -> Vec (S n) a -lengthV :: Vec n a -> Int -lengthV Nil = 0 -lengthV (Cons x xs) = 1 + lengthV xs +length :: Vec n a -> Int +length Nil = 0 +length (Cons x xs) = 1 + length xs -vmap :: (a -> b) -> Vec n a -> Vec n b -vmap f Nil = Nil -vmap f (Cons x xs) = Cons (f x) (vmap f xs) +lengthN :: Vec n a -> Natural n +lengthN Nil = Zero +lengthN (Cons x xs) = Succ $ lengthN xs instance Functor (Vec n) where - fmap = vmap + fmap f Nil = Nil + fmap f (Cons x xs) = Cons (f x) (fmap f xs) + deriving instance Eq a => Eq (Vec n a) + instance Ord a => Ord (Vec n a) where Nil <= _ = True (Cons x xs) <= (Cons y ys) | xs == ys = x <= y | otherwise = xs <= ys instance Show a => Show (Vec n a) where - show = showV + show xs = "<" ++ showV xs ++ ">" + where + showV :: forall n a . Show a => Vec n a -> String + showV Nil = "" + showV (Cons x Nil) = show x + showV (Cons x xs) = show x ++ "," ++ showV xs -showV :: Show a => Vec n a -> String -showV xs = "<" ++ showV' xs ++ ">" +instance Foldable (Vec n) where + foldr _ acc Nil = acc + foldr f acc (Cons x xs) = foldr f (f x acc) xs + +zipWith :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c +zipWith f Nil Nil = Nil +zipWith f (Cons x xs) (Cons y ys) = Cons (f x y) (zipWith f xs ys) + +zip :: Vec n a -> Vec n b -> Vec n (a,b) +zip = zipWith (,) + +findIndex :: (a -> Bool) -> Vec n a -> Maybe Int +findIndex = go 0 where - showV' :: Show a => Vec n a -> String - showV' Nil = "" - showV' (Cons x Nil) = show x - showV' (Cons x xs) = show x ++ "," ++ showV' xs + go :: Int -> (a -> Bool) -> Vec n a -> Maybe Int + go _ _ Nil = Nothing + go acc p (Cons x xs) + | p x = Just acc + | otherwise = go (acc + 1) p xs -type family Max (n :: Nat) (m :: Nat) :: Nat where - Max Z Z = Z - Max Z m = m - Max m Z = m - Max (S n) (S m) = S (Max n m) +(!!) :: Vec n a -> Int -> a +Cons x v' !! 0 = x +Cons _ v' !! n = v' !! (n - 1) -zipVec :: Vec m Int -> Vec n Int -> (Vec (Max n m) Int, Vec (Max n m) Int) -zipVec Nil Nil = (Nil, Nil) -zipVec Nil xs = (fmap (const 0) xs, xs) -zipVec xs Nil = (xs, fmap (const 0) xs) -zipVec (Cons x xs) (Cons y ys) - = (Cons x xs', Cons y ys') where (xs', ys') = zipVec xs ys +replace :: Int -> a -> Vec n a -> Vec n a +replace 0 a (Cons x xs) = Cons a xs +replace n a (Cons x xs) = Cons x (replace (n-1) a xs) +replace _ _ Nil = error "Found asymmetry is beyond the limits." + +-- Equality type +data EqT a b where + ReflEq :: EqT a a + +data ExistsEqT t n where + ExistsEqT :: EqT (t m) n -> ExistsEqT t n + +-- Lists existentially quanitify over a vector's size : Exists n . Vec n a +data VecBox a where + VecBox :: Vec n a -> VecBox a + +fromList :: [a] -> VecBox a +fromList = foldr (\x (VecBox xs) -> VecBox (Cons x xs)) (VecBox Nil) + +toList :: Vec n a -> [ a ] +toList Nil = [ ] +toList (Cons x xs) = x : toList xs + +-- | Apply length preserving list operation. +applyListOp :: ([ a ] -> [ a ]) -> Vec n a -> Vec n a +applyListOp f v = + case fromList . f . toList $ v of + VecBox v' -> + case proveEqSize v v' of + Just ReflEq -> v' + Nothing -> error "List operation was not length preserving." + +proveEqSize :: Vec n a -> Vec m b -> Maybe (EqT m n) +proveEqSize Nil Nil = return ReflEq +proveEqSize (Cons _ xs) (Cons _ ys) = do + ReflEq <- proveEqSize xs ys + return ReflEq +proveEqSize _ _ = Nothing + +proveNonEmpty :: Vec n a -> Maybe (ExistsEqT S n) +proveNonEmpty v = + case v of + Nil -> Nothing + (Cons x xs) -> Just $ ExistsEqT ReflEq + +hasSize :: Vec m a -> Natural n -> Maybe (EqT m n) +hasSize Nil Zero = return ReflEq +hasSize (Cons _ xs) (Succ n) = do + ReflEq <- xs `hasSize` n + return ReflEq +hasSize _ _ = Nothing + +{- Vector list repreentation where the size 'n' is existential quantified -} +data VecList a where VL :: [Vec n a] -> VecList a + +-- pre-condition: the input is a 'rectangular' list of lists (i.e. all internal +-- lists have the same size) +fromLists :: forall a . [[a]] -> VecList a +fromLists [] = VL ([] :: [Vec Z a]) +fromLists (xs:xss) = consList (fromList xs) (fromLists xss) + where + consList :: VecBox a -> VecList a -> VecList a + consList (VecBox vec) (VL []) = VL [vec] + consList (VecBox vec) (VL xs) = -- Force the pre-condition equality + case preCondition vec xs of + ReflEq -> VL (vec : xs) + where -- At the moment the pre-condition is 'assumed', and therefore + -- force used unsafeCoerce: TODO, rewrite + preCondition :: forall n n1 a . Vec n a -> [Vec n1 a] -> EqT n n1 + preCondition xs x = unsafeCoerce ReflEq diff --git a/src/Camfort/Input.hs b/src/Camfort/Input.hs --- a/src/Camfort/Input.hs +++ b/src/Camfort/Input.hs @@ -14,7 +14,7 @@ limitations under the License. -} -{- +{-2 Handles input of code base (files and directories) and passing them into the core functionality @@ -32,9 +32,12 @@ import qualified Language.Fortran.Parser.Any as FP import qualified Language.Fortran.AST as F +import Language.Fortran.Util.ModFile import qualified Data.ByteString.Char8 as B import Data.Data +import Data.Char (toUpper) +import Data.Maybe import Data.Generics.Uniplate.Operations import Data.List (foldl', nub, (\\), elemIndices, intercalate) import Data.Monoid @@ -92,6 +95,23 @@ sFun report ---- +doAnalysisReportWithModFiles :: ([(Filename, F.ProgramFile A)] -> r) + -> (r -> IO out) + -> FileOrDir + -> [Filename] + -> ModFiles + -> IO out +doAnalysisReportWithModFiles rFun sFun inSrc excludes mods = do + if excludes /= [] && excludes /= [""] + then putStrLn $ "Excluding " ++ intercalate "," excludes + ++ " from " ++ inSrc ++ "/" + else return () + ps <- readParseSrcDirWithModFiles inSrc excludes mods +---- + let report = rFun (map (\(f, inp, ast) -> (f, ast)) ps) + sFun report +---- + {-| Performs a refactoring provided by its first parameter, on the directory of the second, excluding files listed by third, output to the directory specified by the fourth parameter -} @@ -112,6 +132,23 @@ outputFiles inSrc outSrc outputs return report +doRefactorWithModFiles :: ([(Filename, F.ProgramFile A)] -> (String, [(Filename, F.ProgramFile A)])) + -> FileOrDir + -> [Filename] + -> FileOrDir + -> ModFiles + -> IO String +doRefactorWithModFiles rFun inSrc excludes outSrc mods = do + if excludes /= [] && excludes /= [""] + then putStrLn $ "Excluding " ++ intercalate "," excludes + ++ " from " ++ inSrc ++ "/" + else return () + ps <- readParseSrcDirWithModFiles inSrc excludes mods + let (report, ps') = rFun (map (\(f, inp, ast) -> (f, ast)) ps) + let outputs = reassociateSourceText ps ps' + outputFiles inSrc outSrc outputs + return report + -- For refactorings which create some files too -- i.e., for refactoring functions that return a -- pair of lists of filename/program file pairs is @@ -132,6 +169,40 @@ outputFiles inSrc outSrc outputs' return report +-- For refactorings which create some files too +-- i.e., for refactoring functions that return a +-- pair of lists of filename/program file pairs is +type FileProgram = (Filename, F.ProgramFile A) +doRefactorAndCreateBinary :: ([FileProgram] -> (String, [FileProgram], [(Filename, B.ByteString)])) + -> FileOrDir -> [Filename] -> FileOrDir -> IO String +doRefactorAndCreateBinary rFun inSrc excludes outSrc = do + if excludes /= [] && excludes /= [""] + then putStrLn $ "Excluding " ++ intercalate "," excludes + ++ " from " ++ inSrc ++ "/" + else return () + ps <- readParseSrcDir inSrc excludes + let (report, ps', bins) = rFun (map (\ (f, inp, ast) -> (f, ast)) ps) + let outputs = reassociateSourceText ps ps' + outputFiles inSrc outSrc outputs + outputFiles inSrc outSrc bins + return report + +doCreateBinary :: ([FileProgram] -> (String, [(Filename, B.ByteString)])) + -> FileOrDir + -> [Filename] + -> FileOrDir + -> ModFiles + -> IO String +doCreateBinary rFun inSrc excludes outSrc mods = do + if excludes /= [] && excludes /= [""] + then putStrLn $ "Excluding " ++ intercalate "," excludes + ++ " from " ++ inSrc ++ "/" + else return () + ps <- readParseSrcDirWithModFiles inSrc excludes mods + let (report, bins) = rFun (map (\ (f, inp, ast) -> (f, ast)) ps) + outputFiles inSrc outSrc bins + return report + reassociateSourceText :: [(Filename, SourceText, a)] -> [(Filename, F.ProgramFile Annotation)] -> [(Filename, SourceText, F.ProgramFile Annotation)] @@ -155,14 +226,46 @@ let excludes' = excludes ++ map (\x -> inp ++ "/" ++ x) excludes return $ (map (\y -> inp ++ "/" ++ y) files) \\ excludes' else return [inp] - mapM readParseSrcFile files + mapMaybeM readParseSrcFile files +mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] +mapMaybeM f = fmap catMaybes . (mapM f) + +readParseSrcDirWithModFiles :: FileOrDir + -> [Filename] + -> ModFiles + -> IO [(Filename, SourceText, F.ProgramFile A)] +readParseSrcDirWithModFiles inp excludes mods = do + isdir <- isDirectory inp + files <- if isdir + then do + files <- rGetDirContents inp + -- Compute alternate list of excludes with the + -- the directory appended + let excludes' = excludes ++ map (\x -> inp ++ "/" ++ x) excludes + return $ (map (\y -> inp ++ "/" ++ y) files) \\ excludes' + else return [inp] + mapMaybeM (readParseSrcFileWithModFiles mods) files + {-| Read a specific file, and parse it -} -readParseSrcFile :: Filename -> IO (Filename, SourceText, F.ProgramFile A) +readParseSrcFile :: Filename + -> IO (Maybe (Filename, SourceText, F.ProgramFile A)) readParseSrcFile f = do inp <- flexReadFile f - let ast = FP.fortranParser inp f - return (f, inp, fmap (const unitAnnotation) ast) + let result = FP.fortranParserWithModFiles [] inp f + case result of + Right ast -> return $ Just (f, inp, fmap (const unitAnnotation) ast) + Left error -> (putStrLn $ show error) >> return Nothing + +readParseSrcFileWithModFiles :: ModFiles + -> Filename + -> IO (Maybe (Filename, SourceText, F.ProgramFile A)) +readParseSrcFileWithModFiles mods f = do + inp <- flexReadFile f + let result = FP.fortranParserWithModFiles mods inp f + case result of + Right ast -> return $ Just (f, inp, fmap (const unitAnnotation) ast) + Left error -> (putStrLn $ show error) >> return Nothing ---- rGetDirContents :: FileOrDir -> IO [String] @@ -181,8 +284,23 @@ then return (x : xs') else return xs' +-- A version that lists all files, not just Fortran ones +rGetDirContents' :: FileOrDir -> IO [String] +rGetDirContents' d = do + ds <- getDirectoryContents d + fmap concat . mapM f $ ds \\ [".", ".."] -- remove '.' and '..' entries + where + f x = do + g <- doesDirectoryExist (d ++ "/" ++ x) + if g then do + x' <- rGetDirContents (d ++ "/" ++ x) + return $ map (\ y -> x ++ "/" ++ y) x' + else return [x] + {-| predicate on which fileextensions are Fortran files -} -isFortran x = fileExt x `elem` [".f", ".f90", ".f77", ".cmn", ".inc"] +isFortran x = fileExt x `elem` (exts ++ extsUpper) + where exts = [".f", ".f90", ".f77", ".cmn", ".inc"] + extsUpper = map (map toUpper) exts {-| extract a filename's extension -} fileExt x = let ix = elemIndices '.' x diff --git a/src/Camfort/Output.hs b/src/Camfort/Output.hs --- a/src/Camfort/Output.hs +++ b/src/Camfort/Output.hs @@ -105,11 +105,11 @@ instance OutputFiles (Filename, SourceText) where mkOutputText _ (_, output) = output outputFile (f, _) = f - isNewFile (_, inp) = B.null inp + isNewFile _ = True -- When there is a file to be reprinted (for refactoring) instance OutputFiles (Filename, SourceText, F.ProgramFile Annotation) where - mkOutputText f' (f, input, ast@(F.ProgramFile (F.MetaInfo version) _ _)) = + mkOutputText f' (f, input, ast@(F.ProgramFile (F.MetaInfo version _) _)) = -- If we are create a file, call the pretty printer directly if B.null input then B.pack $ PP.pprintAndRender version ast (Just 0) @@ -125,19 +125,48 @@ refactoring :: Typeable a => FPM.FortranVersion -> a -> SourceText -> StateT FU.Position Identity (SourceText, Bool) -refactoring v z inp = catchAll inp `extQ` refactorings inp $ z +refactoring v z inp = ((catchAll inp `extQ` refactoringsForProgramUnits v inp) `extQ` refactoringsForBlocks v inp) $ z where catchAll :: SourceText -> a -> StateT FU.Position Identity (SourceText, Bool) catchAll _ _ = return (B.empty, False) - refactorings inp z = - mapStateT (\n -> Identity $ n `evalState` 0) (refactorBlocks v inp z) +refactoringsForProgramUnits :: FPM.FortranVersion + -> SourceText + -> F.ProgramUnit Annotation + -> StateT FU.Position Identity (SourceText, Bool) +refactoringsForProgramUnits v inp z = + mapStateT (\n -> Identity $ n `evalState` 0) (refactorProgramUnits v inp z) + +refactorProgramUnits :: FPM.FortranVersion + -> SourceText + -> F.ProgramUnit Annotation + -> StateT FU.Position (State Int) (SourceText, Bool) +-- Output comments +refactorProgramUnits v inp e@(F.PUComment ann span (F.Comment comment)) = do + cursor <- get + if pRefactored ann + then let (FU.SrcSpan lb ub) = span + lb' = leftOne lb + (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) + where leftOne (FU.Position f c l) = FU.Position f (c-1) (l-1) +refactorProgramUnits _ _ _ = return (B.empty, False) + +refactoringsForBlocks :: FPM.FortranVersion + -> SourceText + -> F.Block Annotation + -> StateT FU.Position Identity (SourceText, Bool) +refactoringsForBlocks v inp z = + mapStateT (\n -> Identity $ n `evalState` 0) (refactorBlocks v inp z) + refactorBlocks :: FPM.FortranVersion -> SourceText -> F.Block Annotation -> StateT FU.Position (State Int) (SourceText, Bool) -- Output comments -refactorBlocks v inp e@(F.BlComment ann span comment) = do +refactorBlocks v inp e@(F.BlComment ann span (F.Comment comment)) = do cursor <- get if pRefactored ann then let (FU.SrcSpan lb ub) = span 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 @@ -17,31 +17,18 @@ module Camfort.Specification.Stencils (InferMode, infer, check, synth) where -import Control.Monad.State.Lazy -import Control.Monad.Writer hiding (Product) - -import qualified Camfort.Specification.Stencils.Grammar as Gram import Camfort.Specification.Stencils.CheckFrontend hiding (LogLine) import Camfort.Specification.Stencils.InferenceFrontend -import Camfort.Specification.Stencils.Syntax import Camfort.Specification.Stencils.Synthesis -import Camfort.Analysis.CommentAnnotator import Camfort.Analysis.Annotations -- These two are redefined here for ForPar ASTs -import Camfort.Helpers hiding (lineCol, spanLineCol) +import Camfort.Helpers 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.Analysis.BBlocks as FAB -import qualified Language.Fortran.Analysis.DataFlow as FAD -import qualified Language.Fortran.Util.Position as FU -import Data.Generics.Uniplate.Operations -import Data.Data -import qualified Data.Map as M -import Data.Maybe import Data.List -------------------------------------------------- @@ -84,7 +71,7 @@ synthPF :: InferMode -> Char -> Filename -> F.ProgramFile Annotation -> (String, F.ProgramFile Annotation) -synthPF mode marker filename pf = +synthPF _ marker _ pf = -- Append filename to any outputs ("", fmap FA.prevAnnotation pf'') where diff --git a/src/Camfort/Specification/Stencils/Annotation.hs b/src/Camfort/Specification/Stencils/Annotation.hs --- a/src/Camfort/Specification/Stencils/Annotation.hs +++ b/src/Camfort/Specification/Stencils/Annotation.hs @@ -21,12 +21,10 @@ import Camfort.Analysis.Annotations import Camfort.Analysis.CommentAnnotator -import Camfort.Specification.Stencils.Syntax import qualified Camfort.Specification.Stencils.Grammar as Gram import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA -import Debug.Trace {- *** Routines for associating annotations to ASTs -} @@ -41,3 +39,4 @@ link ann (b@(F.BlStatement _ _ _ (F.StExpressionAssign {}))) = onPrev (\ann -> ann { stencilBlock = Just b }) ann link ann b = ann + linkPU ann pu = ann diff --git a/src/Camfort/Specification/Stencils/CheckBackend.hs b/src/Camfort/Specification/Stencils/CheckBackend.hs --- a/src/Camfort/Specification/Stencils/CheckBackend.hs +++ b/src/Camfort/Specification/Stencils/CheckBackend.hs @@ -14,44 +14,16 @@ limitations under the License. -} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ImplicitParams #-} module Camfort.Specification.Stencils.CheckBackend where -import Data.Data -import Data.Maybe -import Data.List -import Data.Generics.Uniplate.Operations -import Control.Monad.State.Lazy -import Control.Monad.Reader -import Control.Monad.Writer hiding (Product,Sum) - -import Camfort.Specification.Stencils.InferenceBackend import Camfort.Specification.Stencils.Syntax import Camfort.Specification.Stencils.Model import qualified Camfort.Specification.Stencils.Grammar as SYN -import Camfort.Analysis.Annotations -import Camfort.Helpers.Vec --- These two are redefined here for ForPar ASTs -import Camfort.Helpers hiding (lineCol, spanLineCol) - -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.Analysis.BBlocks as FAB -import qualified Language.Fortran.Analysis.DataFlow as FAD - -import Language.Fortran.Util.Position -import qualified Data.Map as M -import Data.Set hiding (map) - type ErrorMsg = String -- Class for functions converting from Grammar parse @@ -81,8 +53,8 @@ Just SYN.AtLeast -> Bound (Just s') Nothing Nothing -> Exact s' where - addLinearity Linear appr = Single appr - addLinearity NonLinear appr = Multiple appr + addLinearity Linear appr = Once appr + addLinearity NonLinear appr = Mult appr -- Convert region definitions into the DNF-form used internally instance SynToAst SYN.Region RegionSum where 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 @@ -14,9 +14,9 @@ limitations under the License. -} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} module Camfort.Specification.Stencils.CheckFrontend where @@ -25,17 +25,15 @@ import Control.Monad.State.Strict import Control.Monad.Writer.Strict hiding (Product) +import qualified Camfort.Helpers.Vec as V import Camfort.Specification.Stencils.CheckBackend +import qualified Camfort.Specification.Stencils.Consistency as C import qualified Camfort.Specification.Stencils.Grammar as Gram -import Camfort.Specification.Stencils.Annotation import Camfort.Specification.Stencils.Model import Camfort.Specification.Stencils.InferenceFrontend hiding (LogLine) -import Camfort.Specification.Stencils.InferenceBackend -import Camfort.Specification.Stencils.Synthesis import Camfort.Specification.Stencils.Syntax import Camfort.Analysis.Annotations import Camfort.Analysis.CommentAnnotator -import Camfort.Helpers import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA @@ -46,7 +44,9 @@ import qualified Data.Map as M import Data.Maybe -import Data.List +import Algebra.Lattice (joins1) +import Data.Int +import qualified Data.Set as S -- Entry point stencilChecking :: FAR.NameMap -> F.ProgramFile (FA.Analysis A) -> [String] @@ -76,7 +76,7 @@ let ?nameMap = nameMap in descendBiM perProgramUnitCheck pf' -- Format output - let a@(_, output) = evalState (runWriterT results) (([], Nothing), ivmap) + let (_, output) = evalState (runWriterT results) (([], Nothing), ivmap) tell $ pprint output type LogLine = (FU.SrcSpan, String) @@ -109,16 +109,42 @@ checkOffsetsAgainstSpec :: [(Variable, Multiplicity [[Int]])] -> [(Variable, Specification)] -> Bool -checkOffsetsAgainstSpec offsetMaps = - all (\(var1, Specification mult)-> - all (\(var2, offsets) -> - var1 /= var2 || noAllInfinity offsets `consistent` mult) offsetMaps) - where - noAllInfinity (Single a) = - Single $ filter (not . all (== absoluteRep)) a - noAllInfinity (Multiple a) = - Multiple $ filter (not . all (== absoluteRep)) a +checkOffsetsAgainstSpec offsetMaps specMaps = + flip all specToVecList $ + \case + (spec, Once (V.VL vs)) -> spec `C.consistent` (Once . toUNF) vs == C.Consistent + (spec, Mult (V.VL vs)) -> spec `C.consistent` (Mult . toUNF) vs == C.Consistent + where + toUNF :: [ V.Vec n Int64 ] -> UnionNF n Offsets + toUNF = joins1 . map (return . fmap intToSubscript) + -- This function generates the special offsets subspace, subscript, + -- that either had one element or is the whole set. + intToSubscript :: Int64 -> Offsets + intToSubscript i + | fromIntegral i == absoluteRep = SetOfIntegers + | otherwise = Offsets . S.singleton $ i + + -- Convert list of list of indices into vectors and wrap them around + -- existential so that we don't have to prove they are all of the same + -- size. + specToVecList :: [ (Specification, Multiplicity (V.VecList Int64)) ] + specToVecList = map (second (fmap V.fromLists)) specToIxs + + specToIxs :: [ (Specification, Multiplicity [ [ Int64 ] ]) ] + specToIxs = pairWithFst specMaps (map (second toInt64) offsetMaps) + + toInt64 :: Multiplicity [ [ Int ] ] -> Multiplicity [ [ Int64 ] ] + toInt64 = fmap (map (map fromIntegral)) + + -- Given two maps for each key in the first map generate a set of + -- tuples matching the (val,val') where val and val' are corresponding + -- values from each set. + pairWithFst :: Eq a => [ (a, b) ] -> [ (a, c) ] -> [ (b, c) ] + pairWithFst [] _ = [] + pairWithFst ((key, val):xs) ys = + map ((val,) . snd) (filter ((key ==) . fst) ys) ++ pairWithFst xs ys + -- Go into the program units first and record the module name when -- entering into a module perProgramUnitCheck :: (?nameMap :: FAR.NameMap, ?flowsGraph :: FAD.FlowsGraph A) @@ -139,7 +165,7 @@ -- Comment contains a specification and an Associated block (Just (Right (Right specDecls)), Just block) -> case block of - s@(F.BlStatement ann span' _ (F.StExpressionAssign _ _ lhs rhs)) -> + s@(F.BlStatement _ span' _ (F.StExpressionAssign _ _ lhs _)) -> case isArraySubscript lhs of Just subs -> do -- Create list of relative indices @@ -151,8 +177,8 @@ let relOffsets = correctNames . fst . runWriter $ genOffsets ivmap lhsN [s] let multOffsets = map (\relOffset -> case relOffset of - (var, (True, offsets)) -> (var, Multiple offsets) - (var, (False, offsets)) -> (var, Single offsets)) relOffsets + (var, (True, offsets)) -> (var, Mult offsets) + (var, (False, offsets)) -> (var, Once offsets)) relOffsets let expandedDecls = concatMap (\(vars,spec) -> map (flip (,) spec) vars) specDecls -- Model and compare the current and specified stencil specs @@ -160,7 +186,7 @@ then tell [ (span, "Correct.") ] else do let correctNames2 = map (first (map realName)) - let inferred = correctNames2 . fst . runWriter $ genSpecifications ivmap lhsN [s] + let inferred = correctNames2 . fst . fst . runWriter $ genSpecifications ivmap lhsN [s] let sp = replicate 8 ' ' tell [ (span, "Not well specified.\n" @@ -172,13 +198,12 @@ return b' Nothing -> return b' - (F.BlDo ann span _ _ _ mDoSpec body _) -> - -- Stub, maybe collect stencils inside 'do' block - return b' + -- Stub, maybe collect stencils inside 'do' block + F.BlDo{} -> return b' _ -> return b' _ -> return b' -perBlockCheck b@(F.BlDo ann span _ _ _ mDoSpec body _) = do +perBlockCheck b@(F.BlDo _ _ _ _ _ _ body _) = do -- descend into the body of the do-statement mapM_ (descendBiM perBlockCheck) body -- Remove any induction variable from the state diff --git a/src/Camfort/Specification/Stencils/Consistency.hs b/src/Camfort/Specification/Stencils/Consistency.hs new file mode 100644 --- /dev/null +++ b/src/Camfort/Specification/Stencils/Consistency.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Camfort.Specification.Stencils.Consistency ( consistent + , ConsistencyResult(..) ) where + +import qualified Camfort.Helpers.Vec as V +import Camfort.Specification.Stencils.DenotationalSemantics +import Camfort.Specification.Stencils.Model +import Camfort.Specification.Stencils.Syntax + +data ConsistencyResult = + Consistent + | Inconsistent String + deriving (Eq, Show) + +-- | This function checks multiplicity consistency and then delegates the +-- spatial consistency to |consistent'| function. +consistent :: forall n . + Specification + -> Multiplicity (UnionNF n Offsets) + -> ConsistencyResult +consistent (Specification mult) observedIxs = + -- First do the linearity check + case (specModel, observedIxs) of + (Mult a, Mult b) -> a `consistent'` b + (Once a, Once b) -> a `consistent'` b + (Once _, Mult _) ->Inconsistent + "Specification is readOnce, but there are repeated indices." + (Mult _, Once _) -> Inconsistent + "Specification lacks readOnce, but the indices are inuque." + where + specModel :: Multiplicity (Approximation (UnionNF n (Interval Standard))) + specModel = + case sequence $ (sequence . fmap (regionsToIntervals nOfDims)) <$> mult of + Right model -> model + Left msg -> error msg + + nOfDims :: V.Natural n + nOfDims = vecLength . peel $ observedIxs + +-- | This is the actual consistency check using set comparison supplied in +-- the model. +consistent' :: Approximation (UnionNF n (Interval Standard)) + -> UnionNF n Offsets + -> ConsistencyResult +consistent' (Exact unf) ixs = + case unfCompare unf ixs of + EQ -> Consistent + LT -> + Inconsistent "The specification covers a smaller area than the indices." + GT -> + Inconsistent "The specification covers a larger area than the indices." +consistent' (Bound (Just unf) Nothing) ixs = + case unfCompare unf ixs of + EQ -> Consistent + LT -> Consistent + GT -> Inconsistent $ + "There are indices covered by the lower bound specification, but " ++ + "could not observed in the indices." +consistent' (Bound Nothing (Just unf)) ixs = + case unfCompare unf ixs of + EQ -> Consistent + GT -> Consistent + LT -> Inconsistent + "There are indices outside the upper bound specification." +consistent' (Bound lb ub) ixs = + case (cLower, cUpper) of + (Consistent, Consistent) -> Consistent + (Consistent, inconsistent) -> inconsistent + (inconsistent, Consistent) -> inconsistent + (Inconsistent{}, Inconsistent{}) -> Inconsistent + "Neither the lower nor ther upper bound conform with the indices." + where + cLower = Bound lb Nothing `consistent'` ixs + cUpper = Bound Nothing ub `consistent'` ixs diff --git a/src/Camfort/Specification/Stencils/DenotationalSemantics.hs b/src/Camfort/Specification/Stencils/DenotationalSemantics.hs new file mode 100644 --- /dev/null +++ b/src/Camfort/Specification/Stencils/DenotationalSemantics.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds #-} + +module Camfort.Specification.Stencils.DenotationalSemantics ( intervalsToRegions + , regionsToIntervals ) where + +import Algebra.Lattice +import qualified Data.List.NonEmpty as NE +import qualified Data.Semigroup as SG + +import qualified Camfort.Helpers.Vec as V +import Camfort.Specification.Stencils.Model +import Camfort.Specification.Stencils.Syntax + +-- preconditions: +-- 1. If finite interval, all have "lower bound <= 0 <= upper bound"; +-- 2. No dimensionality of 0; (insured by dep. type); +-- 3. All unioned interval lists are of equal length (insured by dep. type). +intervalsToRegions :: UnionNF (V.S n) (Interval Standard) + -> Either String Spatial +intervalsToRegions as = do + sums <- mapM toProd + . maximas -- Final subsumption optimisation + . NE.toList + . SG.sconcat + . fmap asymmetryElim + $ as + return . Spatial . Sum $ sums + where + asymmetryElim :: V.Vec n (Interval a) -> UnionNF n (Interval a) + asymmetryElim ints + | Just ix <- findAsymmetry ints = + case ints V.!! ix of + IntervHoled m n p -> + asymmetryElim (V.replace ix (IntervHoled m 0 p) ints) SG.<> + asymmetryElim (V.replace ix (IntervHoled 0 n p) ints) + | otherwise = return ints + findAsymmetry = + V.findIndex $ \case + (IntervHoled m n _) -> m /= 0 && n /= 0 && m /= -n + _ -> False + + toProd :: V.Vec n (Interval Standard) -> Either String RegionProd + toProd ints = + fmap Product $ mapM convert + . filter (isNonInf . fst) + $ zip (V.toList ints) [0..] + + isNonInf :: Interval Standard -> Bool + isNonInf IntervInfinite = False + isNonInf _ = True + + convert :: (Interval Standard, Int) -> Either String Region + convert (IntervHoled 0 0 False, _) = + Left "Empty set cannot be realised as a region." + convert (IntervHoled 0 0 True, ix) = return $ Centered 0 (ix + 1) True + convert (IntervHoled 0 m p, ix) = return $ Forward (fromIntegral m) (ix + 1) p + convert (IntervHoled m 0 p, ix) = return $ Backward (fromIntegral $ -m) (ix + 1) p + convert (IntervHoled m n p, ix) + | m == -n = return $ Centered (fromIntegral n) (ix + 1) p + | otherwise = Left $ + "Impossible: the lower bound is not negation of upper bound. " ++ + "Should have been separated before." + convert _ = Left "Infinite interval cannot be realised as a region." + +regionsToIntervals :: forall n . + V.Natural n + -> Spatial + -> Either String (UnionNF n (Interval Standard)) +regionsToIntervals nOfDims (Spatial (Sum prods)) + | null prods = Left "Empty region sum" + | otherwise = + fmap SG.sconcat . sequence . fmap convert . NE.fromList $ prods + where + convert :: RegionProd -> Either String (UnionNF n (Interval Standard)) + convert (Product rs) + | null rs = Left "Empty region product" + | otherwise = Right $ meets1 . map convert' $ rs + + convert' r = return $ proto nOfDims $ + case r of + Forward dep dim p -> (dim-1, IntervHoled 0 (fromIntegral dep) p) + Backward dep dim p -> (dim-1, IntervHoled (- fromIntegral dep) 0 p) + Centered dep dim p -> (dim-1, IntervHoled (- fromIntegral dep) (fromIntegral dep) p) + + proto :: forall n . + V.Natural n + -> (Int, Interval Standard) + -> V.Vec n (Interval Standard) + proto V.Zero _ = V.Nil + proto (V.Succ n) (i, interv) = V.Cons + (if i == 0 then interv else IntervInfinite) + (proto n (i-1, interv)) diff --git a/src/Camfort/Specification/Stencils/Grammar.hs b/src/Camfort/Specification/Stencils/Grammar.hs deleted file mode 100644 --- a/src/Camfort/Specification/Stencils/Grammar.hs +++ /dev/null @@ -1,1275 +0,0 @@ -{-# OPTIONS_GHC -w #-} --- -*- Mode: Haskell -*- -{-# LANGUAGE DeriveDataTypeable, PatternGuards #-} -module Camfort.Specification.Stencils.Grammar -( specParser, Specification(..), Region(..), Spec(..), Mod(..), lexer ) where - -import Data.Char (isLetter, isNumber, isAlphaNum, toLower, isAlpha, isSpace) -import Data.List (intersect, sort, isPrefixOf) -import Data.Data - -import Debug.Trace - -import Camfort.Analysis.CommentAnnotator -import Camfort.Specification.Stencils.Syntax (showL) -import Control.Applicative(Applicative(..)) -import Control.Monad (ap) - --- parser produced by Happy Version 1.19.5 - -data HappyAbsSyn - = HappyTerminal (Token) - | HappyErrorToken Int - | HappyAbsSyn4 (Specification) - | HappyAbsSyn5 ((String, Region)) - | HappyAbsSyn6 (Region) - | HappyAbsSyn7 ((Depth Int, Dim Int, Bool)) - | HappyAbsSyn8 ((Dim Int, Bool)) - | HappyAbsSyn9 ((Depth Int, Bool)) - | HappyAbsSyn10 (Depth Int) - | HappyAbsSyn11 (Dim Int) - | HappyAbsSyn12 (Bool) - | HappyAbsSyn13 (Spec) - | HappyAbsSyn14 (Mod) - | HappyAbsSyn15 ([Mod]) - | HappyAbsSyn17 ([String]) - -{- to allow type-synonyms as our monads (likely - - with explicitly-specified bind and return) - - in Haskell98, it seems that with - - /type M a = .../, then /(HappyReduction M)/ - - is not allowed. But Happy is a - - code-generator that can just substitute it. -type HappyReduction m = - Int - -> (Token) - -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn) - -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn)] - -> HappyStk HappyAbsSyn - -> [(Token)] -> m HappyAbsSyn --} - -action_0, - action_1, - action_2, - action_3, - action_4, - action_5, - action_6, - action_7, - action_8, - action_9, - action_10, - action_11, - action_12, - action_13, - action_14, - action_15, - action_16, - action_17, - action_18, - action_19, - action_20, - action_21, - action_22, - action_23, - action_24, - action_25, - action_26, - action_27, - action_28, - action_29, - action_30, - action_31, - action_32, - action_33, - action_34, - action_35, - action_36, - action_37, - action_38, - action_39, - action_40, - action_41, - action_42, - action_43, - action_44, - action_45, - action_46, - action_47, - action_48, - action_49, - action_50, - action_51, - action_52, - action_53, - action_54, - action_55, - action_56, - action_57, - action_58, - action_59, - action_60, - action_61, - action_62, - action_63, - action_64, - action_65, - action_66, - action_67, - action_68, - action_69, - action_70, - action_71, - action_72, - action_73, - action_74, - action_75, - action_76, - action_77, - action_78, - action_79, - action_80, - action_81, - action_82 :: () => Int -> ({-HappyReduction (Either AnnotationParseError) = -} - Int - -> (Token) - -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Either AnnotationParseError) HappyAbsSyn) - -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Either AnnotationParseError) HappyAbsSyn)] - -> HappyStk HappyAbsSyn - -> [(Token)] -> (Either AnnotationParseError) HappyAbsSyn) - -happyReduce_1, - happyReduce_2, - happyReduce_3, - happyReduce_4, - happyReduce_5, - happyReduce_6, - happyReduce_7, - happyReduce_8, - happyReduce_9, - happyReduce_10, - happyReduce_11, - happyReduce_12, - happyReduce_13, - happyReduce_14, - happyReduce_15, - happyReduce_16, - happyReduce_17, - happyReduce_18, - happyReduce_19, - happyReduce_20, - happyReduce_21, - happyReduce_22, - happyReduce_23, - happyReduce_24, - happyReduce_25, - happyReduce_26, - happyReduce_27, - happyReduce_28, - happyReduce_29, - happyReduce_30, - happyReduce_31, - happyReduce_32, - happyReduce_33, - happyReduce_34, - happyReduce_35, - happyReduce_36, - happyReduce_37 :: () => ({-HappyReduction (Either AnnotationParseError) = -} - Int - -> (Token) - -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Either AnnotationParseError) HappyAbsSyn) - -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Either AnnotationParseError) HappyAbsSyn)] - -> HappyStk HappyAbsSyn - -> [(Token)] -> (Either AnnotationParseError) HappyAbsSyn) - -action_0 (18) = happyShift action_5 -action_0 (19) = happyShift action_3 -action_0 (4) = happyGoto action_4 -action_0 (5) = happyGoto action_2 -action_0 _ = happyFail - -action_1 (19) = happyShift action_3 -action_1 (5) = happyGoto action_2 -action_1 _ = happyFail - -action_2 _ = happyReduce_1 - -action_3 (36) = happyShift action_21 -action_3 _ = happyFail - -action_4 (40) = happyAccept -action_4 _ = happyFail - -action_5 (20) = happyShift action_11 -action_5 (21) = happyShift action_12 -action_5 (23) = happyShift action_13 -action_5 (24) = happyShift action_14 -action_5 (27) = happyShift action_15 -action_5 (28) = happyShift action_16 -action_5 (29) = happyShift action_17 -action_5 (30) = happyShift action_18 -action_5 (32) = happyShift action_19 -action_5 (38) = happyShift action_20 -action_5 (6) = happyGoto action_6 -action_5 (13) = happyGoto action_7 -action_5 (14) = happyGoto action_8 -action_5 (15) = happyGoto action_9 -action_5 (16) = happyGoto action_10 -action_5 _ = happyFail - -action_6 (34) = happyShift action_35 -action_6 (35) = happyShift action_36 -action_6 _ = happyReduce_30 - -action_7 (36) = happyShift action_34 -action_7 _ = happyFail - -action_8 (21) = happyShift action_12 -action_8 (27) = happyShift action_15 -action_8 (28) = happyShift action_16 -action_8 (29) = happyShift action_17 -action_8 (32) = happyShift action_19 -action_8 (38) = happyShift action_20 -action_8 (6) = happyGoto action_33 -action_8 _ = happyFail - -action_9 (20) = happyShift action_11 -action_9 (14) = happyGoto action_32 -action_9 _ = happyFail - -action_10 (21) = happyShift action_12 -action_10 (23) = happyShift action_13 -action_10 (24) = happyShift action_14 -action_10 (27) = happyShift action_15 -action_10 (28) = happyShift action_16 -action_10 (29) = happyShift action_17 -action_10 (32) = happyShift action_19 -action_10 (38) = happyShift action_20 -action_10 (6) = happyGoto action_29 -action_10 (15) = happyGoto action_30 -action_10 (16) = happyGoto action_31 -action_10 _ = happyReduce_33 - -action_11 _ = happyReduce_31 - -action_12 (38) = happyShift action_28 -action_12 _ = happyFail - -action_13 _ = happyReduce_34 - -action_14 _ = happyReduce_35 - -action_15 (38) = happyShift action_27 -action_15 _ = happyFail - -action_16 (38) = happyShift action_26 -action_16 _ = happyFail - -action_17 (38) = happyShift action_25 -action_17 _ = happyFail - -action_18 (38) = happyShift action_24 -action_18 _ = happyFail - -action_19 _ = happyReduce_11 - -action_20 (21) = happyShift action_12 -action_20 (27) = happyShift action_15 -action_20 (28) = happyShift action_16 -action_20 (29) = happyShift action_17 -action_20 (32) = happyShift action_19 -action_20 (38) = happyShift action_20 -action_20 (6) = happyGoto action_23 -action_20 _ = happyFail - -action_21 (32) = happyShift action_22 -action_21 _ = happyFail - -action_22 (37) = happyShift action_54 -action_22 _ = happyFail - -action_23 (34) = happyShift action_35 -action_23 (35) = happyShift action_36 -action_23 (39) = happyShift action_53 -action_23 _ = happyFail - -action_24 (32) = happyShift action_40 -action_24 (17) = happyGoto action_52 -action_24 _ = happyFail - -action_25 (22) = happyShift action_47 -action_25 (25) = happyShift action_48 -action_25 (26) = happyShift action_49 -action_25 (7) = happyGoto action_51 -action_25 (10) = happyGoto action_44 -action_25 (11) = happyGoto action_45 -action_25 (12) = happyGoto action_46 -action_25 _ = happyFail - -action_26 (22) = happyShift action_47 -action_26 (25) = happyShift action_48 -action_26 (26) = happyShift action_49 -action_26 (7) = happyGoto action_50 -action_26 (10) = happyGoto action_44 -action_26 (11) = happyGoto action_45 -action_26 (12) = happyGoto action_46 -action_26 _ = happyFail - -action_27 (22) = happyShift action_47 -action_27 (25) = happyShift action_48 -action_27 (26) = happyShift action_49 -action_27 (7) = happyGoto action_43 -action_27 (10) = happyGoto action_44 -action_27 (11) = happyGoto action_45 -action_27 (12) = happyGoto action_46 -action_27 _ = happyFail - -action_28 (25) = happyShift action_42 -action_28 _ = happyFail - -action_29 (34) = happyShift action_35 -action_29 (35) = happyShift action_36 -action_29 _ = happyReduce_29 - -action_30 _ = happyReduce_32 - -action_31 (23) = happyShift action_13 -action_31 (24) = happyShift action_14 -action_31 (15) = happyGoto action_30 -action_31 (16) = happyGoto action_31 -action_31 _ = happyReduce_33 - -action_32 (21) = happyShift action_12 -action_32 (27) = happyShift action_15 -action_32 (28) = happyShift action_16 -action_32 (29) = happyShift action_17 -action_32 (32) = happyShift action_19 -action_32 (38) = happyShift action_20 -action_32 (6) = happyGoto action_41 -action_32 _ = happyFail - -action_33 (34) = happyShift action_35 -action_33 (35) = happyShift action_36 -action_33 _ = happyReduce_28 - -action_34 (32) = happyShift action_40 -action_34 (17) = happyGoto action_39 -action_34 _ = happyFail - -action_35 (21) = happyShift action_12 -action_35 (27) = happyShift action_15 -action_35 (28) = happyShift action_16 -action_35 (29) = happyShift action_17 -action_35 (32) = happyShift action_19 -action_35 (38) = happyShift action_20 -action_35 (6) = happyGoto action_38 -action_35 _ = happyFail - -action_36 (21) = happyShift action_12 -action_36 (27) = happyShift action_15 -action_36 (28) = happyShift action_16 -action_36 (29) = happyShift action_17 -action_36 (32) = happyShift action_19 -action_36 (38) = happyShift action_20 -action_36 (6) = happyGoto action_37 -action_36 _ = happyFail - -action_37 _ = happyReduce_9 - -action_38 (35) = happyShift action_36 -action_38 _ = happyReduce_8 - -action_39 _ = happyReduce_2 - -action_40 (32) = happyShift action_40 -action_40 (17) = happyGoto action_71 -action_40 _ = happyReduce_37 - -action_41 (34) = happyShift action_35 -action_41 (35) = happyShift action_36 -action_41 _ = happyReduce_27 - -action_42 (37) = happyShift action_70 -action_42 _ = happyFail - -action_43 (39) = happyShift action_69 -action_43 _ = happyFail - -action_44 (22) = happyShift action_47 -action_44 (25) = happyShift action_48 -action_44 (8) = happyGoto action_66 -action_44 (11) = happyGoto action_67 -action_44 (12) = happyGoto action_68 -action_44 _ = happyFail - -action_45 (22) = happyShift action_47 -action_45 (26) = happyShift action_49 -action_45 (9) = happyGoto action_63 -action_45 (10) = happyGoto action_64 -action_45 (12) = happyGoto action_65 -action_45 _ = happyFail - -action_46 (25) = happyShift action_48 -action_46 (26) = happyShift action_49 -action_46 (10) = happyGoto action_61 -action_46 (11) = happyGoto action_62 -action_46 _ = happyFail - -action_47 _ = happyReduce_24 - -action_48 (37) = happyShift action_60 -action_48 _ = happyFail - -action_49 (37) = happyShift action_59 -action_49 _ = happyFail - -action_50 (39) = happyShift action_58 -action_50 _ = happyFail - -action_51 (39) = happyShift action_57 -action_51 _ = happyFail - -action_52 (39) = happyShift action_56 -action_52 _ = happyFail - -action_53 _ = happyReduce_10 - -action_54 (21) = happyShift action_12 -action_54 (27) = happyShift action_15 -action_54 (28) = happyShift action_16 -action_54 (29) = happyShift action_17 -action_54 (32) = happyShift action_19 -action_54 (38) = happyShift action_20 -action_54 (6) = happyGoto action_55 -action_54 _ = happyFail - -action_55 (34) = happyShift action_35 -action_55 (35) = happyShift action_36 -action_55 _ = happyReduce_3 - -action_56 (31) = happyShift action_81 -action_56 _ = happyReduce_25 - -action_57 _ = happyReduce_6 - -action_58 _ = happyReduce_5 - -action_59 (33) = happyShift action_80 -action_59 _ = happyFail - -action_60 (33) = happyShift action_79 -action_60 _ = happyFail - -action_61 (25) = happyShift action_48 -action_61 (11) = happyGoto action_78 -action_61 _ = happyFail - -action_62 (26) = happyShift action_49 -action_62 (10) = happyGoto action_77 -action_62 _ = happyFail - -action_63 _ = happyReduce_13 - -action_64 (22) = happyShift action_47 -action_64 (12) = happyGoto action_76 -action_64 _ = happyReduce_21 - -action_65 (26) = happyShift action_49 -action_65 (10) = happyGoto action_75 -action_65 _ = happyFail - -action_66 _ = happyReduce_12 - -action_67 (22) = happyShift action_47 -action_67 (12) = happyGoto action_74 -action_67 _ = happyReduce_18 - -action_68 (25) = happyShift action_48 -action_68 (11) = happyGoto action_73 -action_68 _ = happyFail - -action_69 _ = happyReduce_4 - -action_70 (33) = happyShift action_72 -action_70 _ = happyFail - -action_71 _ = happyReduce_36 - -action_72 (39) = happyShift action_82 -action_72 _ = happyFail - -action_73 _ = happyReduce_16 - -action_74 _ = happyReduce_17 - -action_75 _ = happyReduce_20 - -action_76 _ = happyReduce_19 - -action_77 _ = happyReduce_15 - -action_78 _ = happyReduce_14 - -action_79 _ = happyReduce_23 - -action_80 _ = happyReduce_22 - -action_81 _ = happyReduce_26 - -action_82 _ = happyReduce_7 - -happyReduce_1 = happySpecReduce_1 4 happyReduction_1 -happyReduction_1 (HappyAbsSyn5 happy_var_1) - = HappyAbsSyn4 - (RegionDec (fst happy_var_1) (snd happy_var_1) - ) -happyReduction_1 _ = notHappyAtAll - -happyReduce_2 = happyReduce 4 4 happyReduction_2 -happyReduction_2 ((HappyAbsSyn17 happy_var_4) `HappyStk` - _ `HappyStk` - (HappyAbsSyn13 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn4 - (SpecDec happy_var_2 happy_var_4 - ) `HappyStk` happyRest - -happyReduce_3 = happyReduce 5 5 happyReduction_3 -happyReduction_3 ((HappyAbsSyn6 happy_var_5) `HappyStk` - _ `HappyStk` - (HappyTerminal (TId happy_var_3)) `HappyStk` - _ `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn5 - ((happy_var_3, happy_var_5) - ) `HappyStk` happyRest - -happyReduce_4 = happyReduce 4 6 happyReduction_4 -happyReduction_4 (_ `HappyStk` - (HappyAbsSyn7 happy_var_3) `HappyStk` - _ `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn6 - (applyAttr Forward happy_var_3 - ) `HappyStk` happyRest - -happyReduce_5 = happyReduce 4 6 happyReduction_5 -happyReduction_5 (_ `HappyStk` - (HappyAbsSyn7 happy_var_3) `HappyStk` - _ `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn6 - (applyAttr Backward happy_var_3 - ) `HappyStk` happyRest - -happyReduce_6 = happyReduce 4 6 happyReduction_6 -happyReduction_6 (_ `HappyStk` - (HappyAbsSyn7 happy_var_3) `HappyStk` - _ `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn6 - (applyAttr Centered happy_var_3 - ) `HappyStk` happyRest - -happyReduce_7 = happyReduce 6 6 happyReduction_7 -happyReduction_7 (_ `HappyStk` - (HappyTerminal (TNum happy_var_5)) `HappyStk` - _ `HappyStk` - _ `HappyStk` - _ `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn6 - (Centered 0 (read happy_var_5) True - ) `HappyStk` happyRest - -happyReduce_8 = happySpecReduce_3 6 happyReduction_8 -happyReduction_8 (HappyAbsSyn6 happy_var_3) - _ - (HappyAbsSyn6 happy_var_1) - = HappyAbsSyn6 - (Or happy_var_1 happy_var_3 - ) -happyReduction_8 _ _ _ = notHappyAtAll - -happyReduce_9 = happySpecReduce_3 6 happyReduction_9 -happyReduction_9 (HappyAbsSyn6 happy_var_3) - _ - (HappyAbsSyn6 happy_var_1) - = HappyAbsSyn6 - (And happy_var_1 happy_var_3 - ) -happyReduction_9 _ _ _ = notHappyAtAll - -happyReduce_10 = happySpecReduce_3 6 happyReduction_10 -happyReduction_10 _ - (HappyAbsSyn6 happy_var_2) - _ - = HappyAbsSyn6 - (happy_var_2 - ) -happyReduction_10 _ _ _ = notHappyAtAll - -happyReduce_11 = happySpecReduce_1 6 happyReduction_11 -happyReduction_11 (HappyTerminal (TId happy_var_1)) - = HappyAbsSyn6 - (Var happy_var_1 - ) -happyReduction_11 _ = notHappyAtAll - -happyReduce_12 = happySpecReduce_2 7 happyReduction_12 -happyReduction_12 (HappyAbsSyn8 happy_var_2) - (HappyAbsSyn10 happy_var_1) - = HappyAbsSyn7 - ((happy_var_1, fst happy_var_2, snd happy_var_2) - ) -happyReduction_12 _ _ = notHappyAtAll - -happyReduce_13 = happySpecReduce_2 7 happyReduction_13 -happyReduction_13 (HappyAbsSyn9 happy_var_2) - (HappyAbsSyn11 happy_var_1) - = HappyAbsSyn7 - ((fst happy_var_2, happy_var_1, snd happy_var_2) - ) -happyReduction_13 _ _ = notHappyAtAll - -happyReduce_14 = happySpecReduce_3 7 happyReduction_14 -happyReduction_14 (HappyAbsSyn11 happy_var_3) - (HappyAbsSyn10 happy_var_2) - (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn7 - ((happy_var_2, happy_var_3, happy_var_1) - ) -happyReduction_14 _ _ _ = notHappyAtAll - -happyReduce_15 = happySpecReduce_3 7 happyReduction_15 -happyReduction_15 (HappyAbsSyn10 happy_var_3) - (HappyAbsSyn11 happy_var_2) - (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn7 - ((happy_var_3, happy_var_2, happy_var_1) - ) -happyReduction_15 _ _ _ = notHappyAtAll - -happyReduce_16 = happySpecReduce_2 8 happyReduction_16 -happyReduction_16 (HappyAbsSyn11 happy_var_2) - (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn8 - ((happy_var_2, happy_var_1) - ) -happyReduction_16 _ _ = notHappyAtAll - -happyReduce_17 = happySpecReduce_2 8 happyReduction_17 -happyReduction_17 (HappyAbsSyn12 happy_var_2) - (HappyAbsSyn11 happy_var_1) - = HappyAbsSyn8 - ((happy_var_1, happy_var_2) - ) -happyReduction_17 _ _ = notHappyAtAll - -happyReduce_18 = happySpecReduce_1 8 happyReduction_18 -happyReduction_18 (HappyAbsSyn11 happy_var_1) - = HappyAbsSyn8 - ((happy_var_1, True) - ) -happyReduction_18 _ = notHappyAtAll - -happyReduce_19 = happySpecReduce_2 9 happyReduction_19 -happyReduction_19 (HappyAbsSyn12 happy_var_2) - (HappyAbsSyn10 happy_var_1) - = HappyAbsSyn9 - ((happy_var_1, happy_var_2) - ) -happyReduction_19 _ _ = notHappyAtAll - -happyReduce_20 = happySpecReduce_2 9 happyReduction_20 -happyReduction_20 (HappyAbsSyn10 happy_var_2) - (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn9 - ((happy_var_2, happy_var_1) - ) -happyReduction_20 _ _ = notHappyAtAll - -happyReduce_21 = happySpecReduce_1 9 happyReduction_21 -happyReduction_21 (HappyAbsSyn10 happy_var_1) - = HappyAbsSyn9 - ((happy_var_1, True) - ) -happyReduction_21 _ = notHappyAtAll - -happyReduce_22 = happySpecReduce_3 10 happyReduction_22 -happyReduction_22 (HappyTerminal (TNum happy_var_3)) - _ - _ - = HappyAbsSyn10 - (Depth $ read happy_var_3 - ) -happyReduction_22 _ _ _ = notHappyAtAll - -happyReduce_23 = happySpecReduce_3 11 happyReduction_23 -happyReduction_23 (HappyTerminal (TNum happy_var_3)) - _ - _ - = HappyAbsSyn11 - (Dim $ read happy_var_3 - ) -happyReduction_23 _ _ _ = notHappyAtAll - -happyReduce_24 = happySpecReduce_1 12 happyReduction_24 -happyReduction_24 _ - = HappyAbsSyn12 - (False - ) - -happyReduce_25 = happyReduce 4 13 happyReduction_25 -happyReduction_25 (_ `HappyStk` - (HappyAbsSyn17 happy_var_3) `HappyStk` - _ `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn13 - (Temporal happy_var_3 False - ) `HappyStk` happyRest - -happyReduce_26 = happyReduce 5 13 happyReduction_26 -happyReduction_26 (_ `HappyStk` - _ `HappyStk` - (HappyAbsSyn17 happy_var_3) `HappyStk` - _ `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn13 - (Temporal happy_var_3 True - ) `HappyStk` happyRest - -happyReduce_27 = happySpecReduce_3 13 happyReduction_27 -happyReduction_27 (HappyAbsSyn6 happy_var_3) - (HappyAbsSyn14 happy_var_2) - (HappyAbsSyn15 happy_var_1) - = HappyAbsSyn13 - (Spatial (happy_var_1 ++ [happy_var_2]) happy_var_3 - ) -happyReduction_27 _ _ _ = notHappyAtAll - -happyReduce_28 = happySpecReduce_2 13 happyReduction_28 -happyReduction_28 (HappyAbsSyn6 happy_var_2) - (HappyAbsSyn14 happy_var_1) - = HappyAbsSyn13 - (Spatial [happy_var_1] happy_var_2 - ) -happyReduction_28 _ _ = notHappyAtAll - -happyReduce_29 = happySpecReduce_2 13 happyReduction_29 -happyReduction_29 (HappyAbsSyn6 happy_var_2) - (HappyAbsSyn14 happy_var_1) - = HappyAbsSyn13 - (Spatial [happy_var_1] happy_var_2 - ) -happyReduction_29 _ _ = notHappyAtAll - -happyReduce_30 = happySpecReduce_1 13 happyReduction_30 -happyReduction_30 (HappyAbsSyn6 happy_var_1) - = HappyAbsSyn13 - (Spatial [] happy_var_1 - ) -happyReduction_30 _ = notHappyAtAll - -happyReduce_31 = happySpecReduce_1 14 happyReduction_31 -happyReduction_31 _ - = HappyAbsSyn14 - (ReadOnce - ) - -happyReduce_32 = happySpecReduce_2 15 happyReduction_32 -happyReduction_32 (HappyAbsSyn15 happy_var_2) - (HappyAbsSyn14 happy_var_1) - = HappyAbsSyn15 - (happy_var_1 : happy_var_2 - ) -happyReduction_32 _ _ = notHappyAtAll - -happyReduce_33 = happySpecReduce_1 15 happyReduction_33 -happyReduction_33 (HappyAbsSyn14 happy_var_1) - = HappyAbsSyn15 - ([happy_var_1] - ) -happyReduction_33 _ = notHappyAtAll - -happyReduce_34 = happySpecReduce_1 16 happyReduction_34 -happyReduction_34 _ - = HappyAbsSyn14 - (AtMost - ) - -happyReduce_35 = happySpecReduce_1 16 happyReduction_35 -happyReduction_35 _ - = HappyAbsSyn14 - (AtLeast - ) - -happyReduce_36 = happySpecReduce_2 17 happyReduction_36 -happyReduction_36 (HappyAbsSyn17 happy_var_2) - (HappyTerminal (TId happy_var_1)) - = HappyAbsSyn17 - (happy_var_1 : happy_var_2 - ) -happyReduction_36 _ _ = notHappyAtAll - -happyReduce_37 = happySpecReduce_1 17 happyReduction_37 -happyReduction_37 (HappyTerminal (TId happy_var_1)) - = HappyAbsSyn17 - ([happy_var_1] - ) -happyReduction_37 _ = notHappyAtAll - -happyNewToken action sts stk [] = - action 40 40 notHappyAtAll (HappyState action) sts stk [] - -happyNewToken action sts stk (tk:tks) = - let cont i = action i i tk (HappyState action) sts stk tks in - case tk of { - TId "stencil" -> cont 18; - TId "region" -> cont 19; - TId "readonce" -> cont 20; - TId "reflexive" -> cont 21; - TId "irreflexive" -> cont 22; - TId "atmost" -> cont 23; - TId "atleast" -> cont 24; - TId "dim" -> cont 25; - TId "depth" -> cont 26; - TId "forward" -> cont 27; - TId "backward" -> cont 28; - TId "centered" -> cont 29; - TId "dependency" -> cont 30; - TId "mutual" -> cont 31; - TId happy_dollar_dollar -> cont 32; - TNum happy_dollar_dollar -> cont 33; - TPlus -> cont 34; - TStar -> cont 35; - TDoubleColon -> cont 36; - TEqual -> cont 37; - TLParen -> cont 38; - TRParen -> cont 39; - _ -> happyError' (tk:tks) - } - -happyError_ 40 tk tks = happyError' tks -happyError_ _ tk tks = happyError' (tk:tks) - -happyThen :: () => Either AnnotationParseError a -> (a -> Either AnnotationParseError b) -> Either AnnotationParseError b -happyThen = (>>=) -happyReturn :: () => a -> Either AnnotationParseError a -happyReturn = (return) -happyThen1 m k tks = (>>=) m (\a -> k a tks) -happyReturn1 :: () => a -> b -> Either AnnotationParseError a -happyReturn1 = \a tks -> (return) a -happyError' :: () => [(Token)] -> Either AnnotationParseError a -happyError' = happyError - -parseSpec tks = happySomeParser where - happySomeParser = happyThen (happyParse action_0 tks) (\x -> case x of {HappyAbsSyn4 z -> happyReturn z; _other -> notHappyAtAll }) - -happySeq = happyDontSeq - - -newtype Depth a = Depth a -newtype Dim a = Dim a - -applyAttr :: (Int -> Int -> Bool -> Region) - -> (Depth Int, Dim Int, Bool) - -> Region -applyAttr constr (Depth d, Dim dim, irrefl) = constr d dim irrefl - -data Specification - = RegionDec String Region - | SpecDec Spec [String] - deriving (Show, Eq, Ord, Typeable, Data) - -data Region - = Forward Int Int Bool - | Backward Int Int Bool - | Centered Int Int Bool - | Or Region Region - | And Region Region - | Var String - deriving (Show, Eq, Ord, Typeable, Data) - -data Spec - = Spatial [Mod] Region - | Temporal [String] Bool - deriving (Show, Eq, Ord, Typeable, Data) - -data Mod - = AtLeast - | AtMost - | ReadOnce - deriving (Show, Eq, Ord, Typeable, Data) - --------------------------------------------------- - -data Token - = TDoubleColon - | TStar - | TPlus - | TEqual - | TComma - | TLParen - | TRParen - | TId String - | TNum String - deriving (Show) - -addToTokens :: Token -> String -> Either AnnotationParseError [ Token ] -addToTokens tok rest = do - tokens <- lexer' rest - return $ tok : tokens - -stripLeadingWhiteSpace (' ':xs) = stripLeadingWhiteSpace xs -stripLeadingWhiteSpace ('\t':xs) = stripLeadingWhiteSpace xs -stripLeadingWhiteSpace ('\n':xs) = stripLeadingWhiteSpace xs -stripLeadingWhiteSpace xs = xs - - -lexer :: String -> Either AnnotationParseError [ Token ] -lexer input | length (stripLeadingWhiteSpace input) >= 2 = - case stripLeadingWhiteSpace input of - -- Check the leading character is '=' for specification - '=':input' -> - -- First test to see if the input looks like an actual - -- specification of either a stencil or region - if (input' `hasPrefix` "stencil" || input' `hasPrefix` "region") - then lexer' input' - else Left NotAnnotation - _ -> Left NotAnnotation - where - hasPrefix [] str = False - hasPrefix (' ':xs) str = hasPrefix xs str - hasPrefix xs str = isPrefixOf str xs -lexer _ = Left NotAnnotation - - -lexer' :: String -> Either AnnotationParseError [ Token ] -lexer' [] = return [] -lexer' (' ':xs) = lexer' xs -lexer' ('\t':xs) = lexer' xs -lexer' (':':':':xs) = addToTokens TDoubleColon xs -lexer' ('*':xs) = addToTokens TStar xs -lexer' ('+':xs) = addToTokens TPlus xs -lexer' ('=':xs) = addToTokens TEqual xs --- Comma hack: drop commas that are not separating numbers, in order to avoid need for 2-token lookahead. -lexer' (',':xs) - | x':xs' <- dropWhile isSpace xs, not (isNumber x') = lexer' (x':xs') - | otherwise = addToTokens TComma xs -lexer' ('(':xs) = addToTokens TLParen xs -lexer' (')':xs) = addToTokens TRParen xs -lexer' (x:xs) - | isLetter x = aux TId $ \ c -> isAlphaNum c || c == '_' - | isNumber x = aux TNum isNumber - | otherwise - = failWith $ "Not an indentifier " ++ show x - where - aux f p = (f target :) `fmap` lexer' rest - where (target, rest) = span p (x:xs) -lexer' x - = failWith $ "Not a valid piece of stencil syntax " ++ show x - --------------------------------------------------- - --- specParser :: String -> Either AnnotationParseError Specification -specParser :: AnnotationParser Specification -specParser src = do - tokens <- lexer src - parseSpec tokens >>= modValidate - --- Check whether modifiers are used correctly -modValidate :: Specification -> Either AnnotationParseError Specification -modValidate (SpecDec (Spatial mods r) vars) = - do mods' <- modValidate' $ sort mods - return $ SpecDec (Spatial mods' r) vars - - where modValidate' [] = return $ [] - - modValidate' (AtLeast : AtLeast : xs) - = failWith "Duplicate 'atLeast' modifier; use at most one." - - modValidate' (AtMost : AtMost : xs) - = failWith "Duplicate 'atMost' modifier; use at most one." - - modValidate' (ReadOnce : ReadOnce : xs) - = failWith "Duplicate 'readOnce' modifier; use at most one." - - modValidate' (AtLeast : AtMost : xs) - = failWith $ "Conflicting modifiers: cannot use 'atLeast' and " - ++ "'atMost' together" - - modValidate' (x : xs) - = do xs' <- modValidate' xs - return $ x : xs' -modValidate x = return x - -happyError :: [ Token ] -> Either AnnotationParseError a -happyError t = failWith $ "Could not parse specification at: " ++ show t -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 16 "" #-} -{-# LINE 1 "/usr/local/lib/ghc-7.10.2/include/ghcversion.h" #-} - - - - - - - - - - - - - - - - - - -{-# LINE 17 "" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} --- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp - - -{-# LINE 13 "templates/GenericTemplate.hs" #-} - - -{-# LINE 46 "templates/GenericTemplate.hs" #-} - - - - - - - - - -{-# LINE 67 "templates/GenericTemplate.hs" #-} - - -{-# LINE 77 "templates/GenericTemplate.hs" #-} - - - - - - - - - - -infixr 9 `HappyStk` -data HappyStk a = HappyStk a (HappyStk a) - ------------------------------------------------------------------------------ --- starting the parse - -happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll - ------------------------------------------------------------------------------ --- Accepting the parse - --- If the current token is (1), it means we've just accepted a partial --- parse (a %partial parser). We must ignore the saved token on the top of --- the stack in this case. -happyAccept (1) tk st sts (_ `HappyStk` ans `HappyStk` _) = - happyReturn1 ans -happyAccept j tk st sts (HappyStk ans _) = - (happyReturn1 ans) - ------------------------------------------------------------------------------ --- Arrays only: do the next action - - -{-# LINE 155 "templates/GenericTemplate.hs" #-} - ------------------------------------------------------------------------------ --- HappyState data type (not arrays) - - - -newtype HappyState b c = HappyState - (Int -> -- token number - Int -> -- token number (yes, again) - b -> -- token semantic value - HappyState b c -> -- current state - [HappyState b c] -> -- state stack - c) - - - ------------------------------------------------------------------------------ --- Shifting a token - -happyShift new_state (1) tk st sts stk@(x `HappyStk` _) = - let i = (case x of { HappyErrorToken (i) -> i }) in --- trace "shifting the error token" $ - new_state i i tk (HappyState (new_state)) ((st):(sts)) (stk) - -happyShift new_state i tk st sts stk = - happyNewToken new_state ((st):(sts)) ((HappyTerminal (tk))`HappyStk`stk) - --- happyReduce is specialised for the common cases. - -happySpecReduce_0 i fn (1) tk st sts stk - = happyFail (1) tk st sts stk -happySpecReduce_0 nt fn j tk st@((HappyState (action))) sts stk - = action nt j tk st ((st):(sts)) (fn `HappyStk` stk) - -happySpecReduce_1 i fn (1) tk st sts stk - = happyFail (1) tk st sts stk -happySpecReduce_1 nt fn j tk _ sts@(((st@(HappyState (action))):(_))) (v1`HappyStk`stk') - = let r = fn v1 in - happySeq r (action nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_2 i fn (1) tk st sts stk - = happyFail (1) tk st sts stk -happySpecReduce_2 nt fn j tk _ ((_):(sts@(((st@(HappyState (action))):(_))))) (v1`HappyStk`v2`HappyStk`stk') - = let r = fn v1 v2 in - happySeq r (action nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_3 i fn (1) tk st sts stk - = happyFail (1) tk st sts stk -happySpecReduce_3 nt fn j tk _ ((_):(((_):(sts@(((st@(HappyState (action))):(_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') - = let r = fn v1 v2 v3 in - happySeq r (action nt j tk st sts (r `HappyStk` stk')) - -happyReduce k i fn (1) tk st sts stk - = happyFail (1) tk st sts stk -happyReduce k nt fn j tk st sts stk - = case happyDrop (k - ((1) :: Int)) sts of - sts1@(((st1@(HappyState (action))):(_))) -> - let r = fn stk in -- it doesn't hurt to always seq here... - happyDoSeq r (action nt j tk st1 sts1 r) - -happyMonadReduce k nt fn (1) tk st sts stk - = happyFail (1) tk st sts stk -happyMonadReduce k nt fn j tk st sts stk = - case happyDrop k ((st):(sts)) of - sts1@(((st1@(HappyState (action))):(_))) -> - let drop_stk = happyDropStk k stk in - happyThen1 (fn stk tk) (\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk)) - -happyMonad2Reduce k nt fn (1) tk st sts stk - = happyFail (1) tk st sts stk -happyMonad2Reduce k nt fn j tk st sts stk = - case happyDrop k ((st):(sts)) of - sts1@(((st1@(HappyState (action))):(_))) -> - let drop_stk = happyDropStk k stk - - - - - - new_state = action - - in - happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) - -happyDrop (0) l = l -happyDrop n ((_):(t)) = happyDrop (n - ((1) :: Int)) t - -happyDropStk (0) l = l -happyDropStk n (x `HappyStk` xs) = happyDropStk (n - ((1)::Int)) xs - ------------------------------------------------------------------------------ --- Moving to a new state after a reduction - - - - - - - - - -happyGoto action j tk st = action j j tk (HappyState action) - - ------------------------------------------------------------------------------ --- Error recovery ((1) is the error token) - --- parse error if we are in recovery and we fail again -happyFail (1) tk old_st _ stk@(x `HappyStk` _) = - let i = (case x of { HappyErrorToken (i) -> i }) in --- trace "failing" $ - happyError_ i tk - -{- We don't need state discarding for our restricted implementation of - "error". In fact, it can cause some bogus parses, so I've disabled it - for now --SDM - --- discard a state -happyFail (1) tk old_st (((HappyState (action))):(sts)) - (saved_tok `HappyStk` _ `HappyStk` stk) = --- trace ("discarding state, depth " ++ show (length stk)) $ - action (1) (1) tk (HappyState (action)) sts ((saved_tok`HappyStk`stk)) --} - --- Enter error recovery: generate an error token, --- save the old token and carry on. -happyFail i tk (HappyState (action)) sts stk = --- trace "entering error recovery" $ - action (1) (1) tk (HappyState (action)) sts ( (HappyErrorToken (i)) `HappyStk` stk) - --- Internal happy errors: - -notHappyAtAll :: a -notHappyAtAll = error "Internal Happy error\n" - ------------------------------------------------------------------------------ --- Hack to get the typechecker to accept our action functions - - - - - - - ------------------------------------------------------------------------------ --- Seq-ing. If the --strict flag is given, then Happy emits --- happySeq = happyDoSeq --- otherwise it emits --- happySeq = happyDontSeq - -happyDoSeq, happyDontSeq :: a -> b -> b -happyDoSeq a b = a `seq` b -happyDontSeq a b = b - ------------------------------------------------------------------------------ --- Don't inline any functions from the template. GHC has a nasty habit --- of deciding to inline happyGoto everywhere, which increases the size of --- the generated parser quite a bit. - - - - - - - - - -{-# NOINLINE happyShift #-} -{-# NOINLINE happySpecReduce_0 #-} -{-# NOINLINE happySpecReduce_1 #-} -{-# NOINLINE happySpecReduce_2 #-} -{-# NOINLINE happySpecReduce_3 #-} -{-# NOINLINE happyReduce #-} -{-# NOINLINE happyMonadReduce #-} -{-# NOINLINE happyGoto #-} -{-# NOINLINE happyFail #-} - --- end of Happy Template. - diff --git a/src/Camfort/Specification/Stencils/Grammar.y b/src/Camfort/Specification/Stencils/Grammar.y --- a/src/Camfort/Specification/Stencils/Grammar.y +++ b/src/Camfort/Specification/Stencils/Grammar.y @@ -22,8 +22,8 @@ stencil { TId "stencil" } region { TId "region" } readOnce { TId "readonce" } - reflexive { TId "reflexive" } - irreflexive { TId "irreflexive" } + pointed { TId "pointed" } + nonpointed { TId "nonpointed" } atMost { TId "atmost" } atLeast { TId "atleast" } dim { TId "dim" } @@ -56,7 +56,7 @@ : forward '(' REGION_ATTRS ')' { applyAttr Forward $3 } | backward '(' REGION_ATTRS ')' { applyAttr Backward $3 } | centered '(' REGION_ATTRS ')' { applyAttr Centered $3 } -| reflexive '(' dim '=' num ')' { Centered 0 (read $5) True } +| pointed '(' dim '=' num ')' { Centered 0 (read $5) True } | REGION '+' REGION { Or $1 $3 } | REGION '*' REGION { And $1 $3 } | '(' REGION ')' { $2 } @@ -87,7 +87,7 @@ DIM : dim '=' num { Dim $ read $3 } REFL :: { Bool } - : irreflexive { False } + : nonpointed { False } SPECDEC :: { Spec } : APPROXMODS MOD REGION { Spatial ($1 ++ [$2]) $3 } diff --git a/src/Camfort/Specification/Stencils/InferenceBackend.hs b/src/Camfort/Specification/Stencils/InferenceBackend.hs --- a/src/Camfort/Specification/Stencils/InferenceBackend.hs +++ b/src/Camfort/Specification/Stencils/InferenceBackend.hs @@ -16,213 +16,141 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE LambdaCase #-} module Camfort.Specification.Stencils.InferenceBackend where -import Prelude hiding (sum) -import Data.Generics.Uniplate.Operations -import Data.List hiding (sum) -import Data.Data -import Control.Arrow ((***)) -import Data.Function +import Data.List +import Data.Maybe +import Algebra.Lattice (joins1) import Camfort.Specification.Stencils.Model +import Camfort.Specification.Stencils.DenotationalSemantics import Camfort.Helpers -import Camfort.Helpers.Vec - -import Debug.Trace -import Unsafe.Coerce +import qualified Camfort.Helpers.Vec as V import Camfort.Specification.Stencils.Syntax {- Spans are a pair of a lower and upper bound -} -type Span a = (a, a) -mkTrivialSpan a = (a, a) -inferFromIndices :: VecList Int -> Specification -inferFromIndices (VL ixs) = Specification $ - case fromBool mult of - Linear -> Single $ inferCore ixs' - NonLinear -> Multiple $ inferCore ixs' - where - (ixs', mult) = hasDuplicates ixs - --- Same as inferFromIndices but don't do any linearity checking --- (defaults to NonLinear). This is used when the front-end does --- the linearity check first as an optimimsation. -inferFromIndicesWithoutLinearity :: VecList Int -> Specification -inferFromIndicesWithoutLinearity (VL ixs) = - Specification . Multiple . inferCore $ ixs - -inferCore :: (IsNatural n, Permutable n) => [Vec n Int] -> Approximation Spatial -inferCore = simplify . fromRegionsToSpec . inferMinimalVectorRegions - -simplify :: Approximation Spatial -> Approximation Spatial -simplify = fmap simplifySpatial - -simplifySpatial :: Spatial -> Spatial -simplifySpatial (Spatial (Sum ps)) = Spatial (Sum ps') - where ps' = order (reducor ps normaliseNoSort size) - order = sort . (map (Product . sort . unProd)) - size :: [RegionProd] -> Int - size = foldr (+) 0 . map (length . unProd) - --- Given a list, a list->list transofmer, a size function --- find the minimal transformed list by applying the transformer --- to every permutation of the list and when a smaller list is found --- iteratively apply to permutations on the smaller list -reducor :: [a] -> ([a] -> [a]) -> ([a] -> Int) -> [a] -reducor xs f size = reducor' (permutations xs) - where - reducor' [y] = f y - reducor' (y:ys) = - if (size y' < size y) - then reducor' (permutations y') - else reducor' ys - where y' = f y - -fromRegionsToSpec :: IsNatural n => [Span (Vec n Int)] -> Approximation Spatial -fromRegionsToSpec = foldr (\x y -> sum (toSpecND x) y) zero +type Span a = (a, a) --- toSpecND converts an n-dimensional region into an exact --- spatial specification or a bound of spatial specifications -toSpecND :: Span (Vec n Int) -> Approximation Spatial -toSpecND = toSpecPerDim 1 +spansToApproxSpatial :: [ Span (V.Vec (V.S n) Int) ] + -> Either String (Approximation Spatial) +spansToApproxSpatial spans = sequence . fmap intervalsToRegions $ approxUnion where - -- convert the region one dimension at a time. - toSpecPerDim :: Int -> Span (Vec n Int) -> Approximation Spatial - toSpecPerDim d (Nil, Nil) = one - toSpecPerDim d (Cons l ls, Cons u us) = - prod (toSpec1D d l u) (toSpecPerDim (d + 1) (ls, us)) - --- toSpec1D takes a dimension identifier, a lower and upper bound of a region in --- that dimension, and builds the simple directional spec. -toSpec1D :: Dimension -> Int -> Int -> Approximation Spatial -toSpec1D dim l u - | l == absoluteRep || u == absoluteRep = - Exact $ Spatial (Sum [Product []]) - - | l == 0 && u == 0 = - Exact $ Spatial (Sum [Product [Centered 0 dim True]]) - - | l < 0 && u == 0 = - Exact $ Spatial (Sum [Product [Backward (abs l) dim True]]) - - | l < 0 && u == (-1) = - Exact $ Spatial (Sum [Product [Backward (abs l) dim False]]) - - | l == 0 && u > 0 = - Exact $ Spatial (Sum [Product [Forward u dim True]]) + approxVecs = + toApprox . map (fmap absRepToInf . transposeVecInterval) $ spans + approxUnion = fmap (optimise . joins1 . map return) approxVecs - | l == 1 && u > 0 = - Exact $ Spatial (Sum [Product [Forward u dim False]]) + toApprox :: [ V.Vec n (Interval Arbitrary) ] + -> Approximation [ V.Vec n (Interval Standard) ] + toApprox vs + | parts <- (elongatedPartitions . map approxVec) vs = + case parts of + (orgs, []) -> Exact . map fromExact $ orgs + ([], elongs) -> Bound Nothing (Just $ map upperBound elongs) + (orgs, elongs) -> Bound (Just . map upperBound $ orgs) + (Just . map upperBound $ orgs ++ elongs) - | l < 0 && u > 0 && (abs l == u) = - Exact $ Spatial (Sum [Product [Centered u dim True]]) + elongatedPartitions = + partition $ \case { Exact{} -> True; Bound{} -> False } - | l < 0 && u > 0 && (abs l /= u) = - Exact $ Spatial (Sum [Product [Backward (abs l) dim True], - Product [Forward u dim True]]) - -- Represents a non-contiguous region - | otherwise = - upperBound $ Spatial (Sum [Product - [if l > 0 then Forward u dim True else Backward (abs l) dim True]]) + -- TODO: DELETE AS SOON AS POSSIBLE + absRepToInf :: Interval Arbitrary -> Interval Arbitrary + absRepToInf interv@(IntervArbitrary a b) + | fromIntegral a == absoluteRep = IntervInfiniteArbitrary + | fromIntegral b == absoluteRep = IntervInfiniteArbitrary + | otherwise = interv + absRepToInf interv = interv -{- Normalise a span into the form (lower, upper) based on the first index -} -normaliseSpan :: Span (Vec n Int) -> Span (Vec n Int) -normaliseSpan (Nil, Nil) - = (Nil, Nil) -normaliseSpan (a@(Cons l1 ls1), b@(Cons u1 us1)) - | l1 <= u1 = (a, b) - | otherwise = (b, a) + transposeVecInterval :: Span (V.Vec n Int) -> V.Vec n (Interval Arbitrary) + transposeVecInterval (us, vs) = V.zipWith IntervArbitrary us vs --- DEPRECATED -{- `spanBoundingBox` creates a span which is a bounding box over two spans -} -spanBoundingBox :: Span (Vec n Int) -> Span (Vec n Int) -> Span (Vec n Int) -spanBoundingBox a b = boundingBox' (normaliseSpan a) (normaliseSpan b) +mkTrivialSpan :: V.Vec n Int -> Span (V.Vec n Int) +mkTrivialSpan V.Nil = (V.Nil, V.Nil) +mkTrivialSpan (V.Cons x xs) = + if x == absoluteRep + then (V.Cons (-absoluteRep) ys, V.Cons absoluteRep zs) + else (V.Cons x ys, V.Cons x zs) where - boundingBox' :: Span (Vec n Int) -> Span (Vec n Int) -> Span (Vec n Int) - boundingBox' (Nil, Nil) (Nil, Nil) - = (Nil, Nil) - boundingBox' (Cons l1 ls1, Cons u1 us1) (Cons l2 ls2, Cons u2 us2) - = let (ls', us') = boundingBox' (ls1, us1) (ls2, us2) - in (Cons (min l1 l2) ls', Cons (max u1 u2) us') + (ys, zs) = mkTrivialSpan xs +-- TODO: This seems completely redundant. Perhaps DELETE. +inferFromIndices :: V.VecList Int -> Specification +inferFromIndices (V.VL ixs) = Specification $ + case fromBool mult of + Linear -> Once $ inferCore ixs' + NonLinear -> Mult $ inferCore ixs' + where + (ixs', mult) = hasDuplicates ixs -{-| Given two spans, if they are consecutive - (i.e., (lower1, upper1) (lower2, upper2) where lower2 = upper1 + 1) - then compose together returning Just of the new span. Otherwise Nothing -} -composeConsecutiveSpans :: Span (Vec n Int) - -> Span (Vec n Int) -> [Span (Vec n Int)] -composeConsecutiveSpans (Nil, Nil) (Nil, Nil) = [(Nil, Nil)] -composeConsecutiveSpans (Cons l1 ls1, Cons u1 us1) (Cons l2 ls2, Cons u2 us2) - | (ls1 == ls2) && (us1 == us2) && (u1 + 1 == l2) - = [(Cons l1 ls1, Cons u2 us2)] - | otherwise - = [] +-- Same as inferFromIndices but don't do any linearity checking +-- (defaults to NonLinear). This is used when the front-end does +-- the linearity check first as an optimimsation. +inferFromIndicesWithoutLinearity :: V.VecList Int -> Specification +inferFromIndicesWithoutLinearity (V.VL ixs) = + Specification . Mult . inferCore $ ixs +inferCore :: [V.Vec n Int] -> Approximation Spatial +inferCore subs = + case V.proveNonEmpty . head $ subs of + Just (V.ExistsEqT V.ReflEq) -> + case spansToApproxSpatial . inferMinimalVectorRegions $ subs of + Right a -> a + Left msg -> error msg + Nothing -> error "Input vectors are empty!" + {-| |inferMinimalVectorRegions| a key part of the algorithm, from a list of n-dimensional relative indices it infers a list of (possibly overlapping) 1-dimensional spans (vectors) within the n-dimensional space. Built from |minimalise| and |allRegionPermutations| -} -inferMinimalVectorRegions :: (Permutable n) => [Vec n Int] -> [Span (Vec n Int)] +inferMinimalVectorRegions :: [V.Vec n Int] -> [Span (V.Vec n Int)] inferMinimalVectorRegions = fixCoalesce . map mkTrivialSpan where fixCoalesce spans = - let spans' = minimaliseRegions . allRegionPermutations $ spans + let spans' = minimaliseRegions . coalesceContiguous $ spans in if spans' == spans then spans' else fixCoalesce spans' -{-| Map from a lists of n-dimensional spans of relative indices into all - possible contiguous spans within the n-dimensional space (individual pass)-} -allRegionPermutations :: (Permutable n) - => [Span (Vec n Int)] -> [Span (Vec n Int)] -allRegionPermutations = - nub . concat . unpermuteIndices . map (coalesceRegions >< id) . groupByPerm . map permutationss - where - {- Permutations of a indices in a span - (independently permutes the lower and upper bounds in the same way) -} - permutationss :: Permutable n - => Span (Vec n Int) - -> [(Span (Vec n Int), Vec n Int -> Vec n Int)] - -- Since the permutation ordering is identical for lower & upper bound, - -- reuse the same unpermutation - permutationss (l, u) = map (\((l', un1), (u', un2)) -> ((l', u'), un1)) - $ zip (permutationsV l) (permutationsV u) - - sortByFst = sortBy (\(l1, u1) (l2, u2) -> compare l1 l2) - - groupByPerm :: [[(Span (Vec n Int), Vec n Int -> Vec n Int)]] - -> [( [Span (Vec n Int)] , Vec n Int -> Vec n Int)] - groupByPerm = map (\ixP -> let unPerm = snd $ head ixP - in (map fst ixP, unPerm)) . transpose - - coalesceRegions :: [Span (Vec n Int)] -> [Span (Vec n Int)] - coalesceRegions = nub . foldL composeConsecutiveSpans . sortByFst +-- An alternative that is simpler and possibly quicker +coalesceContiguous :: [Span (V.Vec n Int)] -> [Span (V.Vec n Int)] +coalesceContiguous [] = [] +coalesceContiguous [x] = [x] +coalesceContiguous [x, y] = + case coalesce x y of + Nothing -> [x, y] + Just c -> [c] +coalesceContiguous (x:xs) = + case sequenceMaybes (map (coalesce x) xs) of + Nothing -> x : coalesceContiguous xs + Just cs -> coalesceContiguous (cs ++ xs) - unpermuteIndices :: [([Span (Vec n Int)], Vec n Int -> Vec n Int)] - -> [[Span (Vec n Int)]] - unpermuteIndices = nub . map (\(rs, unPerm) -> map (unPerm *** unPerm) rs) +sequenceMaybes :: Eq a => [Maybe a] -> Maybe [a] +sequenceMaybes xs | all (== Nothing) xs = Nothing + | otherwise = Just (catMaybes xs) --- Helper function, reduces a list two elements at a time with a non-determistic operation -foldL :: (a -> a -> [a]) -> [a] -> [a] -foldL f [] = [] -foldL f [a] = [a] -foldL f (a:(b:xs)) = case f a b of - [] -> a : foldL f (b : xs) - cs -> foldL f (cs ++ xs) +coalesce :: Span (V.Vec n Int) -> Span (V.Vec n Int) -> Maybe (Span (V.Vec n Int)) +coalesce (V.Nil, V.Nil) (V.Nil, V.Nil) = Just (V.Nil, V.Nil) +-- If two well-defined intervals are equal, then they cannot be coalesced +coalesce x y | x == y = Nothing +-- Otherwise +coalesce (V.Cons l1 ls1, V.Cons u1 us1) (V.Cons l2 ls2, V.Cons u2 us2) + | l1 == l2 && u1 == u2 + = case coalesce (ls1, us1) (ls2, us2) of + Just (l, u) -> Just (V.Cons l1 l, V.Cons u1 u) + Nothing -> Nothing + | (u1 + 1 == l2) && (us1 == us2) && (ls1 == ls2) + = Just (V.Cons l1 ls1, V.Cons u2 us2) + | (u2 + 1 == l1) && (us1 == us2) && (ls1 == ls2) + = Just (V.Cons l2 ls2, V.Cons u1 us1) + | otherwise + = Nothing {-| Collapses the regions into a small set by looking for potential overlaps and eliminating those that overlap -} -minimaliseRegions :: [Span (Vec n Int)] -> [Span (Vec n Int)] +minimaliseRegions :: [Span (V.Vec n Int)] -> [Span (V.Vec n Int)] minimaliseRegions [] = [] minimaliseRegions xss = nub . minimalise $ xss - where localMin x ys = (filter' x (\y -> containedWithin x y && (x /= y)) xss) ++ ys + where localMin x ys = filter' x (\y -> containedWithin x y && (x /= y)) xss ++ ys minimalise = foldr localMin [] -- If nothing is caught by the filter, i.e. no overlaps then return -- the original regions r @@ -231,97 +159,11 @@ ys -> ys {-| Binary predicate on whether the first region containedWithin the second -} -containedWithin :: Span (Vec n Int) -> Span (Vec n Int) -> Bool -containedWithin (Nil, Nil) (Nil, Nil) +containedWithin :: Span (V.Vec n Int) -> Span (V.Vec n Int) -> Bool +containedWithin (V.Nil, V.Nil) (V.Nil, V.Nil) = True -containedWithin (Cons l1 ls1, Cons u1 us1) (Cons l2 ls2, Cons u2 us2) +containedWithin (V.Cons l1 ls1, V.Cons u1 us1) (V.Cons l2 ls2, V.Cons u2 us2) = (l2 <= l1 && u1 <= u2) && containedWithin (ls1, us1) (ls2, us2) - - -{-| Defines the (total) class of vector sizes which are permutable, along with - the permutation function which pairs permutations with the 'unpermute' - operation -} -class Permutable (n :: Nat) where - -- From a Vector of length n to a list of 'selections' - -- (triples of a selected element, the rest of the vector, - -- a function to 'unselect') - selectionsV :: Vec n a -> [Selection n a] - -- From a Vector of length n to a list of its permutations paired with the - -- 'unpermute' function - permutationsV :: Vec n a -> [(Vec n a, Vec n a -> Vec n a)] - --- 'Split' is a size-indexed family which gives the type of selections --- for each size: --- Z is trivial --- (S n) provides a triple of the select element, the remaining vector, --- and the 'unselect' function for returning the original value -type family Selection n a where - Selection Z a = a - Selection (S n) a = (a, Vec n a, a -> Vec n a -> Vec (S n) a) - -instance Permutable Z where - selectionsV Nil = [] - permutationsV Nil = [(Nil, id)] - -instance Permutable (S Z) where - selectionsV (Cons x xs) - = [(x, Nil, Cons)] - permutationsV (Cons x Nil) - = [(Cons x Nil, id)] - -instance Permutable (S n) => Permutable (S (S n)) where - selectionsV (Cons x xs) = - (x, xs, Cons) : [ (y, Cons x ys, unselect unSel) - | (y, ys, unSel) <- selectionsV xs ] - where - unselect :: (a -> Vec n a -> Vec (S n) a) - -> (a -> Vec (S n) a -> Vec (S (S n)) a) - unselect f y' (Cons x' ys') = Cons x' (f y' ys') - - permutationsV xs = - [ (Cons y zs, \(Cons y' zs') -> unSel y' (unPerm zs')) - | (y, ys, unSel) <- selectionsV xs, - (zs, unPerm) <- permutationsV ys ] - -{- Vector list repreentation where the size 'n' is existential quantified -} -data VecList a where VL :: (IsNatural n, Permutable n) => [Vec n a] -> VecList a - --- Lists existentially quanitify over a vector's size : Exists n . Vec n a -data List a where - List :: (IsNatural n, Permutable n) => Vec n a -> List a - -lnil :: List a -lnil = List Nil -lcons :: a -> List a -> List a -lcons x (List Nil) = List (Cons x Nil) -lcons x (List (Cons y Nil)) = List (Cons x (Cons y Nil)) -lcons x (List (Cons y (Cons z xs))) = List (Cons x (Cons y (Cons z xs))) - -fromList :: [a] -> List a -fromList = foldr lcons lnil - --- pre-condition: the input is a 'rectangular' list of lists (i.e. all internal --- lists have the same size) -fromLists :: [[Int]] -> VecList Int -fromLists [] = VL ([] :: [Vec Z Int]) -fromLists (xs:xss) = consList (fromList xs) (fromLists xss) - where - consList :: List Int -> VecList Int -> VecList Int - consList (List vec) (VL []) = VL [vec] - consList (List vec) (VL (x:xs)) - = let (vec', x') = zipVec vec x - in -- Force the pre-condition equality - case (preCondition x' xs, preCondition vec' xs) of - (ReflEq, ReflEq) -> VL (vec' : (x' : xs)) - - where -- At the moment the pre-condition is 'assumed', and therefore - -- force used unsafeCoerce: TODO, rewrite - preCondition :: Vec n a -> [Vec n1 a] -> EqT n n1 - preCondition xs x = unsafeCoerce ReflEq - --- Equality type -data EqT (a :: k) (b :: k) where - ReflEq :: EqT a a -- Local variables: -- mode: haskell 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 @@ -31,24 +31,22 @@ import Camfort.Analysis.CommentAnnotator import Camfort.Specification.Stencils.InferenceBackend +import Camfort.Specification.Stencils.Model import Camfort.Specification.Stencils.Syntax -import Camfort.Specification.Stencils.Annotation +import Camfort.Specification.Stencils.Annotation () import qualified Camfort.Specification.Stencils.Grammar as Gram import qualified Camfort.Specification.Stencils.Synthesis as Synth import Camfort.Analysis.Annotations -import Camfort.Helpers.Vec -import Camfort.Helpers (collect) +import Camfort.Helpers (collect, descendReverseM, descendBiReverseM) +import qualified Camfort.Helpers.Vec as V import Camfort.Input -import qualified Camfort.Output as O 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.Analysis.BBlocks as FAB import qualified Language.Fortran.Analysis.DataFlow as FAD import qualified Language.Fortran.Util.Position as FU -import qualified Language.Fortran.Util.SecondParameter as FUS import Data.Data import Data.Foldable @@ -58,7 +56,6 @@ import qualified Data.IntMap as IM import qualified Data.Set as S import Data.Maybe -import Data.List import Debug.Trace -- Define modes of interaction with the inference @@ -70,8 +67,9 @@ defaultValue = AssignMode data InferState = IS { - ivMap :: FAD.InductionVarMapByASTBlock, - hasSpec :: [(FU.SrcSpan, Variable)] } + ivMap :: FAD.InductionVarMapByASTBlock + , hasSpec :: [(FU.SrcSpan, Variable)] + , visitedNodes :: [Int]} -- The inferer returns information as a LogLine @@ -89,7 +87,7 @@ -> Inferer a -> (a, [LogLine]) runInferer ivmap flTo = - flip evalState (IS ivmap []) + flip evalState (IS ivmap [] []) . flip runReaderT flTo . runWriterT @@ -99,23 +97,19 @@ -> F.ProgramFile (FA.Analysis A) -> (F.ProgramFile (FA.Analysis A), [LogLine]) stencilInference nameMap mode marker pf = - (F.ProgramFile mi cm_pus' blocks', log1 ++ log2) + (F.ProgramFile mi pus', log1) where -- Parse specification annotations and include them into the syntax tree -- that way if generate specifications at the same place we can -- decide whether to synthesise or not -- TODO: might want to output log0 somehow (though it doesn't fit LogLine) - (pf'@(F.ProgramFile mi cm_pus blocks), log0) = + (pf'@(F.ProgramFile mi pus), log0) = if mode == Synth then runWriter (annotateComments Gram.specParser pf) else (pf, []) - (cm_pus', log1) = runWriter (transformBiM perPU cm_pus) - (blocks', log2) = runInferer ivMap flTo blocksInf - blocksInf = let ?flowsGraph = flTo - ?nameMap = nameMap - in descendBiM (perBlockInfer mode marker) blocks + (pus', log1) = runWriter (transformBiM perPU pus) -- Run inference per program unit, placing the flowsmap in scope perPU :: F.ProgramUnit (FA.Analysis A) @@ -160,8 +154,9 @@ -> [F.Block (FA.Analysis A)] -> Inferer [([Variable], Specification)] genSpecsAndReport mode span lhs blocks = do - (IS ivmap _) <- get - let (specs, evalInfos) = runWriter $ genSpecifications ivmap lhs blocks + (IS ivmap _ _) <- get + let ((specs, visited), evalInfos) = runWriter $ genSpecifications ivmap lhs blocks + modify (\state -> state { visitedNodes = (visitedNodes state) ++ visited }) tell [ (span, Left specs) ] if mode == EvalMode then do @@ -175,16 +170,24 @@ return specs else return specs + + -- Match expressions which are array subscripts, returning Just of their -- index expressions, else Nothing isArraySubscript :: F.Expression (FA.Analysis A) -> Maybe [F.Index (FA.Analysis A)] isArraySubscript (F.ExpSubscript _ _ (F.ExpValue _ _ (F.ValVariable _)) subs) = Just $ F.aStrip subs -isArraySubscript (F.ExpDataRef _ _ _ e) = isArraySubscript e +isArraySubscript (F.ExpDataRef _ _ e e') = do + isArraySubscript e <++> isArraySubscript e' + where + Nothing <++> Nothing = Nothing + Nothing <++> Just xs = Just xs + Just xs <++> Nothing = Just xs + Just xs <++> Just ys = Just (xs ++ ys) isArraySubscript _ = Nothing -fromJustMsg msg (Just x) = x +fromJustMsg _ (Just x) = x fromJustMsg msg Nothing = error msg -- Traverse Blocks in the AST and infer stencil specifications @@ -192,7 +195,7 @@ => InferMode -> Char -> F.Block (FA.Analysis A) -> Inferer (F.Block (FA.Analysis A)) -perBlockInfer Synth _ b@(F.BlComment ann span _) = do +perBlockInfer Synth _ b@(F.BlComment ann _ _) = do -- If we have a comment that is actually a specification then record that -- this has been assigned so that we don't generate extra specifications -- that overlap with user-given oones @@ -203,37 +206,45 @@ (Just (Left (Gram.SpecDec _ vars)), Just block) -> -- Is the block an assignment case block of - s@(F.BlStatement _ span _ assg@(F.StExpressionAssign _ _ _ _)) -> do + F.BlStatement _ span _ F.StExpressionAssign{} -> do -- Then update the list of spans+vars that have specifications state <- get put (state { hasSpec = hasSpec state ++ zip (repeat span) vars }) _ -> return () return b -perBlockInfer mode marker b@(F.BlStatement ann span@(FU.SrcSpan lp up) _ stmnt) +perBlockInfer mode marker b@(F.BlStatement ann span@(FU.SrcSpan lp _) _ stmnt) | mode == AssignMode || mode == CombinedMode || mode == EvalMode || mode == Synth = do - -- On all StExpressionAssigns that occur in stmt.... - let lhses = [lhs | (F.StExpressionAssign _ _ lhs _) + + (IS ivmap hasSpec visitedStmts) <- get + let label = fromMaybe (-1) (FA.insLabel ann) + if (label `elem` visitedStmts) + then -- This statement has been part of a visited dataflow path + return b + else do + -- On all StExpressionAssigns that occur in stmt.... + let lhses = [lhs | (F.StExpressionAssign _ _ lhs _) <- universe stmnt :: [F.Statement (FA.Analysis A)]] - (IS ivmap hasSpec) <- get - specs <- flip mapM lhses - -- ... apply the following: - (\lhs -> do - case isArraySubscript lhs of - Just subs -> - -- Left-hand side is a subscript-by relative index or by a range - case neighbourIndex ivmap subs of - Just lhs -> genSpecsAndReport mode span lhs [b] - Nothing -> if mode == EvalMode - then do - tell [(span , Right ("EVALMODE: LHS is an array\ - \ subscript we can't handle \ - \(tag: LHSnotHandled)",""))] - return [] - else return [] - -- Not an assign we are interested in - _ -> return []) - if mode == Synth && not (null specs) && specs /= [[]] + specs <- forM lhses $ \lhs -> do + -- ... apply the following: + case lhs of + -- Assignment to a variable + (F.ExpValue _ _ (F.ValVariable v)) -> genSpecsAndReport mode span [] [b] + _ -> case isArraySubscript lhs of + Just subs -> + -- Left-hand side is a subscript-by relative index or by a range + case neighbourIndex ivmap subs of + Just lhs -> genSpecsAndReport mode span lhs [b] + Nothing -> if mode == EvalMode + then do + tell [(span , Right ("EVALMODE: LHS is an array\ + \ subscript we can't handle \ + \(tag: LHSnotHandled)",""))] + return [] + else return [] + -- Not an assign we are interested in + _ -> return [] + if mode == Synth && not (null specs) && specs /= [[]] then let specComment = Synth.formatSpec (Just (tabs ++ '!':marker:" ")) ?nameMap (span, Left (concat specs')) specs' = map (mapMaybe noSpecAlready) specs @@ -247,73 +258,104 @@ (FU.SrcSpan loc _) = span span' = FU.SrcSpan (lp {FU.posColumn = 0}) (lp {FU.posColumn = 0}) ann' = ann { FA.prevAnnotation = (FA.prevAnnotation ann) { refactored = Just loc } } - in return $ F.BlComment ann' span' specComment + in return $ F.BlComment ann' span' (F.Comment specComment) else return b perBlockInfer mode marker b@(F.BlDo ann span lab cname lab' mDoSpec body tlab) = do - -- introduce any induction variables into the induction variable state - if (mode == DoMode || mode == CombinedMode) && isStencilDo b then genSpecsAndReport mode span [] body else return [] - -- descend into the body of the do-statement - body' <- mapM (descendBiM (perBlockInfer mode marker)) body - -- Remove any induction variable from the state + -- descend into the body of the do-statement (in reverse order) + body' <- mapM (descendBiReverseM (perBlockInfer mode marker)) (reverse body) return $ F.BlDo ann span lab cname lab' mDoSpec body' tlab perBlockInfer mode marker b = do -- Go inside child blocks - b' <- descendM (descendBiM (perBlockInfer mode marker)) $ b + b' <- descendReverseM (descendBiReverseM (perBlockInfer mode marker)) $ b return b' +-- Combiantor for reducing a map with effects and partiality inside +-- into an effectful list of key-value pairs +assocsSequence :: Monad m => M.Map k (m (Maybe a)) -> m [(k, a)] +assocsSequence maps = do + assocs <- sequence . map strength . M.toList $ maps + return . catMaybes . map strength $ assocs + where + strength :: Monad m => (a, m b) -> m (a, b) + strength (a, mb) = mb >>= (\b -> return (a, b)) + genSpecifications :: Params => FAD.InductionVarMapByASTBlock -> [Neighbour] -> [F.Block (FA.Analysis A)] - -> Writer EvalLog [([Variable], Specification)] + -> Writer EvalLog ([([Variable], Specification)], [Int]) genSpecifications ivs lhs blocks = do - let subscripts = evalState (mapM (genSubscripts True) blocks) [] - varToMaybeSpecs <- sequence . map strength . mkSpecs $ subscripts - let varToSpecs = catMaybes . map strength $ varToMaybeSpecs + let (subscripts, visitedNodes) = subscriptsOnRhs ?nameMap blocks + varToSpecs <- assocsSequence $ mkSpecs subscripts case varToSpecs of [] -> do tell [("EVALMODE: Empty specification (tag: emptySpec)", "")] - return [] + return ([], visitedNodes) _ -> do let varsToSpecs = groupKeyBy varToSpecs - return $ splitUpperAndLower varsToSpecs + return (splitUpperAndLower varsToSpecs, visitedNodes) where - mkSpecs = M.toList - . M.mapWithKey (\v -> indicesToSpec ivs v lhs) - . M.unionsWith (++) + mkSpecs = M.mapWithKey (\v -> indicesToSpec ivs v lhs) splitUpperAndLower = concatMap splitUpperAndLower' - splitUpperAndLower' (vs, Specification (Multiple (Bound (Just l) (Just u)))) = - [(vs, Specification (Multiple (Bound (Just l) Nothing))), - (vs, Specification (Multiple (Bound Nothing (Just u))))] - splitUpperAndLower' (vs, Specification (Single (Bound (Just l) (Just u)))) = - [(vs, Specification (Single (Bound (Just l) Nothing))), - (vs, Specification (Single (Bound Nothing (Just u))))] + splitUpperAndLower' (vs, Specification (Mult (Bound (Just l) (Just u)))) + | isUnit l = + [(vs, Specification (Mult (Bound Nothing (Just u))))] + | otherwise = + [(vs, Specification (Mult (Bound (Just l) Nothing))), + (vs, Specification (Mult (Bound Nothing (Just u))))] + splitUpperAndLower' (vs, Specification (Once (Bound (Just l) (Just u)))) + | isUnit l = + [(vs, Specification (Mult (Bound Nothing (Just u))))] + | otherwise = + [(vs, Specification (Once (Bound (Just l) Nothing))), + (vs, Specification (Once (Bound Nothing (Just u))))] splitUpperAndLower' x = [x] +{-| subscriptsOnRhs + Takes * a name map + * a list of blocks representing an RHS + Returns a map from array variables to indices, and a list of + nodes that were visited when computing this information -} +subscriptsOnRhs :: Params + => FAR.NameMap + -> [F.Block (FA.Analysis A)] + -> (M.Map Variable [[F.Index (FA.Analysis A)]], [Int]) +subscriptsOnRhs nameMap blocks = + (subscripts', visitedNodes) + where + (maps, visitedNodes) = runState (mapM (genSubscripts True) blocks) [] + subscripts = M.unionsWith (++) maps + subscripts' = filterOutFuns ?nameMap subscripts + genOffsets :: Params => FAD.InductionVarMapByASTBlock -> [Neighbour] -> [F.Block (FA.Analysis A)] -> Writer EvalLog [(Variable, (Bool, [[Int]]))] genOffsets ivs lhs blocks = do - let subscripts = evalState (mapM (genSubscripts True) blocks) [] - varToMaybeSpecs <- sequence . map strength . mkOffsets $ subscripts - return $ catMaybes . map strength $ varToMaybeSpecs + let (subscripts, _) = subscriptsOnRhs ?nameMap blocks + assocsSequence $ mkOffsets subscripts where - mkOffsets = M.toList - . M.mapWithKey (\v -> indicesToRelativisedOffsets ivs v lhs) - . M.unionsWith (++) + mkOffsets = M.mapWithKey (\v -> indicesToRelativisedOffsets ivs v lhs) -strength :: Monad m => (a, m b) -> m (a, b) -strength (a, mb) = mb >>= (\b -> return (a, b)) +-- Filter out any variable names which do not appear in the name map or +-- which in appear in the name map with the same name, indicating they +-- are an instric function, e.g., abs +filterOutFuns nameMap m = + M.filterWithKey (\k _ -> + case k `M.lookup` nameMap of + Nothing -> False + Just k' | k == k' -> False + _ -> True) m + -- Generate all subscripting expressions (that are translations on -- induction variables) that flow to this block -- The State monad provides a list of the visited nodes so far @@ -326,7 +368,7 @@ -- Don't pull dependencies through arrays = return M.empty -genSubscripts top block = do +genSubscripts _ block = do visited <- get case (FA.insLabel $ F.getAnnotation block) of @@ -353,13 +395,12 @@ where -- Any occurence of an subscript "modulo(e, e')" is replaced with "e" replaceModulo :: F.Expression (FA.Analysis A) -> F.Expression (FA.Analysis A) - replaceModulo e@(F.ExpSubscript _ _ - (F.ExpValue _ _ (F.ValVariable "modulo")) subs) = + replaceModulo e@(F.ExpFunctionCall _ _ + (F.ExpValue _ _ (F.ValIntrinsic iname)) subs) + | iname `elem` ["modulo", "mod", "amod", "dmod"] -- We expect that the first parameter to modulo is being treated -- as an IxSingle element - case (head $ F.aStrip subs) of - (F.IxSingle _ _ _ e') -> e' - _ -> e + , Just (F.Argument _ _ _ e':_) <- fmap F.aStrip subs = e' replaceModulo e = e genRHSsubscripts' b = @@ -375,7 +416,7 @@ getInductionVar _ = [] isStencilDo :: F.Block (FA.Analysis A) -> Bool -isStencilDo b@(F.BlDo _ span _ _ _ mDoSpec body _) = +isStencilDo (F.BlDo _ _ _ _ _ mDoSpec body _) = -- Check to see if the body contains any affine use of the induction variable -- as a subscript case getInductionVar mDoSpec of @@ -459,15 +500,16 @@ relativiseRHS _ rhses = rhses relativiseBy v i (Neighbour u j) | v == u = Neighbour u (j - i) - -- RHS is a range, map it to constant - relativiseBy v i (Neighbour "" j) = Constant (F.ValInteger "") relativiseBy _ _ x = x -- Check that induction variables are used consistently consistentIVSuse :: [Neighbour] -> [[Neighbour]] -> Bool -consistentIVSuse lhs [] = True +consistentIVSuse [] _ = True +consistentIVSuse _ [] = True consistentIVSuse lhs rhses = - consistentRHS /= Nothing && (all consistentWithLHS (fromJust consistentRHS)) + rhsBasis /= Nothing -- There is a consitent RHS + && (all (`consistentWith` lhs) (fromJust rhsBasis) + || all (`consistentWith` (fromJust rhsBasis)) lhs) where cmp (Neighbour v i) (Neighbour v' _) | v == v' = Just $ Neighbour v i | otherwise = Nothing @@ -477,25 +519,25 @@ cmp (NonNeighbour {}) (Neighbour {}) = Nothing cmp (Neighbour {}) (NonNeighbour{}) = Nothing cmp _ _ = Just $ Constant (F.ValInteger "") - consistentRHS = foldrM (\a b -> mapM (uncurry cmp) $ zip a b) (head rhses) (tail rhses) + rhsBasis = foldrM (\a b -> mapM (uncurry cmp) $ zip a b) (head rhses) (tail rhses) -- If there is an induction variable on the RHS, then it also occurs on -- the LHS - consistentWithLHS :: Neighbour -> Bool - consistentWithLHS (Neighbour rv _) = any (matchesIV rv) lhs - consistentWithLHS _ = True + consistentWith :: Neighbour -> [Neighbour] -> Bool + consistentWith (Neighbour rv _) ns = any (matchesIV rv) ns + consistentWith _ _ = True matchesIV :: Variable -> Neighbour -> Bool matchesIV v (Neighbour v' _) | v == v' = True -- All RHS to contain index ranges - matchesIV v (Neighbour v' _) | v == "" = True - matchesIV v (Neighbour v' _) | v' == "" = True + matchesIV v Neighbour{} | v == "" = True + matchesIV _ (Neighbour v' _) | v' == "" = True matchesIV _ _ = False -- Convert list of relative offsets to a spec relativeIxsToSpec :: [[Int]] -> Maybe Specification relativeIxsToSpec ixs = if isEmpty exactSpec then Nothing else Just exactSpec - where exactSpec = inferFromIndicesWithoutLinearity . fromLists $ ixs + where exactSpec = inferFromIndicesWithoutLinearity . V.fromLists $ ixs isNeighbour :: Data a => F.Index (FA.Analysis a) -> [Variable] -> Bool isNeighbour exp vs = @@ -548,8 +590,8 @@ ixsspan (F.IxRange _ sp _ _ _) = sp ixsspan (F.IxSingle _ sp _ _ ) = sp -ixToNeighbour' ivs (F.IxRange _ _ Nothing Nothing Nothing) = Neighbour "" 0 -ixToNeighbour' ivs (F.IxRange _ _ Nothing Nothing +ixToNeighbour' _ (F.IxRange _ _ Nothing Nothing Nothing) = Neighbour "" 0 +ixToNeighbour' _ (F.IxRange _ _ Nothing Nothing (Just (F.ExpValue _ _ (F.ValInteger "1")))) = Neighbour "" 0 ixToNeighbour' ivs (F.IxSingle _ _ _ exp) = expToNeighbour ivs exp @@ -564,7 +606,7 @@ | FA.varName e `elem` ivs = Neighbour (FA.varName e) 0 | otherwise = Constant (fmap (const ()) v) -expToNeighbour ivs (F.ExpValue _ _ val) = Constant (fmap (const ()) val) +expToNeighbour _ (F.ExpValue _ _ val) = Constant (fmap (const ()) val) expToNeighbour ivs (F.ExpBinary _ _ F.Addition e@(F.ExpValue _ _ (F.ValVariable _)) 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 @@ -22,202 +22,387 @@ -} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE MultiWayIf #-} -module Camfort.Specification.Stencils.Model where +module Camfort.Specification.Stencils.Model ( Interval(..) + , Bound(..) + , approxVec + , Offsets(..) + , UnionNF + , vecLength + , unfCompare + , optimise + , maximas + , Approximation(..) + , lowerBound, upperBound + , fromExact + , Multiplicity(..) + , Peelable(..) + ) where -import Camfort.Specification.Stencils.Syntax -import Data.Set hiding (map,foldl',(\\)) -import qualified Data.Set as Set -import Data.List -import qualified Data.List as DL -import qualified Data.Map as DM +import qualified Control.Monad as CM -{-| This function maps inner representation to a set of vectors of length -- given by `dim`. This is the mathematical representation of the -- specification. |-} -model :: Multiplicity (Approximation Spatial) - -> Int - -> Multiplicity (Approximation (Set [Int])) -model s dims = - let ?globalDimensionality = dims - in mkModel s +import Algebra.Lattice +import Data.Semigroup +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as S +import Data.Foldable +import Data.SBV +import Data.Data +import Data.List (sortBy, nub) +import Data.Maybe (fromJust) +import qualified Data.PartialOrd as PO -consistent :: Multiplicity [[Int]] - -> Multiplicity (Approximation Spatial) - -> Bool --- If the specification says "readOnce" but there are duplicates among --- offsets, then there is no consistency. --- --- Note that if the spec omits "readOnce" and the offsets happen to be --- unique that is allowed as "readOnce" is an extra qualifier. -consistent (Multiple _) (Single _) = False -consistent mult1 spec = - consistent' (model spec dimensionality) - where - dimensionality = length . head $ accesses - consistent' m2 = - case fromMult m2 of - Exact unifiers -> - consistent' (Multiple (Bound Nothing (Just unifiers))) && - consistent' (Multiple (Bound (Just unifiers) Nothing)) - Bound lus@Just{} uus@Just{} -> - consistent' (Multiple (Bound lus Nothing)) && - consistent' (Multiple (Bound Nothing uus)) - Bound Nothing (Just unifiers) -> - all (\access -> any (access `accepts`) unifiers) accesses - Bound (Just unifiers) Nothing -> - all (\unifier -> any (`accepts` unifier) accesses) unifiers +import qualified Camfort.Helpers.Vec as V +import System.IO.Unsafe +import Debug.Trace - accesses = fromMult mult1 +-- Utility container +class Container a where + type MemberTyp a + type CompTyp a - access `accepts` unifier = - all (\(u,v) -> v == absoluteRep || u == v) (zip access unifier) + member :: MemberTyp a -> a -> Bool + compile :: a -> (CompTyp a -> SBool) --- Recursive `Model` class implemented for all parts of the spec. -class Model spec where - type Domain spec +-------------------------------------------------------------------------------- +-- Arbitrary sets representing offsets +-------------------------------------------------------------------------------- - -- generate model for the specification, where the implicit - -- parameter ?globalDimensionality is the global dimensionality - -- for the spec (not just the local maximum dimensionality) - mkModel :: (?globalDimensionality :: Int) => spec -> Domain spec +data Offsets = + Offsets (S.Set Int64) + | SetOfIntegers + deriving Eq - -- Return the maximum dimension specified in the spec - -- giving the dimensionality for that specification - dimensionality :: spec -> Int - dimensionality = maximum . dimensions - -- Return all the dimensions specified for in this spec - dimensions :: spec -> [Int] +instance Ord Offsets where + Offsets s `compare` Offsets s' = s `compare` s' + Offsets _ `compare` SetOfIntegers = LT + SetOfIntegers `compare` Offsets _ = GT + SetOfIntegers `compare` SetOfIntegers = EQ --- Set representation where multiplicities are (-1) modulo 2 --- that is, False = multiplicity 1, True = multiplicity > 1 -instance Model Specification where - type Domain Specification = Multiplicity (Approximation (Set [Int])) +instance Container Offsets where + type MemberTyp Offsets = Int64 + type CompTyp Offsets = SInt64 - mkModel (Specification s) = mkModel s + member i (Offsets s) = i `S.member` s + member _ _ = True - dimensionality (Specification s) = dimensionality s + compile (Offsets s) i = i `sElem` map fromIntegral (S.toList s) + compile SetOfIntegers _ = true - dimensions (Specification s) = dimensions s +instance JoinSemiLattice Offsets where + (Offsets s) \/ (Offsets s') = Offsets $ s `S.union` s' + _ \/ _ = SetOfIntegers -instance Model (Multiplicity (Approximation Spatial)) where - type Domain (Multiplicity (Approximation Spatial)) = - Multiplicity (Approximation (Set [Int])) +instance MeetSemiLattice Offsets where + (Offsets s) /\ (Offsets s') = Offsets $ s `S.intersection` s' + off@Offsets{} /\ _ = off + _ /\ o = o - mkModel (Multiple s) = Multiple (mkModel s) - mkModel (Single s) = Single (mkModel s) +instance Lattice Offsets - dimensionality mult = dimensionality $ fromMult mult +instance BoundedJoinSemiLattice Offsets where + bottom = Offsets S.empty - dimensions mult = dimensions $ fromMult mult +instance BoundedMeetSemiLattice Offsets where + top = SetOfIntegers -instance Model (Approximation Spatial) where - type Domain (Approximation Spatial) = Approximation (Set [Int]) +instance BoundedLattice Offsets - mkModel = fmap mkModel - dimensionality (Exact s) = dimensionality s - dimensionality (Bound l u) = dimensionality l `max` dimensionality u +-------------------------------------------------------------------------------- +-- Interval as defined in the paper +-------------------------------------------------------------------------------- - dimensions (Exact s) = dimensions s - dimensions (Bound l u) = dimensions l ++ dimensions u +data Bound = Arbitrary | Standard --- Lifting of model to Maybe type -instance Model a => Model (Maybe a) where - type Domain (Maybe a) = Maybe (Domain a) +-- | Interval data structure assumes the following: +-- 1. The first num. param. is less than the second; +-- 2. For holed intervals, first num. param. <= 0 <= second num. param.; +data Interval a where + IntervArbitrary :: Int -> Int -> Interval Arbitrary + IntervInfiniteArbitrary :: Interval Arbitrary + IntervHoled :: Int64 -> Int64 -> Bool -> Interval Standard + IntervInfinite :: Interval Standard - mkModel Nothing = Nothing - mkModel (Just x) = Just (mkModel x) +deriving instance Eq (Interval a) - dimensions Nothing = [0] - dimensions (Just x) = dimensions x +instance Show (Interval Standard) where + show IntervInfinite = "IntervInfinite" + show (IntervHoled lb up p) = + "Interv [" ++ show lb ++ "," ++ show up ++ "]^" ++ show p --- Core part of the model -instance Model Spatial where - type Domain Spatial = Set [Int] +approxInterv :: Interval Arbitrary -> Approximation (Interval Standard) +approxInterv (IntervArbitrary a b) + | a > b = error + "Interval condition violated: lower bound is bigger than the upper bound." + | a <= 0, b >= 0 = Exact $ IntervHoled a' b' True + | a <= -1, b == -1 = Exact $ IntervHoled a' 0 False + | a == 1, b >= 1 = Exact $ IntervHoled 0 b' False + | a > 1, b > 1 = Bound Nothing $ Just $ IntervHoled 0 b' False + | a < -1, b < -1 = Bound Nothing $ Just $ IntervHoled a' 0 False + | otherwise = error "Impossible: All posibilities are covered." + where + a' = fromIntegral a + b' = fromIntegral b +approxInterv IntervInfiniteArbitrary = Exact IntervInfinite - mkModel (Spatial s) = mkModel s +approxVec :: forall n . + V.Vec n (Interval Arbitrary) + -> Approximation (V.Vec n (Interval Standard)) +approxVec v = + case findApproxIntervs stdVec of + ([],_) -> Exact . fmap fromExact $ stdVec + _ -> Bound Nothing (Just $ upperBound <$> stdVec) + where + stdVec :: V.Vec n (Approximation (Interval Standard)) + stdVec = fmap approxInterv v - dimensionality (Spatial s) = dimensionality s + findApproxIntervs :: forall n . V.Vec n (Approximation (Interval Standard)) + -> ([ Int ], [ Int ]) + findApproxIntervs v = findApproxIntervs' 0 v ([],[]) - dimensions (Spatial s) = dimensions s + findApproxIntervs' :: forall n . Int + -> V.Vec n (Approximation (Interval Standard)) + -> ([ Int ], [ Int ]) + -> ([ Int ], [ Int ]) + findApproxIntervs' _ V.Nil acc = acc + findApproxIntervs' i (V.Cons x xs) (bixs, eixs) = + findApproxIntervs' (i+1) xs $ + case x of + Bound{} -> (i:bixs, eixs) + Exact{} -> (bixs, i:eixs) +instance Container (Interval Standard) where + type MemberTyp (Interval Standard) = Int64 + type CompTyp (Interval Standard) = SInt64 -instance Model RegionSum where - type Domain RegionSum = Set [Int] - mkModel (Sum ss) = unions (map mkModel ss) - dimensionality (Sum ss) = - maximum1 (map dimensionality ss) + member 0 (IntervHoled _ _ b) = b + member i (IntervHoled a b _) = i >= a && i <= b + member _ _ = True - dimensions (Sum ss) = concatMap dimensions ss + compile (IntervHoled i1 i2 b) i + | b = inRange i range + | otherwise = inRange i range &&& i ./= 0 + where + range = (fromIntegral i1, fromIntegral i2) + compile IntervInfinite _ = true +instance JoinSemiLattice (Interval Standard) where + (IntervHoled lb ub noHole) \/ (IntervHoled lb' ub' noHole') = + IntervHoled (min lb lb') (max ub ub') (noHole || noHole') + _ \/ _ = top -instance Model Region where - type Domain Region = Set [Int] +instance MeetSemiLattice (Interval Standard) where + (IntervHoled lb ub noHole) /\ (IntervHoled lb' ub' noHole') = + IntervHoled (max lb lb') (min ub ub') (noHole && noHole') + int@IntervHoled{} /\ _ = int + _ /\ int = int - mkModel (Forward dep dim reflx) = fromList - [mkSingleEntryNeg i dim ?globalDimensionality | i <- [i0..dep]] - where i0 = if reflx then 0 else 1 +instance Lattice (Interval Standard) - mkModel (Backward dep dim reflx) = fromList - [mkSingleEntryNeg i dim ?globalDimensionality | i <- [(-dep)..i0]] - where i0 = if reflx then 0 else -1 +instance BoundedJoinSemiLattice (Interval Standard) where + bottom = IntervHoled 0 0 False - mkModel (Centered dep dim reflx) = fromList - [mkSingleEntryNeg i dim ?globalDimensionality | i <- [(-dep)..dep] \\ i0] - where i0 = if reflx then [] else [0] +instance BoundedMeetSemiLattice (Interval Standard) where + top = IntervInfinite - dimensionality (Forward _ d _) = d - dimensionality (Backward _ d _) = d - dimensionality (Centered _ d _) = d +instance BoundedLattice (Interval Standard) - dimensions (Forward _ d _) = [d] - dimensions (Backward _ d _) = [d] - dimensions (Centered _ d _) = [d] +-------------------------------------------------------------------------------- +-- Union of cartesian products normal form +-------------------------------------------------------------------------------- -mkSingleEntryNeg :: Int -> Int -> Int -> [Int] -mkSingleEntryNeg i 0 ds = error "Dimensions are 1-indexed" -mkSingleEntryNeg i 1 ds = i : replicate (ds - 1) absoluteRep -mkSingleEntryNeg i d ds = absoluteRep : mkSingleEntryNeg i (d - 1) (ds - 1) +type UnionNF n a = NE.NonEmpty (V.Vec n a) -instance Model RegionProd where - type Domain RegionProd = Set [Int] +vecLength :: UnionNF n a -> V.Natural n +vecLength = V.lengthN . NE.head - mkModel (Product []) = Set.empty - mkModel (Product [s]) = mkModel s - mkModel p@(Product ss) = cleanedProduct - where - cleanedProduct = fromList $ DL.filter keepPred product - product = cprodVs $ map (toList . mkModel) ss - dims = dimensions p - keepPred el = DL.foldr (\pr acc -> nonProdP pr && acc) True (zip [(1::Int)..] el) - nonProdP (i,el) = i `notElem` dims || el /= absoluteRep +instance Container a => Container (UnionNF n a) where + type MemberTyp (UnionNF n a) = V.Vec n (MemberTyp a) + type CompTyp (UnionNF n a) = V.Vec n (CompTyp a) + member is = any (member' is) + where + member' is space = and $ V.zipWith member is space - dimensionality (Product ss) = - maximum1 (map dimensionality ss) - dimensions (Product ss) = - nub $ concatMap dimensions ss + compile spaces is = foldr1 (|||) $ NE.map (`compile'` is) spaces + where + compile' space is = + foldr' (\(set, i) -> (&&&) $ compile set i) true $ V.zip space is -tensor n s t = cleanedProduct - where - cleanedProduct = fromList $ DL.filter keepPred product - product = cprodV s t - keepPred el = DL.foldr (\pr acc -> nonProdP pr && acc) True (zip [(1::Int)..] el) - nonProdP (i,el) = i `notElem` [1..n] || el /= absoluteRep +instance JoinSemiLattice (UnionNF n a) where + oi \/ oi' = oi <> oi' --- Cartesian product on list of vectors4 -cprodVs :: [[[Int]]] -> [[Int]] -cprodVs = foldr1 cprodV +instance BoundedLattice a => MeetSemiLattice (UnionNF n a) where + (/\) = CM.liftM2 (V.zipWith (/\)) -cprodV :: [[Int]] -> [[Int]] -> [[Int]] -cprodV xss yss = xss >>= (\xs -> yss >>= pairwisePerm xs) +instance BoundedLattice a => Lattice (UnionNF n a) -pairwisePerm :: [Int] -> [Int] -> [[Int]] -pairwisePerm x y = sequence . transpose $ [x, y] +unfCompare :: forall a b n . ( Container a, Container b + , MemberTyp a ~ Int64, MemberTyp b ~ Int64 + , CompTyp a ~ SInt64, CompTyp b ~ SInt64 + ) + => UnionNF n a -> UnionNF n b -> Ordering +unfCompare oi oi' = unsafePerformIO $ do + thmRes <- prove pred + case thmRes of + -- Tell the user if there was a hard proof error (e.g., if + -- z3 is not installed/accessible). + -- TODO: give more information + ThmResult (ProofError _ msgs) -> fail $ unlines msgs + _ -> + if modelExists thmRes + then do + ce <- counterExample thmRes + case V.fromList ce of + V.VecBox cev -> + case V.proveEqSize (NE.head oi) cev of + Just V.ReflEq -> + -- TODO: The second branch is defensive programming the + -- member check is not necessary unless the counter example + -- is bogus (it shouldn't be). Delete if it adversely + -- effects the performance. + if | cev `member` oi -> return GT + | cev `member` oi' -> return LT + | otherwise -> fail + "Impossible: counter example is in \ + \neither of the operands" + Nothing -> fail + "Impossible: Counter example size doesn't \ + \match the original vector size." + else "EQ branch" `trace` return EQ + where + counterExample :: ThmResult -> IO [ Int64 ] + counterExample thmRes = + case getModel thmRes of + Right (False, ce) -> return ce + Right (True, _) -> fail "Returned probable model." + Left str -> fail str -maximum1 [] = 0 -maximum1 xs = maximum xs + pred :: Predicate + pred = do + freeVars <- (mkFreeVars . dimensionality) oi :: Symbolic [ SInt64 ] + case V.fromList freeVars of + V.VecBox freeVarVec -> + case V.proveEqSize (NE.head oi) freeVarVec of + Just V.ReflEq -> return $ + compile oi freeVarVec .== compile oi' freeVarVec + Nothing -> fail $ + "Impossible: Free variables size doesn't match that of the " ++ + "union parameter." + dimensionality = V.length . NE.head + +-------------------------------------------------------------------------------- +-- Optimise unions +-------------------------------------------------------------------------------- + +instance PO.PartialOrd Offsets where + (Offsets s) <= (Offsets s') = s <= s' + SetOfIntegers <= Offsets{} = False + _ <= SetOfIntegers = True + +instance PO.PartialOrd (Interval Standard) where + (IntervHoled lb ub p) <= (IntervHoled lb' ub' p') = + (p' || not p) && lb >= lb' && ub <= ub' + IntervInfinite <= IntervHoled{} = False + _ <= IntervInfinite = True + +instance PO.PartialOrd a => PO.PartialOrd (V.Vec n a) where + v <= v' = and $ V.zipWith (PO.<=) v v' + +optimise :: UnionNF n (Interval Standard) -> UnionNF n (Interval Standard) +optimise = NE.fromList . maximas . fixedPointUnion . NE.toList + where + fixedPointUnion unf = + let unf' = unionLemma . maximas $ unf + in if unf' == unf then unf' else fixedPointUnion unf' + +sensibleGroupBy :: Eq a => + (a -> a -> Ordering) + -> (a -> a -> Bool) + -> [ a ] + -> [ [ a ] ] +sensibleGroupBy ord p l = nub . map (\el -> sortBy ord . filter (p el) $ l) $ l + +maximas :: [ V.Vec n (Interval Standard) ] -> [ V.Vec n (Interval Standard) ] +maximas = nub + . fmap (head . PO.maxima) + . sensibleGroupBy ord (PO.<=) + where + ord a b = fromJust $ a `PO.compare` b + +-- | Union lemma says that if we have a product of intervals (as defined in +-- the paper) and we union two that agrees in each dimension except one. +-- The union is again a product of intervals that agrees with the original +-- dimensions in all dimensions except the original differing one. At that +-- point it is the union of intervals, which is itself still an interval. +unionLemma :: [ V.Vec n (Interval Standard) ] -> [ V.Vec n (Interval Standard) ] +unionLemma = map (foldr1 (V.zipWith (\/))) + . sensibleGroupBy (\a b -> if a == b then EQ else LT) agreeButOne + where + -- This function returns true if two vectors agree at all points but one. + -- It also holds if two vectors are identical. + agreeButOne :: Eq a => V.Vec n a -> V.Vec n a -> Bool + agreeButOne = go False + where + go :: Eq a => Bool -> V.Vec n a -> V.Vec n a -> Bool + go _ V.Nil V.Nil = True + go False (V.Cons x xs) (V.Cons y ys) + | x == y = go False xs ys + | otherwise = go True xs ys + go True (V.Cons x xs) (V.Cons y ys) + | x == y = go True xs ys + | otherwise = False + +-------------------------------------------------------------------------------- +-- Injections for multiplicity and exactness +-------------------------------------------------------------------------------- + +data Approximation a = Exact a | Bound (Maybe a) (Maybe a) + deriving (Eq, Show, Functor, Foldable, Traversable, Data, Typeable) + +fromExact :: Approximation a -> a +fromExact (Exact a) = a +fromExact _ = error "Can't retrieve from bounded as if it was exact." + +lowerBound :: Approximation a -> a +lowerBound (Bound (Just a) _) = a +lowerBound (Bound Nothing _) = error "Approximation doesn't have a lower bound." +lowerBound (Exact a) = a + +upperBound :: Approximation a -> a +upperBound (Bound _ (Just a)) = a +upperBound (Bound _ Nothing) = error "Approximation doesn't have a upper bound." +upperBound (Exact a) = a + +class Peelable a where + type CoreTyp a + peel :: a -> CoreTyp a + +data Multiplicity a = Mult a | Once a + deriving (Eq, Show, Functor, Foldable, Traversable, Data, Typeable) + +instance Peelable (Multiplicity a) where + type CoreTyp (Multiplicity a) = a + + peel (Mult a) = a + peel (Once a) = a + +{- +data Approximation a = Exact a | Lower a | Upper a + deriving (Eq, Show, Functor, Data, Typeable) + +instance Peelable Approximation where + peel (Exact a) = a + peel (Lower a) = a + peel (Upper a) = a +-} diff --git a/src/Camfort/Specification/Stencils/Syntax.hs b/src/Camfort/Specification/Stencils/Syntax.hs --- a/src/Camfort/Specification/Stencils/Syntax.hs +++ b/src/Camfort/Specification/Stencils/Syntax.hs @@ -19,11 +19,16 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE DeriveFunctor #-} module Camfort.Specification.Stencils.Syntax where import Camfort.Helpers +import Camfort.Specification.Stencils.Model ( Multiplicity(..) + , peel + , Approximation(..) + , lowerBound, upperBound + , fromExact + ) import Prelude hiding (sum) @@ -41,32 +46,13 @@ {- *** 0. Representations -} --- Representation of an inference result, either exact or with some bound -data Approximation a = - Exact a | Bound (Maybe a) (Maybe a) - deriving (Eq, Data, Typeable, Show) - -fromExact :: Approximation a -> a -fromExact (Exact a) = a -fromExact _ = error "Exception: fromExact on a non-exact result" - -upperBound :: a -> Approximation a -upperBound x = Bound Nothing (Just x) - -lowerBound :: a -> Approximation a -lowerBound x = Bound (Just x) Nothing - -instance Functor Approximation where - fmap f (Exact x) = Exact (f x) - fmap f (Bound x y) = Bound (fmap f x) (fmap f y) - -- 'absoluteRep' is an integer to use to represent absolute indexing expressions -- (which may be constants, non-affine indexing expressions, or expressions -- involving non-induction variables). This is set to maxBoound :: Int usually, -- but can be made smaller for debugging purposes, -- e.g., 100, but it needs to be high enough to clash with reasonable -- relative indices. -absoluteRep = 100 :: Int -- maxBound :: Int +absoluteRep = maxBound :: Int {- *** 1 . Specification syntax -} @@ -96,7 +82,7 @@ deriving (Eq, Data, Typeable) isEmpty :: Specification -> Bool -isEmpty (Specification mult) = isUnit . fromMult $ mult +isEmpty (Specification mult) = isUnit . peel $ mult -- ********************** -- Spatial specifications: @@ -119,20 +105,13 @@ hasDuplicates :: Eq a => [a] -> ([a], Bool) hasDuplicates xs = (nub xs, nub xs /= xs) -fromMult :: Multiplicity a -> a -fromMult (Multiple a) = a -fromMult (Single a) = a - setLinearity :: Linearity -> Specification -> Specification setLinearity l (Specification mult) - | l == Linear = Specification $ Single $ fromMult mult - | l == NonLinear = Specification $ Multiple $ fromMult mult + | l == Linear = Specification $ Once $ peel mult + | l == NonLinear = Specification $ Mult $ peel mult data Linearity = Linear | NonLinear deriving (Eq, Data, Typeable) -data Multiplicity a = Multiple a | Single a - deriving (Eq, Data, Typeable, Functor, Show) - type Dimension = Int -- spatial dimensions are 1 indexed type Depth = Int type IsRefl = Bool @@ -190,147 +169,6 @@ regionPlus x y | x == y = Just x regionPlus x y = Nothing -instance PartialMonoid RegionProd where - emptyM = Product [] - - appendM (Product []) s = Just s - appendM s (Product []) = Just s - appendM (Product [s]) (Product [s']) = - regionPlus s s' >>= (\sCombined -> return $ Product [sCombined]) - appendM (Product ss) (Product ss') - | ss == ss' = Just $ Product ss - | otherwise = - case absorbReflexive ss ss' of - Just (ss0, ss1) -> - case distAndOverlaps ss0 ss1 of - Just ss'' -> return $ Product $ sort ss'' - Nothing -> return $ Product $ sort (ss0 ++ ss1) - Nothing -> case distAndOverlaps ss ss' of - Just ss'' -> return $ Product $ sort ss'' - Nothing -> Nothing - ---Based on equations: --- Forward n d + Reflexive d = Forward n d --- Backward n d + Reflexive d = Backward n d --- Centered n d + Reflexive d = Centered n d --- (and so on for n-ary cases and Backward and Centered). - -absorbReflexive :: [Region] -> [Region] -> Maybe ([Region], [Region]) -absorbReflexive a b = - absorbReflexive' (sortBy cmpDims a) (sortBy cmpDims b) - <|> absorbReflexive' (sortBy cmpDims b) (sortBy cmpDims a) - where cmpDims = compare `on` getDimension - -absorbReflexive' [] [] = Just ([], []) -absorbReflexive' (Forward d dim reflx : rs) [Centered 0 dim' _] - | dim == dim' = Just (Forward d dim True:rs, []) - -absorbReflexive' (Backward d dim reflx : rs) [Centered 0 dim' _] - | dim == dim' = Just (Backward d dim True:rs, []) - -absorbReflexive' (Centered d dim reflx : rs) [Centered 0 dim' _] - | dim == dim' && d /= 0 = Just (Centered d dim True:rs, []) - -absorbReflexive' _ _ = Nothing - --- Implements a combination of (+DIST), (+COMM), and (OVERLAPS) -distAndOverlaps :: [Region] -> [Region] -> Maybe [Region] -distAndOverlaps x y = - if length x <= 1 || length y <= 1 - then Nothing - else -- (+COMM) - distAndOverlaps' x y <|> distAndOverlaps' y x - -distAndOverlaps' [] xs = Just xs -distAndOverlaps' xs [] = Just xs - --- F+F -distAndOverlaps' (Forward d dim refl : rs) (Forward d' dim' refl' : rs') - | rs == rs' && dim == dim' - = Just (Forward (max d d') dim (refl || refl') : rs) - --- B+B -distAndOverlaps' (Backward d dim refl : rs) (Backward d' dim' refl' : rs') - | rs == rs' && dim == dim' - = Just (Backward (max d d') dim (refl || refl') : rs) - --- C+C -distAndOverlaps' (Centered d dim refl : rs) (Centered d' dim' refl' : rs') - | rs == rs' && dim == dim' && d /= 0 && d' /= 0 - = Just (Centered (max d d') dim (refl || refl') : rs) - --- C+F -distAndOverlaps' (Forward d dim refl : rs) (Centered d' dim' refl' : rs') - | rs == rs' && dim == dim' && d <= d' && d' /= 0 - = Just (Centered d' dim (refl || refl') : rs) - --- C+B -distAndOverlaps' (Backward d dim refl : rs) (Centered d' dim' refl' : rs') - | rs == rs' && dim == dim' && d <= d' && d' /= 0 - = Just (Centered d' dim (refl || refl') : rs) - --- F+B -distAndOverlaps' (Forward d dim reflx : rs) (Backward d' dim' reflx' : rs') - | rs == rs' && d == d' && dim == dim' - = Just (Centered d dim (reflx || reflx') : rs) - --- C+R -distAndOverlaps' (Centered d dim reflx : rs) (Centered 0 dim' True : rs') - | rs == rs' && dim == dim' && d /= 0 - = Just (Centered d dim True : rs) - --- F+R -distAndOverlaps' (Forward d dim reflx : rs) (Centered 0 dim' True : rs') - | rs == rs' && dim == dim' - = Just (Forward d dim True : rs) - --- B+R -distAndOverlaps' (Backward d dim reflx : rs) (Centered 0 dim' True : rs') - | rs == rs' && dim == dim' - = Just (Backward d dim True : rs) - --- IRREFL B+!B -distAndOverlaps' p1@(Backward d1 dim1 refl1 : Backward d2 dim2 refl2 : rs) - p2@(Backward d1' dim1' refl1' : Backward d2' dim2' refl2' : rs') - | rs == rs' && dim1 == dim1' && dim2 == dim2' - && d1 == d1' && d2 == d2' && refl1 == not refl1' && refl2 == not refl2' - = Just $ [Backward d1 dim1 True, Backward d2 dim2 True] ++ rs - - | rs == rs' && dim1 == dim2' && dim2 == dim1' - && d1 == d2' && d2 == d1' && refl1 == not refl2' && refl2 == not refl1' - = Just $ [Backward d1 dim1 True, Backward d2 dim2 True] ++ rs - --- IRREFL C+!C -distAndOverlaps' p1@(Centered d1 dim1 refl1 : Centered d2 dim2 refl2 : rs) - p2@(Centered d1' dim1' refl1' : Centered d2' dim2' refl2' : rs') - | rs == rs' && dim1 == dim1' && dim2 == dim2' && (d1 * d2 * d1' * d2' /= 0) - && d1 == d1' && d2 == d2' && refl1 == not refl1' && refl2 == not refl2' - = Just $ [Centered d1 dim1 True, Centered d2 dim2 True] ++ rs - - | rs == rs' && dim1 == dim2' && dim2 == dim1' - && d1 == d2' && d2 == d1' && refl1 == not refl2' && refl2 == not refl1' - = Just $ [Centered d1 dim1 True, Centered d2 dim2 True] ++ rs - --- IRREFL F+!F -distAndOverlaps' p1@(Forward d1 dim1 refl1 : Forward d2 dim2 refl2 : rs) - p2@(Forward d1' dim1' refl1' : Forward d2' dim2' refl2' : rs') - | rs == rs' && dim1 == dim1' && dim2 == dim2' && (d1 * d2 * d1' * d2' /= 0) - && d1 == d1' && d2 == d2' && refl1 == not refl1' && refl2 == not refl2' - = Just $ [Forward d1 dim1 True, Forward d2 dim2 True] ++ rs - - | rs == rs' && dim1 == dim2' && dim2 == dim1' && (d1 * d2 * d1' * d2' /= 0) - && d1 == d2' && d2 == d1' && refl1 == not refl2' && refl2 == not refl1' - = Just $ [Forward d1 dim1 True, Forward d2 dim2 True] ++ rs - --- push any remaining idempotence through dist --- distAndOverlaps(r*s + r*s') = r*(distAndOverlaps (s + s')) -distAndOverlaps' (r:rs) (r':rs') - | r == r' = do rs'' <- distAndOverlaps rs rs' - return $ r : rs'' - -distAndOverlaps' _ _ = Nothing - - -- Operations on region specifications form a semiring -- where `sum` is the additive, and `prod` is the multiplicative -- [without the annihilation property for `zero` with multiplication] @@ -390,7 +228,7 @@ do (Product spec) <- ss (Product spec') <- ss' return $ Product $ nub $ sort $ spec ++ spec' - sum (Sum ss) (Sum ss') = Sum $ normalise $ ss ++ ss' + sum (Sum ss) (Sum ss') = Sum $ ss ++ ss' zero = Sum [] one = Sum [Product []] isUnit s@(Sum ss) = s == zero || s == one || all (== Product []) ss @@ -410,18 +248,20 @@ instance {-# OVERLAPS #-} Show (Multiplicity (Approximation Spatial)) where show mult - | Multiple appr <- mult = apprStr empty appr - | Single appr <- mult = apprStr "readOnce, " appr + | Mult appr <- mult = apprStr empty empty appr + | Once appr <- mult = apprStr "readOnce" ", " appr where - apprStr linearity appr = + apprStr linearity sep appr = case appr of - Exact s -> linearity ++ show s + Exact s -> linearity ++ optionalSeparator sep (show s) Bound Nothing Nothing -> "empty" - Bound Nothing (Just s) -> "atMost, " ++ linearity ++ show s - Bound (Just s) Nothing -> "atLeast, " ++ linearity ++ show s + Bound Nothing (Just s) -> "atMost, " ++ linearity ++ optionalSeparator sep (show s) + Bound (Just s) Nothing -> "atLeast, " ++ linearity ++ optionalSeparator sep (show s) Bound (Just sL) (Just sU) -> - "atLeast, " ++ linearity ++ show sL ++ - "; atMost, " ++ linearity ++ show sU + "atLeast, " ++ linearity ++ optionalSeparator sep (show sL) ++ + "; atMost, " ++ linearity ++ optionalSeparator sep (show sU) + optionalSeparator sep "" = "" + optionalSeparator sep s = sep ++ s instance {-# OVERLAPS #-} Show (Approximation Spatial) where show (Exact s) = show s @@ -459,13 +299,13 @@ show (Forward dep dim reflx) = showRegion "forward" dep dim reflx show (Backward dep dim reflx) = showRegion "backward" dep dim reflx show (Centered dep dim reflx) - | dep == 0 = "reflexive(dim=" ++ show dim ++ ")" + | dep == 0 = "pointed(dim=" ++ show dim ++ ")" | otherwise = showRegion "centered" dep dim reflx -- Helper for showing regions showRegion typ depS dimS reflx = typ ++ "(depth=" ++ show depS ++ ", dim=" ++ show dimS - ++ (if reflx then "" else ", irreflexive") + ++ (if reflx then "" else ", nonpointed") ++ ")" -- Helper for reassociating an association list, grouping the keys together that 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 @@ -20,34 +20,20 @@ module Camfort.Specification.Stencils.Synthesis where -import Data.Data import Data.List import Data.Maybe import qualified Data.Map as M -import Data.Generics.Uniplate.Operations -import Control.Monad.State.Lazy -import Control.Monad.Reader -import Control.Monad.Writer hiding (Product) -import Camfort.Specification.Stencils.InferenceBackend import Camfort.Specification.Stencils.Syntax -import Camfort.Specification.Stencils.Model import Camfort.Analysis.Annotations -import Camfort.Helpers.Vec --- These two are redefined here for ForPar ASTs -import Camfort.Helpers hiding (lineCol, spanLineCol) 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.Analysis.BBlocks as FAB -import qualified Language.Fortran.Analysis.DataFlow as FAD import qualified Language.Fortran.Util.Position as FU import Language.Fortran.Util.Position -import Data.Map hiding (map) -- Format inferred specifications formatSpec :: @@ -65,7 +51,7 @@ Nothing -> show span ++ " " Just pr -> pr -formatSpec prefix nm (span, Left []) = "" +formatSpec _ _ (_, Left []) = "" formatSpec prefix nm (span, Left specs) = (intercalate "\n" $ map (\s -> prefix' ++ doSpec s) specs) where diff --git a/src/Camfort/Specification/Units.hs b/src/Camfort/Specification/Units.hs --- a/src/Camfort/Specification/Units.hs +++ b/src/Camfort/Specification/Units.hs @@ -22,17 +22,24 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} module Camfort.Specification.Units - (checkUnits, inferUnits, synthesiseUnits, inferCriticalVariables) + (checkUnits, inferUnits, compileUnits, synthesiseUnits, inferCriticalVariables, chooseImplicitNames) where import qualified Data.Map.Strict as M +import Data.Data import Data.Char (isNumber) -import Data.List (intercalate) -import Data.Maybe (fromMaybe, maybeToList, listToMaybe, mapMaybe) +import Data.List (intercalate, find, sort, group, nub, inits) +import Data.Maybe (fromMaybe, maybeToList, listToMaybe, mapMaybe, isJust, maybe) +import Data.Binary import Data.Generics.Uniplate.Operations +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB import Control.Monad.State.Strict +import GHC.Generics (Generic) import Camfort.Helpers hiding (lineCol) import Camfort.Helpers.Syntax @@ -48,9 +55,11 @@ import Camfort.Specification.Units.Synthesis (runSynthesis) import qualified Language.Fortran.Analysis.Renaming as FAR +import qualified Language.Fortran.Analysis.Types as FAT import qualified Language.Fortran.Analysis as FA import qualified Language.Fortran.AST as F import qualified Language.Fortran.Util.Position as FU +import Language.Fortran.Util.ModFile -- For debugging and development purposes import qualified Debug.Trace as D @@ -71,33 +80,50 @@ -- Format report okReport [] = (logs ++ "\n" ++ fname ++ ":No additional annotations are necessary.\n", 0) - okReport vars = (logs ++ "\n" ++ fname ++ ": " - ++ show numVars - ++ " variable declarations suggested to be given a specification:\n" - ++ unlines [ " " ++ expReport ei | ei <- expInfo ], numVars) + okReport vars = ( logs ++ "\n" ++ fname ++ ": " + ++ show numVars + ++ " variable declarations suggested to be given a specification:\n" + ++ unlines [ " " ++ declReport d | d <- M.toList dmapSlice ] + , numVars) where - names = map showVar vars - expInfo = filter ((`elem` names) . FA.srcName) $ declVariables pfUA - numVars = length expInfo - - expReport e = "(" ++ showSrcSpan (FU.getSpan e) ++ ") " ++ FA.srcName e + varNames = map unitVarName vars + dmapSlice = M.filterWithKey (\ k _ -> k `elem` varNames) dmap + numVars = M.size dmapSlice - varReport = intercalate ", " . map showVar + declReport (v, (dc, ss)) = vfilename ++ " (" ++ showSrcSpan ss ++ ") " ++ fromMaybe v (M.lookup v uniqnameMap) + where vfilename = fromMaybe fname $ M.lookup v fromWhereMap - showVar (UnitVar (_, s)) = s - showVar (UnitLiteral _) = "" - showVar _ = "" + unitVarName (UnitVar (v, _)) = v + unitVarName (UnitParamVarUse (_, (v, _), _)) = v + unitVarName _ = "" errReport exc = logs ++ "\n" ++ fname ++ ":\n" ++ show exc -- run inference - uOpts = uo { uoNameMap = nameMap } - (eVars, state, logs) = runUnitSolver uOpts pfRenamed $ initInference >> runCriticalVariables + uOpts = uo { uoNameMap = FAR.extractNameMap pfRenamed } + (eVars, state, logs) = runUnitSolver uOpts pfRenamed $ do + modifyTemplateMap . const . cuTemplateMap . combinedCompiledUnits . M.elems $ uoModFiles uo + modifyNameParamMap . const . cuNameParamMap . combinedCompiledUnits . M.elems $ uoModFiles uo + initInference + runCriticalVariables pfUA = usProgramFile state -- the program file after units analysis is done - pfRenamed = FAR.analyseRenames . FA.initAnalysis . fmap mkUnitAnnotation $ pf - nameMap = FAR.extractNameMap pfRenamed + -- Use the module map derived from all of the included Camfort Mod files. + mmap = combinedModuleMap (M.elems (uoModFiles uo)) + pfRenamed = FAR.analyseRenamesWithModuleMap mmap . FA.initAnalysis . fmap mkUnitAnnotation $ pf + -- Map of all declarations + dmap = extractDeclMap pfRenamed `M.union` combinedDeclMap (M.elems (uoModFiles uo)) + + mmap' = extractModuleMap pfRenamed `M.union` mmap -- post-parsing + -- unique name -> src name across modules + uniqnameMap = M.fromList [ + (FA.varName e, FA.srcName e) | + e@(F.ExpValue _ _ (F.ValVariable {})) <- universeBi pfRenamed :: [F.Expression UA] + -- going to ignore intrinsics here + ] `M.union` (M.unions . map (M.fromList . map (\ (a, (b, _)) -> (b, a)) . M.toList) $ M.elems mmap') + fromWhereMap = genUniqNameToFilenameMap . M.elems $ uoModFiles uo + checkUnits, inferUnits :: UnitOpts -> (Filename, F.ProgramFile Annotation) -> Report {-| Check units-of-measure for a program -} @@ -106,14 +132,17 @@ | Left exc <- eCons = errReport exc where -- Format report - okReport Nothing = logs ++ "\n" ++ fname ++ ": Consistent. " ++ show nVars ++ " variables checked." - okReport (Just cons) = logs ++ "\n" ++ fname ++ ": Inconsistent:\n" ++ reportErrors cons + okReport Nothing = logs ++ "\n" ++ fname ++ ": Consistent. " ++ show nVars ++ " variables checked." + okReport (Just cons) = logs ++ "\n" ++ fname ++ ": Inconsistent:\n" ++ reportErrors cons ++ "\n\n" ++ + unlines (map show constraints) - reportErrors cons = unlines [ reportError con | con <- cons ] - reportError con = " - at " ++ srcSpan con - ++ pprintConstr (orient (unrename nameMap con)) - ++ additionalInfo con + reportErrors cons = unlines [ maybe "" showSS ss ++ str | (ss, str) <- reports ] where + reports = map head . group . sort $ map reportError cons + showSS = (++ ": ") . (" - at "++) . showSrcSpan + + reportError con = (findCon con, pprintConstr (orient (unrename nameMap con)) ++ additionalInfo con) + where -- Create additional info for errors additionalInfo con = if null (errorInfo con) @@ -137,6 +166,7 @@ mapNotFirst f (x : xs) = x : (map f xs) orient (ConEq u (UnitVar v)) = ConEq (UnitVar v) u + orient (ConEq u (UnitParamVarUse v)) = ConEq (UnitParamVarUse v) u orient c = c pad o = (++) (replicate o ' ') @@ -145,14 +175,19 @@ | otherwise = "" -- Find a given constraint within the annotated AST. FIXME: optimise + findCon :: Constraint -> Maybe FU.SrcSpan - findCon con = listToMaybe $ [ FU.getSpan x | x <- universeBi pfUA :: [F.Expression UA], getConstraint x `eq` con ] ++ - [ FU.getSpan x | x <- universeBi pfUA :: [F.Statement UA] , getConstraint x `eq` con ] ++ - [ FU.getSpan x | x <- universeBi pfUA :: [F.Declarator UA], getConstraint x `eq` con ] ++ - [ FU.getSpan x | x <- universeBi pfUA :: [F.Argument UA] , getConstraint x `eq` con ] - where eq Nothing _ = False - eq (Just c1) c2 = conParamEq c1 c2 + findCon con = lookupWith (eq con) constraints + where eq c1 c2 = or [ conParamEq c1 c2' | c2' <- universeBi c2 ] + constraints = [ (c, FU.getSpan x) | x <- universeBi pfUA :: [F.Expression UA] , c <- maybeToList (getConstraint x) ] ++ + [ (c, FU.getSpan x) | x <- universeBi pfUA :: [F.Statement UA] , c <- maybeToList (getConstraint x) ] ++ + [ (c, FU.getSpan x) | x <- universeBi pfUA :: [F.Argument UA] , c <- maybeToList (getConstraint x) ] ++ + [ (c, FU.getSpan x) | x <- universeBi pfUA :: [F.Declarator UA] , c <- maybeToList (getConstraint x) ] ++ + -- Why reverse? So that PUFunction and PUSubroutine appear first in the list, before PUModule. + reverse [ (c, FU.getSpan x) | x <- universeBi pfUA :: [F.ProgramUnit UA] + , c <- maybeToList (getConstraint x) ] + varReport = intercalate ", " . map showVar showVar (UnitVar (_, s)) = s @@ -163,7 +198,11 @@ -- run inference uOpts = uo { uoNameMap = nameMap } - (eCons, state, logs) = runUnitSolver uOpts pfRenamed $ initInference >> runInconsistentConstraints + (eCons, state, logs) = runUnitSolver uOpts pfRenamed $ do + modifyTemplateMap . const . cuTemplateMap . combinedCompiledUnits . M.elems $ uoModFiles uo + modifyNameParamMap . const . cuNameParamMap . combinedCompiledUnits . M.elems $ uoModFiles uo + initInference + runInconsistentConstraints templateMap = usTemplateMap state pfUA :: F.ProgramFile UA pfUA = usProgramFile state -- the program file after units analysis is done @@ -174,9 +213,34 @@ UnitParamVarAbs {} -> True; UnitParamVarUse {} -> True _ -> False - pfRenamed = FAR.analyseRenames . FA.initAnalysis . fmap mkUnitAnnotation $ pf + -- Use the module map derived from all of the included Camfort Mod files. + mmap = combinedModuleMap (M.elems (uoModFiles uo)) + pfRenamed = FAR.analyseRenamesWithModuleMap mmap . FA.initAnalysis . fmap mkUnitAnnotation $ pf nameMap = FAR.extractNameMap pfRenamed +lookupWith :: (a -> Bool) -> [(a,b)] -> Maybe b +lookupWith f = fmap snd . find (f . fst) + +-- | Create unique names for all of the inferred implicit polymorphic +-- unit variables. +chooseImplicitNames :: [(VV, UnitInfo)] -> [(VV, UnitInfo)] +chooseImplicitNames vars = replaceImplicitNames (genImplicitNamesMap vars) vars + +genImplicitNamesMap :: Data a => a -> M.Map UnitInfo UnitInfo +genImplicitNamesMap x = M.fromList [ (absU, UnitParamEAPAbs (newN, newN)) | (absU, newN) <- zip absUnits newNames ] + where + absUnits = nub [ u | u@(UnitParamPosAbs _) <- universeBi x ] + eapNames = nub $ [ n | u@(UnitParamEAPAbs (_, n)) <- universeBi x ] ++ + [ n | u@(UnitParamEAPUse ((_, n), _)) <- universeBi x ] + newNames = filter (`notElem` eapNames) . map ('\'':) $ nameGen + nameGen = concatMap sequence . tail . inits $ repeat ['a'..'z'] + +replaceImplicitNames :: Data a => M.Map UnitInfo UnitInfo -> a -> a +replaceImplicitNames implicitMap = transformBi replace + where + replace u@(UnitParamPosAbs _) = fromMaybe u $ M.lookup u implicitMap + replace u = u + {-| Check and infer units-of-measure for a program This produces an output of all the unit information for a program -} inferUnits uo (fname, pf) @@ -185,24 +249,94 @@ | Left exc <- eVars = errReport exc where -- Format report - okReport vars = logs ++ "\n" ++ fname ++ ":\n" ++ unlines [ expReport ei | ei <- expInfo ] + okReport vars = logs ++ "\n" ++ fname ++ ":\n" ++ unlines [ expReport ei | ei <- expInfo ] ++ show vars where - expInfo = [ (e, u) | e <- declVariables pfUA - , u <- maybeToList ((FA.varName e, FA.srcName e) `lookup` vars) ] + expInfo = [ (ei, u) | ei@(ExpInfo _ vname sname) <- declVariableNames pfUA + , u <- maybeToList ((vname, sname) `lookup` vars) ] - expReport (e, u) = " " ++ showSrcSpan (FU.getSpan e) ++ " unit " ++ show u ++ " :: " ++ FA.srcName e + expReport (ExpInfo ss vname sname, u) = " " ++ showSrcSpan ss ++ " unit " ++ show u ++ " :: " ++ sname errReport exc = logs ++ "\n" ++ fname ++ ": " ++ show exc -- run inference uOpts = uo { uoNameMap = nameMap } - (eVars, state, logs) = runUnitSolver uOpts pfRenamed $ initInference >> runInferVariables + (eVars, state, logs) = runUnitSolver uOpts pfRenamed $ do + modifyTemplateMap . const . cuTemplateMap . combinedCompiledUnits . M.elems $ uoModFiles uo + modifyNameParamMap . const . cuNameParamMap . combinedCompiledUnits . M.elems $ uoModFiles uo + initInference + chooseImplicitNames `fmap` runInferVariables pfUA = usProgramFile state -- the program file after units analysis is done - pfRenamed = FAR.analyseRenames . FA.initAnalysis . fmap mkUnitAnnotation $ pf + -- Use the module map derived from all of the included Camfort Mod files. + mmap = combinedModuleMap (M.elems (uoModFiles uo)) + pfRenamed = FAR.analyseRenamesWithModuleMap mmap . FA.initAnalysis . fmap mkUnitAnnotation $ pf + nameMap = FAR.extractNameMap pfRenamed +combinedCompiledUnits :: ModFiles -> CompiledUnits +combinedCompiledUnits mfs = CompiledUnits { cuTemplateMap = M.unions tmaps + , cuNameParamMap = M.unions nmaps } + where + cus = map mfCompiledUnits mfs + tmaps = map cuTemplateMap cus + nmaps = map cuNameParamMap cus + +-- | Name of the labeled data within a ModFile containing unit-specific info. +unitsCompiledDataLabel = "units-compiled-data" + +mfCompiledUnits :: ModFile -> CompiledUnits +mfCompiledUnits mf = case lookupModFileData unitsCompiledDataLabel mf of + Nothing -> emptyCompiledUnits + Just bs -> case decodeOrFail (LB.fromStrict bs) of + Left _ -> emptyCompiledUnits + Right (_, _, cu) -> cu + +genUnitsModFile :: F.ProgramFile UA -> CompiledUnits -> ModFile +genUnitsModFile pf cu = alterModFileData f unitsCompiledDataLabel $ genModFile pf + where + f _ = Just . LB.toStrict $ encode cu + +compileUnits :: UnitOpts -> [FileProgram] -> (String, [(Filename, B.ByteString)]) +compileUnits uo fileprogs = (concat reports, concat bins) + where + (reports, bins) = unzip [ (report, bin) | fileprog <- fileprogs + , let (report, bin) = compileUnits' uo fileprog ] + +compileUnits' :: UnitOpts -> FileProgram -> (String, [(Filename, B.ByteString)]) +compileUnits' uo (fname, pf) + | Right cu <- eCUnits = okReport cu + | Left exc <- eCUnits = errReport exc + where + -- Format report + okReport cu = ( logs ++ "\n" ++ fname ++ ":\n" ++ if uoDebug uo then debugInfo else [] + -- FIXME, filename manipulation (needs to go in -I dir?) + , [(fname ++ modFileSuffix, encodeModFile (genUnitsModFile pfTyped cu))] ) + where + debugInfo = unlines [ n ++ ":\n " ++ intercalate "\n " (map show cs) | (n, cs) <- M.toList (cuTemplateMap cu) ] ++ + unlines ("nameParams:" : (map show . M.toList $ cuNameParamMap cu)) + + + errReport exc = ( logs ++ "\n" ++ fname ++ ": " ++ show exc + , [] ) + -- run inference + uOpts = uo { uoNameMap = nameMap } + (eCUnits, state, logs) = runUnitSolver uOpts pfTyped $ do + modifyTemplateMap . const . cuTemplateMap . combinedCompiledUnits . M.elems $ uoModFiles uo + modifyNameParamMap . const . cuNameParamMap . combinedCompiledUnits . M.elems $ uoModFiles uo + initInference + runCompileUnits + + pfUA = usProgramFile state -- the program file after units analysis is done + + -- Use the module map derived from all of the included Camfort Mod files. + mmap = combinedModuleMap (M.elems (uoModFiles uo)) + tenv = combinedTypeEnv (M.elems (uoModFiles uo)) + pfRenamed = FAR.analyseRenamesWithModuleMap mmap . FA.initAnalysis . fmap mkUnitAnnotation $ pf + pfTyped = fst . FAT.analyseTypesWithEnv tenv $ pfRenamed + + nameMap = FAR.extractNameMap pfTyped + synthesiseUnits :: UnitOpts -> Char -> (Filename, F.ProgramFile Annotation) @@ -216,21 +350,27 @@ -- Format report okReport vars = logs ++ "\n" ++ fname ++ ":\n" ++ unlines [ expReport ei | ei <- expInfo ] where - expInfo = [ (e, u) | e <- declVariables pfUA - , u <- maybeToList ((FA.varName e, FA.srcName e) `lookup` vars) ] + expInfo = [ (ei, u) | ei@(ExpInfo _ vname sname) <- declVariableNames pfUA + , u <- maybeToList ((vname, sname) `lookup` vars) ] - expReport (e, u) = " " ++ showSrcSpan (FU.getSpan e) ++ " unit " ++ show u ++ " :: " ++ FA.srcName e + expReport (ExpInfo ss vname sname, u) = " " ++ showSrcSpan ss ++ " unit " ++ show u ++ " :: " ++ sname errReport exc = logs ++ "\n" ++ fname ++ ": " ++ show exc -- run inference uOpts = uo { uoNameMap = nameMap } - (eVars, state, logs) = runUnitSolver uOpts pfRenamed $ initInference >> runInferVariables >>= runSynthesis marker + (eVars, state, logs) = runUnitSolver uOpts pfRenamed $ do + modifyTemplateMap . const . cuTemplateMap . combinedCompiledUnits . M.elems $ uoModFiles uo + modifyNameParamMap . const . cuNameParamMap . combinedCompiledUnits . M.elems $ uoModFiles uo + initInference + runInferVariables >>= (runSynthesis marker . chooseImplicitNames) pfUA = usProgramFile state -- the program file after units analysis is done pfFinal = fmap prevAnnotation . fmap FA.prevAnnotation $ pfUA -- strip annotations - pfRenamed = FAR.analyseRenames . FA.initAnalysis . fmap mkUnitAnnotation $ pf + -- Use the module map derived from all of the included Camfort Mod files. + mmap = combinedModuleMap (M.elems (uoModFiles uo)) + pfRenamed = FAR.analyseRenamesWithModuleMap mmap . FA.initAnalysis . fmap mkUnitAnnotation $ pf nameMap = FAR.extractNameMap pfRenamed -------------------------------------------------- @@ -240,8 +380,23 @@ showSrcSpan :: FU.SrcSpan -> String showSrcSpan (FU.SrcSpan l u) = show l -declVariables :: F.ProgramFile UA -> [F.Expression UA] -declVariables pf = flip mapMaybe (universeBi pf) $ \ d -> case d of - F.DeclVariable _ _ v@(F.ExpValue _ _ (F.ValVariable _)) _ _ -> Just v - F.DeclArray _ _ v@(F.ExpValue _ _ (F.ValVariable _)) _ _ _ -> Just v +data ExpInfo = ExpInfo { expInfoSrcSpan :: FU.SrcSpan, expInfoVName :: F.Name, expInfoSName :: F.Name } + deriving (Show, Eq, Ord, Typeable, Data, Generic) + +-- | List of declared variables (including both decl statements & function returns, defaulting to first) +declVariableNames :: F.ProgramFile UA -> [ExpInfo] +declVariableNames pf = sort . M.elems $ M.unionWith (curry fst) declInfo puInfo + where + declInfo = M.fromList [ (expInfoVName ei, ei) | ei <- declVariableNamesDecl pf ] + puInfo = M.fromList [ (expInfoVName ei, ei) | ei <- declVariableNamesPU pf ] + +declVariableNamesDecl :: F.ProgramFile UA -> [ExpInfo] +declVariableNamesDecl pf = flip mapMaybe (universeBi pf :: [F.Declarator UA]) $ \ d -> case d of + F.DeclVariable _ ss v@(F.ExpValue _ _ (F.ValVariable _)) _ _ -> Just (ExpInfo ss (FA.varName v) (FA.srcName v)) + F.DeclArray _ ss v@(F.ExpValue _ _ (F.ValVariable _)) _ _ _ -> Just (ExpInfo ss (FA.varName v) (FA.srcName v)) _ -> Nothing +declVariableNamesPU :: F.ProgramFile UA -> [ExpInfo] +declVariableNamesPU pf = flip mapMaybe (universeBi pf :: [F.ProgramUnit UA]) $ \ pu -> case pu of + F.PUFunction _ ss _ _ _ _ (Just v@(F.ExpValue _ _ (F.ValVariable _))) _ _ -> Just (ExpInfo ss (FA.varName v) (FA.srcName v)) + F.PUFunction _ ss _ _ _ _ Nothing _ _ -> Just (ExpInfo ss (puName pu) (puSrcName pu)) + _ -> Nothing 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 @@ -13,7 +13,7 @@ See the License for the specific language governing permissions and limitations under the License. -} -{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, PatternGuards #-} {- Provides various data types and type class instances for the Units extension -} @@ -33,6 +33,8 @@ import Data.List import Data.Matrix import Data.Ratio +import Data.Binary +import GHC.Generics (Generic) import qualified Debug.Trace as D import Text.Printf @@ -44,10 +46,12 @@ data UnitInfo = UnitParamPosAbs (String, Int) -- an abstract parameter identified by PU name and argument position | UnitParamPosUse (String, Int, Int) -- identify particular instantiation of parameters - | UnitParamVarAbs (String, String) -- an abstract parameter identified by PU name and variable name - | UnitParamVarUse (String, String, Int) -- a particular instantiation of above + | UnitParamVarAbs (String, VV) -- an abstract parameter identified by PU name and variable name + | UnitParamVarUse (String, VV, Int) -- a particular instantiation of above | UnitParamLitAbs Int -- a literal with abstract, polymorphic units, uniquely identified | UnitParamLitUse (Int, Int) -- a particular instantiation of a polymorphic literal + | UnitParamEAPAbs VV -- an abstract Explicitly Annotated Polymorphic unit variable + | UnitParamEAPUse (VV, Int) -- a particular instantiation of an Explicitly Annotated Polymorphic unit variable | UnitLiteral Int -- literal with undetermined but uniquely identified units | UnitlessLit -- a unitless literal | UnitlessVar -- a unitless variable @@ -56,30 +60,39 @@ | UnitVar VV -- variable with undetermined units: (unique name, source name) | UnitMul UnitInfo UnitInfo -- two units multiplied | UnitPow UnitInfo Double -- a unit raised to a constant power - deriving (Eq, Ord, Data, Typeable) + | UnitRecord [(String, UnitInfo)] -- 'record'-type of units + deriving (Eq, Ord, Data, Typeable, Generic) +instance Binary UnitInfo + instance Show UnitInfo where show u = case u of - UnitParamPosAbs (f, i) -> printf "#" f i - UnitParamPosUse (f, i, j) -> printf "#" f i j - UnitParamVarAbs (f, v) -> printf "#" f v - UnitParamVarUse (f, v, j) -> printf "#" f v j - UnitParamLitAbs i -> printf "#" i - UnitParamLitUse (i, j) -> printf "#" i j - UnitLiteral i -> printf "#" i - UnitlessLit -> "1" - UnitlessVar -> "1" - UnitName name -> name - UnitAlias name -> name - UnitVar (vName, _) -> printf "#" vName + UnitParamPosAbs (f, i) -> printf "#" f i + UnitParamPosUse (f, i, j) -> printf "#" f i j + UnitParamVarAbs (f, (v, _)) -> printf "#" f v + UnitParamVarUse (f, (v, _), j) -> printf "#" f v j + UnitParamLitAbs i -> printf "#" i + UnitParamLitUse (i, j) -> printf "#" i j + UnitParamEAPAbs (v, _) -> v + UnitParamEAPUse ((v, _), i) -> printf "#" v i + UnitLiteral i -> printf "#" i + UnitlessLit -> "1" + UnitlessVar -> "1" + UnitName name -> name + UnitAlias name -> name + UnitVar (vName, _) -> printf "#" vName + UnitRecord recs -> "record (" ++ intercalate ", " (map (\ (n, u) -> n ++ " :: " ++ show u) recs) ++ ")" UnitMul u1 (UnitPow u2 k) - | k < 0 -> maybeParen u1 ++ " / " ++ maybeParen (UnitPow u2 (-k)) - UnitMul u1 u2 -> maybeParenS u1 ++ " " ++ maybeParenS u2 - UnitPow u 1 -> show u - UnitPow u 0 -> "1" - UnitPow u k -> + | k < 0 -> maybeParen u1 ++ " / " ++ maybeParen (UnitPow u2 (-k)) + UnitMul u1 u2 -> maybeParenS u1 ++ " " ++ maybeParenS u2 + UnitPow u 1 -> show u + UnitPow u 0 -> "1" + UnitPow u k -> -- printf "%s**%f" (maybeParen u) k case doubleToRationalSubset k of - Just r -> printf "%s**%s" (maybeParen u) (showRational r) + Just r + | e <- showRational r + , e /= "1" -> printf "%s**%s" (maybeParen u) e + | otherwise -> show u Nothing -> error $ printf "Irrational unit exponent: %s**%f" (maybeParen u) k where showRational r @@ -87,7 +100,7 @@ | otherwise = showRational' r showRational' r | denominator r == 1 = show (numerator r) - | otherwise = printf "%s / %s" (numerator r) (denominator r) + | otherwise = printf "(%d / %d)" (numerator r) (denominator r) where maybeParen x | all isAlphaNum s = s | otherwise = "(" ++ s ++ ")" @@ -125,21 +138,49 @@ data Constraint = ConEq UnitInfo UnitInfo -- an equality constraint | ConConj [Constraint] -- conjunction of constraints - deriving (Eq, Ord, Data, Typeable) + deriving (Eq, Ord, Data, Typeable, Generic) + +instance Binary Constraint + type Constraints = [Constraint] instance Show Constraint where show (ConEq u1 u2) = show u1 ++ " === " ++ show u2 show (ConConj cs) = intercalate " && " (map show cs) +isVarUnit (UnitVar _) = True +isVarUnit (UnitParamVarUse _) = True +isVarUnit _ = False + +isUnresolvedUnit (UnitVar _) = True +isUnresolvedUnit (UnitParamVarUse _) = True +isUnresolvedUnit (UnitParamVarAbs _) = True +isUnresolvedUnit (UnitParamPosUse _) = True +isUnresolvedUnit (UnitParamPosAbs _) = True +isUnresolvedUnit (UnitParamLitUse _) = True +isUnresolvedUnit (UnitParamLitAbs _) = True +isUnresolvedUnit (UnitParamEAPAbs _) = True +isUnresolvedUnit (UnitParamEAPUse _) = True +isUnresolvedUnit (UnitPow u _) = isUnresolvedUnit u +isUnresolvedUnit (UnitMul u1 u2) = isUnresolvedUnit u1 || isUnresolvedUnit u2 +isUnresolvedUnit _ = False + +isResolvedUnit = not . isUnresolvedUnit + pprintConstr :: Constraint -> String -pprintConstr (ConEq u1@(UnitVar _) u2@(UnitVar _)) - = "'" ++ pprintUnitInfo u1 ++ "' should have the same units as '" ++ pprintUnitInfo u2 ++ "'" -pprintConstr (ConEq u1 u2) = "'" ++ pprintUnitInfo u1 ++ "' should be '" ++ pprintUnitInfo u2 ++ "'" -pprintConstr (ConConj cs) = intercalate "\n\t and " (map pprintConstr cs) +pprintConstr (ConEq u1 u2) + | isResolvedUnit u1 = "'" ++ pprintUnitInfo u2 ++ "' should have unit '" ++ pprintUnitInfo u1 ++ "'" + | isResolvedUnit u2 = "'" ++ pprintUnitInfo u1 ++ "' should have unit '" ++ pprintUnitInfo u2 ++ "'" +pprintConstr (ConEq u1 u2) = "'" ++ pprintUnitInfo u1 ++ "' should have the same units as '" ++ pprintUnitInfo u2 ++ "'" +pprintConstr (ConConj cs) = intercalate "\n\t and " (map pprintConstr cs) pprintUnitInfo :: UnitInfo -> String pprintUnitInfo (UnitVar (_, sName)) = printf "%s" sName +pprintUnitInfo (UnitParamVarUse (_, (_, sName), _)) = printf "%s" sName +pprintUnitInfo (UnitParamPosUse (fname, 0, _)) = printf "result of %s" fname +pprintUnitInfo (UnitParamPosUse (fname, i, _)) = printf "parameter %d to %s" i fname +pprintUnitInfo (UnitParamEAPUse ((v, _), _)) = printf "explicitly annotated polymorphic unit %s" v +pprintUnitInfo (UnitLiteral _) = "literal number" pprintUnitInfo ui = show ui -------------------------------------------------- @@ -147,8 +188,8 @@ -- | Constraint 'parametric' equality: treat all uses of a parametric -- abstractions as equivalent to the abstraction. conParamEq :: Constraint -> Constraint -> Bool -conParamEq (ConEq lhs1 rhs1) (ConEq lhs2 rhs2) = (unitParamEq lhs1 lhs2 && unitParamEq rhs1 rhs2) || - (unitParamEq rhs1 lhs2 && unitParamEq lhs1 rhs2) +conParamEq (ConEq lhs1 rhs1) (ConEq lhs2 rhs2) = unitParamEq lhs1 lhs2 || unitParamEq rhs1 rhs2 || + unitParamEq rhs1 lhs2 || unitParamEq lhs1 rhs2 conParamEq (ConConj cs1) (ConConj cs2) = and $ zipWith conParamEq cs1 cs2 conParamEq _ _ = False @@ -161,6 +202,8 @@ unitParamEq (UnitParamVarUse (f', i', _)) (UnitParamVarAbs (f, i)) = (f, i) == (f', i') unitParamEq (UnitParamPosAbs (f, i)) (UnitParamPosUse (f', i', _)) = (f, i) == (f', i') unitParamEq (UnitParamPosUse (f', i', _)) (UnitParamPosAbs (f, i)) = (f, i) == (f', i') +unitParamEq (UnitParamEAPAbs v) (UnitParamEAPUse (v', _)) = v == v' +unitParamEq (UnitParamEAPUse (v', _)) (UnitParamEAPAbs v) = v == v' unitParamEq (UnitMul u1 u2) (UnitMul u1' u2') = unitParamEq u1 u1' && unitParamEq u2 u2' || unitParamEq u1 u2' && unitParamEq u2 u1' unitParamEq (UnitPow u p) (UnitPow u' p') = unitParamEq u u' && p == p' @@ -170,40 +213,43 @@ -- The annotation on the AST used for solving units. data UnitAnnotation a = UnitAnnotation { - prevAnnotation :: a, - unitSpec :: Maybe P.UnitStatement, - unitConstraint :: Maybe Constraint, - unitInfo :: Maybe UnitInfo, - unitBlock :: Maybe (F.Block (FA.Analysis (UnitAnnotation a))) } - deriving (Data, Typeable, Show) + prevAnnotation :: a, + unitSpec :: Maybe P.UnitStatement, + unitConstraint :: Maybe Constraint, + unitInfo :: Maybe UnitInfo, + unitBlock :: Maybe (F.Block (FA.Analysis (UnitAnnotation a))), -- ^ linked variable declaration + unitPU :: Maybe (F.ProgramUnit (FA.Analysis (UnitAnnotation a))) -- ^ linked program unit + } deriving (Data, Typeable, Show) -dbgUnitAnnotation (UnitAnnotation _ s c i b) = +dbgUnitAnnotation (UnitAnnotation _ s c i b p) = "{ unitSpec = " ++ show s ++ ", unitConstraint = " ++ show c ++ ", unitInfo = " ++ show i ++ ", unitBlock = " ++ (case b of Nothing -> "Nothing" Just (F.BlStatement _ span _ (F.StDeclaration {})) -> "Just {decl}@" ++ show span Just (F.BlStatement _ span _ _) -> "Just {stmt}@" ++ show span Just _ -> "Just ...") + ++ ", unitPU = " ++ + (case p of + Nothing -> "Nothing" + Just (F.PUFunction _ span _ _ _ _ _ _ _) -> "Just {func}@" ++ show span + Just (F.PUSubroutine _ span _ _ _ _ _) -> "Just {subr}@" ++ show span + Just _ -> "Just ...") ++ "}" mkUnitAnnotation :: a -> UnitAnnotation a -mkUnitAnnotation a = UnitAnnotation a Nothing Nothing Nothing Nothing +mkUnitAnnotation a = UnitAnnotation a Nothing Nothing Nothing Nothing Nothing -------------------------------------------------- -- | Convert parser units to UnitInfo -toUnitInfo :: P.UnitOfMeasure -> UnitInfo -toUnitInfo (P.UnitProduct u1 u2) = - UnitMul (toUnitInfo u1) (toUnitInfo u2) -toUnitInfo (P.UnitQuotient u1 u2) = - UnitMul (toUnitInfo u1) (UnitPow (toUnitInfo u2) (-1)) -toUnitInfo (P.UnitExponentiation u1 p) = - UnitPow (toUnitInfo u1) (toDouble p) +toUnitInfo :: P.UnitOfMeasure -> UnitInfo +toUnitInfo (P.UnitProduct u1 u2) = UnitMul (toUnitInfo u1) (toUnitInfo u2) +toUnitInfo (P.UnitQuotient u1 u2) = UnitMul (toUnitInfo u1) (UnitPow (toUnitInfo u2) (-1)) +toUnitInfo (P.UnitExponentiation u1 p) = UnitPow (toUnitInfo u1) (toDouble p) where - toDouble :: P.UnitPower -> Double - toDouble (P.UnitPowerInteger i) = fromInteger i + toDouble :: P.UnitPower -> Double + toDouble (P.UnitPowerInteger i) = fromInteger i toDouble (P.UnitPowerRational x y) = fromRational (x % y) -toUnitInfo (P.UnitBasic str) = - UnitName str -toUnitInfo (P.Unitless) = - UnitlessLit +toUnitInfo (P.UnitBasic str) = UnitName str +toUnitInfo (P.Unitless) = UnitlessLit +toUnitInfo (P.UnitRecord us) = UnitRecord (map (fmap toUnitInfo) us) 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 @@ -18,19 +18,20 @@ Units of measure extension to Fortran: backend -} -{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} module Camfort.Specification.Units.InferenceBackend ( inconsistentConstraints, criticalVariables, inferVariables -- mainly for debugging and testing: - , shiftTerms, flattenConstraints, flattenUnits, constraintsToMatrix, rref, isInconsistentRREF ) + , shiftTerms, flattenConstraints, flattenUnits, constraintsToMatrix, constraintsToMatrices + , rref, isInconsistentRREF, genUnitAssignments ) where import Data.Tuple (swap) import Data.Maybe (maybeToList) -import Data.List ((\\), findIndex, partition, sortBy, group) -import Data.Generics.Uniplate.Operations (rewrite) +import Data.List ((\\), findIndex, partition, sortBy, group, intercalate, tails, sort) +import Data.Generics.Uniplate.Operations (rewrite, universeBi) import Control.Monad import Control.Monad.State.Strict import Control.Monad.ST @@ -48,7 +49,7 @@ ) import qualified Numeric.LinearAlgebra as H import Numeric.LinearAlgebra.Devel ( - newMatrix, readMatrix, writeMatrix, runSTMatrix + newMatrix, readMatrix, writeMatrix, runSTMatrix, freezeMatrix, STMatrix ) import qualified Debug.Trace as D @@ -63,7 +64,7 @@ | null inconsists = Nothing | otherwise = Just [ con | (con, i) <- zip cons [0..], i `elem` inconsists ] where - (unsolvedM, inconsists, colA) = constraintsToMatrix cons + (_, _, inconsists, _, _) = constraintsToMatrices cons -------------------------------------------------- @@ -71,31 +72,56 @@ -- inference or checking to work. criticalVariables :: Constraints -> [UnitInfo] criticalVariables [] = [] -criticalVariables cons = filter (not . isUnitName) $ map (colA A.!) criticalIndices +criticalVariables cons = filter (not . isUnitRHS) $ map (colA A.!) criticalIndices where (unsolvedM, inconsists, colA) = constraintsToMatrix cons solvedM = rref unsolvedM uncriticalIndices = concatMap (maybeToList . findIndex (/= 0)) $ H.toLists solvedM criticalIndices = A.indices colA \\ uncriticalIndices - isUnitName (UnitName _) = True; isUnitName _ = False + isUnitRHS (UnitName _) = True; isUnitRHS _ = False -------------------------------------------------- -- | Returns list of formerly-undetermined variables and their units. inferVariables :: Constraints -> [(VV, UnitInfo)] -inferVariables [] = [] -inferVariables cons - | null inconsists = [ (var, if null units then UnitlessVar else foldl1 UnitMul units) - | ([UnitPow (UnitVar var) k], units) <- map (partition (not . isUnitName)) unitPows - , k `approxEq` 1 ] +inferVariables cons = unitVarAssignments + where + unitAssignments = genUnitAssignments cons + -- Find the rows corresponding to the distilled "unit :: var" + -- information for ordinary (non-polymorphic) variables. + unitVarAssignments = + [ (var, units) | ([UnitPow (UnitVar var) k], units) <- unitAssignments, k `approxEq` 1 ] ++ + [ (var, units) | ([UnitPow (UnitParamVarAbs (_, var)) k], units) <- unitAssignments, k `approxEq` 1 ] + +-- | Raw units-assignment pairs. +genUnitAssignments :: [Constraint] -> [([UnitInfo], UnitInfo)] +genUnitAssignments cons + | null inconsists = unitAssignments | otherwise = [] where - (unsolvedM, inconsists, colA) = constraintsToMatrix cons - solvedM = rref unsolvedM - cols = A.elems colA - unitPows = map (concatMap flattenUnits . zipWith UnitPow cols) (H.toLists solvedM) - isUnitName (UnitPow (UnitName _) _) = True; isUnitName _ = False + (unsolvedM, inconsists, colA) = constraintsToMatrix cons + solvedM = rref unsolvedM + cols = A.elems colA + -- Convert the rows of the solved matrix into flattened unit + -- expressions in the form of "unit ** k". + unitPows = map (concatMap flattenUnits . zipWith UnitPow cols) (H.toLists solvedM) + + -- Variables to the left, unit names to the right side of the equation. + unitAssignments = map (fmap (foldUnits . map negatePosAbs) . partition (not . isUnitRHS)) unitPows + isUnitRHS (UnitPow (UnitName _) _) = True + isUnitRHS (UnitPow (UnitParamEAPAbs _) _) = True + -- Because this version of isUnitRHS different from + -- constraintsToMatrix interpretation, we need to ensure that any + -- moved ParamPosAbs units are negated, because they are + -- effectively being shifted across the equal-sign: + isUnitRHS (UnitPow (UnitParamPosAbs _) _) = True + isUnitRHS _ = False + + foldUnits units + | null units = UnitlessVar + | otherwise = foldl1 UnitMul units + -------------------------------------------------- simplifyConstraints = map (\ (ConEq u1 u2) -> (flattenUnits u1, flattenUnits u2)) @@ -146,6 +172,21 @@ augM = if rows rhsM == 0 || cols rhsM == 0 then lhsM else fromBlocks [[lhsM, rhsM]] inconsists = findInconsistentRows lhsM augM +constraintsToMatrices :: Constraints -> (H.Matrix Double, H.Matrix Double, [Int], A.Array Int UnitInfo, A.Array Int UnitInfo) +constraintsToMatrices cons = (lhsM, rhsM, inconsists, lhsCols, rhsCols) + where + -- convert each constraint into the form (lhs, rhs) + consPairs = filter (uncurry (/=)) $ flattenConstraints cons + -- ensure terms are on the correct side of the equal sign + shiftedCons = map shiftTerms consPairs + lhs = map fst shiftedCons + rhs = map snd shiftedCons + (lhsM, lhsCols) = flattenedToMatrix lhs + (rhsM, rhsCols) = flattenedToMatrix rhs + colElems = A.elems lhsCols ++ A.elems rhsCols + augM = if rows rhsM == 0 || cols rhsM == 0 then lhsM else fromBlocks [[lhsM, rhsM]] + inconsists = findInconsistentRows lhsM augM + -- [[UnitInfo]] is a list of flattened constraints flattenedToMatrix :: [[UnitInfo]] -> (H.Matrix Double, A.Array Int UnitInfo) flattenedToMatrix cons = (m, A.array (0, numCols - 1) (map swap uniqUnits)) @@ -169,25 +210,35 @@ negateCons = map (\ (UnitPow u k) -> UnitPow u (-k)) -colSort (UnitLiteral i) (UnitLiteral j) = compare i j -colSort (UnitLiteral _) _ = LT -colSort _ (UnitLiteral _) = GT -colSort x y = compare x y +negatePosAbs (UnitPow (UnitParamPosAbs x) k) = UnitPow (UnitParamPosAbs x) (-k) +negatePosAbs u = u +colSort (UnitLiteral i) (UnitLiteral j) = compare i j +colSort (UnitLiteral _) _ = LT +colSort _ (UnitLiteral _) = GT +colSort (UnitParamPosAbs x) (UnitParamPosAbs y) = compare x y +colSort (UnitParamPosAbs _) _ = GT +colSort _ (UnitParamPosAbs _) = LT +colSort x y = compare x y + -------------------------------------------------- --- | Translate all constraints into a LHS, RHS side of units. -flattenConstraints :: Constraints -> [([UnitInfo], [UnitInfo])] -flattenConstraints = map (\ (ConEq u1 u2) -> (flattenUnits u1, flattenUnits u2)) +-- Units that should appear on the right-hand-side of the matrix during solving +isUnitRHS (UnitPow (UnitName _) _) = True +isUnitRHS (UnitPow (UnitParamEAPAbs _) _) = True +isUnitRHS _ = False --- | Shift UnitNames to the RHS, and all else to the LHS. +-- | Shift UnitNames/EAPAbs poly units to the RHS, and all else to the LHS. shiftTerms :: ([UnitInfo], [UnitInfo]) -> ([UnitInfo], [UnitInfo]) shiftTerms (lhs, rhs) = (lhsOk ++ negateCons rhsShift, rhsOk ++ negateCons lhsShift) where - (lhsOk, lhsShift) = partition (not . isUnitName) lhs - (rhsOk, rhsShift) = partition isUnitName rhs - isUnitName (UnitPow (UnitName _) _) = True; isUnitName _ = False + (lhsOk, lhsShift) = partition (not . isUnitRHS) lhs + (rhsOk, rhsShift) = partition isUnitRHS rhs +-- | Translate all constraints into a LHS, RHS side of units. +flattenConstraints :: Constraints -> [([UnitInfo], [UnitInfo])] +flattenConstraints = map (\ (ConEq u1 u2) -> (flattenUnits u1, flattenUnits u2)) + -------------------------------------------------- -- Matrix solving functions based on HMatrix @@ -235,29 +286,32 @@ m = cols a below = getColumnBelow a (j - k, j) + erm = elemRowMult n (j - k) (recip (a @@> (j - k, j))) + -- scale the row if the cell is not already equal to 1 - erm = elemRowMult n (j - k) (recip (a @@> (j - k, j))) - (a1, mats1) = if a @@> (j - k, j) /= 1 then - (erm <> a, erm:mats) - else (a, mats) + (a1, mats1) | a @@> (j - k, j) /= 1 = (erm <> a, erm: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 -- separate elemRowAdd matrix for each cancellation that are then -- multiplied together, simply build a single matrix that cancels -- all of them out at the same time, using the ST Monad. - findAdds i m ms = (new <> m, new:ms) + findAdds i m ms + | isWritten = (new <> m, new:ms) + | otherwise = (m, ms) where - new = runSTMatrix $ do - new <- newMatrix 0 n n + (isWritten, 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 i | i >= n = return () - | i == j - k = f (i + 1) - | a @@> (i, j) == 0 = f (i + 1) - | otherwise = writeMatrix new i (j - k) (- (a @@> (i, j))) - >> f (i + 1) - f 0 - return new + 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 + (a2, mats2) = findAdds 0 a1 mats1 -- Get a list of values that occur below (i, j) in the matrix a. @@ -295,7 +349,7 @@ findInconsistentRows :: H.Matrix Double -> H.Matrix Double -> [Int] findInconsistentRows coA augA = [0..(rows augA - 1)] \\ consistent where - consistent = head (filter (tryRows coA augA) (pset ( [0..(rows augA - 1)])) ++ [[]]) + consistent = head (filter (tryRows coA augA) (tails ( [0..(rows augA - 1)])) ++ [[]]) -- Rouché–Capelli theorem is that if the rank of the coefficient -- matrix is not equal to the rank of the augmented matrix then @@ -309,3 +363,8 @@ extractRows = flip (?) -- hmatrix 0.17 changed interface m @@> i = m `atIndex` i + +showCons str = unlines . ([replicate 50 '-', str ++ ":"]++) . (++[replicate 50 '^']) . map f + where + f (ConEq u1 u2) = show (flattenUnits u1) ++ " === " ++ show (flattenUnits u2) + f (ConConj cons) = intercalate " && " (map f cons) diff --git a/src/Camfort/Specification/Units/InferenceFrontend.hs b/src/Camfort/Specification/Units/InferenceFrontend.hs --- a/src/Camfort/Specification/Units/InferenceFrontend.hs +++ b/src/Camfort/Specification/Units/InferenceFrontend.hs @@ -22,11 +22,12 @@ {-# LANGUAGE PatternGuards #-} module Camfort.Specification.Units.InferenceFrontend - ( initInference, runCriticalVariables, runInferVariables, runInconsistentConstraints, getConstraint ) + ( initInference, runCriticalVariables, runInferVariables, runCompileUnits, runInconsistentConstraints, getConstraint + , puName, puSrcName ) where import Data.Data (Data) -import Data.List (nub) +import Data.List (nub, intercalate, partition) import qualified Data.Map.Strict as M import qualified Data.IntMap.Strict as IM import qualified Data.Set as S @@ -40,6 +41,8 @@ import qualified Language.Fortran.AST as F import Language.Fortran.Parser.Utils (readReal, readInteger) +import Language.Fortran.Util.Position (getSpan) +import Language.Fortran.Util.ModFile import qualified Language.Fortran.Analysis as FA import Language.Fortran.Analysis (varName, srcName) @@ -59,6 +62,7 @@ initInference :: UnitSolver () initInference = do pf <- gets usProgramFile + -- Parse unit annotations found in comments and link to their -- corresponding statements in the AST. let (linkedPF, parserReport) = runWriter $ annotateComments P.unitParser pf @@ -102,11 +106,13 @@ -- These constraints will include parametric polymorphic units that -- have not yet been instantiated into their particular uses. abstractCons <- extractConstraints + dumpConsM "***abstractCons" abstractCons -- Eliminate all parametric polymorphic units by copying them for -- each specific use cases and substituting a unique call-site -- identifier that distinguishes each use-case from the others. cons <- applyTemplates abstractCons + dumpConsM "***concreteCons" cons -- Remove any traces of CommentAnnotator, since the annotations can -- cause generic operations traversing the AST to get confused. @@ -117,7 +123,7 @@ debugLogging cleanLinks :: F.ProgramFile UA -> F.ProgramFile UA -cleanLinks = transformBi (\ a -> a { unitBlock = Nothing, unitSpec = Nothing } :: UnitAnnotation A) +cleanLinks = transformBi (\ a -> a { unitPU = Nothing, unitBlock = Nothing, unitSpec = Nothing } :: UnitAnnotation A) -------------------------------------------------- -- Inference functions @@ -142,6 +148,39 @@ cons <- usConstraints `fmap` get return $ inconsistentConstraints cons +-- | Produce information for a "units-mod" file. +runCompileUnits :: UnitSolver CompiledUnits +runCompileUnits = do + cons <- usConstraints `fmap` get + + -- Sketching some ideas about solving the unit equation for each + -- parameter of each function. + let unitAssigns = map (fmap flattenUnits) $ genUnitAssignments cons + let mulCons x = map (\ (UnitPow u k) -> UnitPow u (x * k)) + let negateCons = mulCons (-1) + let epsilon = 0.001 -- arbitrary + let approxEq a b = abs (b - a) < epsilon + let uninvert ([UnitPow u k], rhs) | not (k `approxEq` 1) = ([UnitPow u 1], mulCons (1 / k) rhs) + uninvert (lhs, rhs) = (lhs, rhs) + let shiftTerms name pos (lhs, rhs) = (lhsOk ++ negateCons rhsShift, rhsOk ++ negateCons lhsShift) + where + (lhsOk, lhsShift) = partition isLHS lhs + (rhsOk, rhsShift) = partition (not . isLHS) rhs + isLHS (UnitParamPosAbs (n, i)) | n == name && i == pos = True + isLHS (UnitPow u _) = isLHS u + isLHS _ = False + + let nameParams = M.fromList [ (NPKParam name pos, rhs) | assign <- unitAssigns + , UnitParamPosAbs (name, pos) <- universeBi assign + , let (_, rhs) = uninvert $ shiftTerms name pos assign ] + + + let variables = M.fromList [ (NPKVariable var, units) | ([UnitPow (UnitVar var) k], units) <- unitAssigns + , k `approxEq` 1 ] + + tmap <- gets usTemplateMap + return $ CompiledUnits { cuTemplateMap = tmap, cuNameParamMap = nameParams `M.union` variables } + -------------------------------------------------- -- | Seek out any parameters to functions or subroutines that do not @@ -177,65 +216,155 @@ -- variables are inside of a function or subroutine. insertUndeterminedUnits :: UnitSolver () insertUndeterminedUnits = do - pf <- gets usProgramFile - forM_ (universeBi pf) $ \ pu -> case pu of - F.PUFunction {} -> modifyPUBlocksM (transformBiM (toParamVar (puName pu))) pu - F.PUSubroutine {} -> modifyPUBlocksM (transformBiM (toParamVar (puName pu))) pu - _ -> modifyPUBlocksM (transformBiM toUnitVar) pu + pf <- gets usProgramFile + dmap <- (M.union (extractDeclMap pf) . combinedDeclMap . M.elems) `fmap` asks uoModFiles + forM_ (universeBi pf :: [F.ProgramUnit UA]) $ \ pu -> + modifyPUBlocksM (transformBiM (insertUndeterminedUnitVar dmap)) pu - where - toParamVar :: String -> F.Expression UA -> UnitSolver (F.Expression UA) - toParamVar fname v@(F.ExpValue _ _ (F.ValVariable _)) = do - let vname = varName v - let sname = srcName v - modifyVarUnitMap $ M.insertWith (curry snd) (vname, sname) (UnitParamVarAbs (fname, vname)) - return v - toParamVar _ e = return e +-- Specifically handle variables +insertUndeterminedUnitVar :: DeclMap -> F.Expression UA -> UnitSolver (F.Expression UA) +insertUndeterminedUnitVar dmap v@(F.ExpValue _ _ (F.ValVariable _)) = do + let vname = varName v + let sname = srcName v + let unit = toUnitVar dmap (vname, sname) + modifyVarUnitMap $ M.insertWith (curry snd) (varName v, srcName v) unit + return v +insertUndeterminedUnitVar _ e = return e - toUnitVar :: F.Expression UA -> UnitSolver (F.Expression UA) - toUnitVar v@(F.ExpValue _ _ (F.ValVariable _)) = do - let vname = varName v - let sname = srcName v - modifyVarUnitMap $ M.insertWith (curry snd) (vname, sname) (UnitVar (vname, sname)) - return v - toUnitVar e = return e +-- Choose UnitVar or UnitParamVarAbs depending upon how the variable was declared. +toUnitVar :: DeclMap -> VV -> UnitInfo +toUnitVar dmap (vname, sname) = unit + where + unit = case fst `fmap` M.lookup vname dmap of + Just (DCFunction (F.Named fname)) -> UnitParamVarAbs (fname, (vname, sname)) + Just (DCSubroutine (F.Named fname)) -> UnitParamVarAbs (fname, (vname, sname)) + _ -> UnitVar (vname, sname) -------------------------------------------------- +-- | Convert explicit polymorphic annotations such as (UnitName "'a") +-- into UnitParamEAPAbs with a 'context-unique-name' given by the +-- ProgramUnitName combined with the supplied unit name. +transformExplicitPolymorphism :: Maybe F.ProgramUnitName -> UnitInfo -> UnitInfo +transformExplicitPolymorphism (Just (F.Named f)) (UnitName a@('\'':_)) = UnitParamEAPAbs (a, f ++ "_" ++ a) +transformExplicitPolymorphism _ u = u + -- | Any units provided by the programmer through comment annotations -- will be incorporated into the VarUnitMap. insertGivenUnits :: UnitSolver () insertGivenUnits = do pf <- gets usProgramFile - mapM_ checkComment [ b | b@(F.BlComment {}) <- universeBi pf ] + mapM_ checkPU (universeBi pf) where + -- Look through each Program Unit for the comments + checkPU :: F.ProgramUnit UA -> UnitSolver () + checkPU pu@(F.PUComment a _ _) + -- Look at unit assignment between function return variable and spec. + | Just (P.UnitAssignment (Just vars) unitsAST) <- mSpec + , Just pu <- mPU = insertPUUnitAssigns (toUnitInfo unitsAST) pu vars + -- Add a new unit alias. + | Just (P.UnitAlias name unitsAST) <- mSpec = modifyUnitAliasMap (M.insert name (toUnitInfo unitsAST)) + | otherwise = return () + where + mSpec = unitSpec (FA.prevAnnotation a) + mPU = unitPU (FA.prevAnnotation a) + -- Other type of ProgramUnit (e.g. one with a body of blocks) + checkPU pu = mapM_ (checkBlockComment (getName pu)) [ b | b@(F.BlComment {}) <- universeBi (F.programUnitBody pu) ] + where + getName pu = case pu of + F.PUFunction {} -> Just $ F.getName pu + F.PUSubroutine {} -> Just $ F.getName pu + _ -> Nothing + -- Look through each comment that has some kind of unit annotation within it. - checkComment :: F.Block UA -> UnitSolver () - checkComment (F.BlComment a _ _) + checkBlockComment :: Maybe F.ProgramUnitName -> F.Block UA -> UnitSolver () + checkBlockComment pname (F.BlComment a _ _) -- Look at unit assignment between variable and spec. | Just (P.UnitAssignment (Just vars) unitsAST) <- mSpec - , Just b <- mBlock = insertUnitAssignments (toUnitInfo unitsAST) b vars + , Just b <- mBlock = insertBlockUnitAssigns pname (toUnitInfo unitsAST) b vars -- Add a new unit alias. - | Just (P.UnitAlias name unitsAST) <- mSpec = modifyUnitAliasMap (M.insert name (toUnitInfo unitsAST)) - | otherwise = return () + | Just (P.UnitAlias name unitsAST) <- mSpec = modifyUnitAliasMap (M.insert name (toUnitInfo unitsAST)) + | otherwise = return () where mSpec = unitSpec (FA.prevAnnotation a) mBlock = unitBlock (FA.prevAnnotation a) -- Figure out the unique names of the referenced variables and -- then insert unit info under each of those names. - insertUnitAssignments :: UnitInfo -> F.Block UA -> [String] -> UnitSolver () - insertUnitAssignments info (F.BlStatement _ _ _ (F.StDeclaration _ _ _ _ decls)) varRealNames = do + insertBlockUnitAssigns :: Maybe F.ProgramUnitName -> UnitInfo -> F.Block UA -> [String] -> UnitSolver () + insertBlockUnitAssigns pname info (F.BlStatement _ _ _ (F.StDeclaration _ _ _ _ decls)) varRealNames = do -- figure out the 'unique name' of the varRealName that was found in the comment -- FIXME: account for module renaming -- FIXME: might be more efficient to allow access to variable renaming environ at this program point - let m = M.fromList [ ((varName e, srcName e), info) + let info' = transform (transformExplicitPolymorphism pname) info + let m = M.fromList [ ((varName e, srcName e), info') | e@(F.ExpValue _ _ (F.ValVariable _)) <- universeBi decls :: [F.Expression UA] , varRealName <- varRealNames - , varRealName == FA.srcName e ] + , varRealName == srcName e ] modifyVarUnitMap $ M.unionWith const m modifyGivenVarSet . S.union . S.fromList . map fst . M.keys $ m + -- Insert unit annotation for function return variable + insertPUUnitAssigns :: UnitInfo -> F.ProgramUnit UA -> [String] -> UnitSolver () + insertPUUnitAssigns info pu@(F.PUFunction _ _ _ _ _ _ mret _ _) varRealNames + | (retUniq, retSrc) <- case mret of Just ret -> (FA.varName ret, FA.srcName ret) + Nothing -> (puName pu, puSrcName pu) + , retSrc `elem` varRealNames = do + let pname = Just $ F.getName pu + let info' = transform (transformExplicitPolymorphism pname) info + let m = M.fromList [ ((retUniq, retSrc), info') ] + modifyVarUnitMap $ M.unionWith const m + modifyGivenVarSet . S.union . S.fromList . map fst . M.keys $ m + + +-- ensure polymorphic variable annotation is used correctly +checkPolymorphicAnnotation :: UnitSolver [String] +checkPolymorphicAnnotation = do + pf <- gets usProgramFile + checks <- mapM checkPU (universeBi pf) + return . map fst . filter (not . snd) $ checks + where + -- Look through each Program Unit for its parameters and annotations + checkPU :: F.ProgramUnit UA -> UnitSolver (String, Bool) + checkPU pu = do + (argPolys, resPolys) <- foldM (checkBlockComment (getNameAndArgs pu)) ([], []) [ b | b@(F.BlComment {}) <- universeBi (F.programUnitBody pu) ] + return (puName pu, S.fromList resPolys `S.isSubsetOf` S.fromList argPolys) + where + getNameAndArgs :: F.ProgramUnit UA -> Maybe (String, [String], Maybe String) + getNameAndArgs pu = case pu of + F.PUFunction _ _ _ _ _ args Nothing _ _ + | name <- puName pu -> Just (name, map varName (universeBi args :: [F.Expression UA]), Just name) + F.PUFunction _ _ _ _ _ args (Just res) _ _ + | name <- puName pu -> Just (name, map varName (universeBi args :: [F.Expression UA]), Just (varName res)) + F.PUSubroutine _ _ _ _ args _ _ + | name <- puName pu -> Just (name, map varName (universeBi args :: [F.Expression UA]), Nothing) + _ -> Nothing + checkBlockComment :: Maybe (String, [String], Maybe String) -> ([String], [String]) -> F.Block UA -> UnitSolver ([String], [String]) + checkBlockComment pinfo (argPolys, resPolys) (F.BlComment a _ _) + -- Look at unit assignment between variable and spec. + | Just (pname, args, mres) <- pinfo + , Just (P.UnitAssignment (Just vars) unitsAST) <- mSpec + , Just b <- mBlock = + let + annotVars = S.fromList [ varName e + | e@(F.ExpValue _ _ (F.ValVariable _)) <- universeBi b :: [F.Expression UA] + , varSrcName <- vars + , varSrcName == srcName e ] + extractPolys ast = [ v | P.UnitBasic (v@('\'':_)) <- universeBi ast ] + in case () of + () | any (`S.member` annotVars) args -> return (extractPolys unitsAST ++ argPolys, resPolys) + | Just res <- mres, + res `S.member` annotVars -> return (argPolys, extractPolys unitsAST ++ resPolys) + | otherwise -> return (argPolys, resPolys) + | otherwise = return (argPolys, resPolys) + where + mSpec = unitSpec (FA.prevAnnotation a) + mBlock = unitBlock (FA.prevAnnotation a) + + + + + -------------------------------------------------- -- | Take the unit information from the VarUnitMap and use it to @@ -245,6 +374,7 @@ varUnitMap <- usVarUnitMap `fmap` get let annotateExp e@(F.ExpValue _ _ (F.ValVariable _)) | Just info <- M.lookup (varName e, srcName e) varUnitMap = setUnitInfo info e + -- may need to annotate intrinsics separately annotateExp e = e return $ transformBi annotateExp pf @@ -270,8 +400,10 @@ -- 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 _ -> return e @@ -285,17 +417,54 @@ | isLiteral e = flip setUnitInfo e `fmap` m | otherwise = return e + isPolyCtxt = case pu of F.PUFunction {} -> True; F.PUSubroutine {} -> True; _ -> False + +-- | Is it a literal, literally? +isLiteral :: F.Expression UA -> Bool +isLiteral (F.ExpValue _ _ (F.ValReal _)) = True +isLiteral (F.ExpValue _ _ (F.ValInteger _)) = True +isLiteral _ = False + +-- | Is expression a literal and is it zero? +isLiteralZero :: F.Expression UA -> Bool +isLiteralZero (F.ExpValue _ _ (F.ValInteger i)) = readInteger i == Just 0 +isLiteralZero (F.ExpValue _ _ (F.ValReal i)) = readReal i == Just 0 +isLiteralZero _ = False + +-- | Is expression a literal and is it 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 + -------------------------------------------------- -- | Convert all parametric templates into actual uses, via substitution. applyTemplates :: Constraints -> UnitSolver Constraints -- postcondition: returned constraints lack all Parametric constructors applyTemplates cons = do + dumpConsM "applyTemplates" cons -- Get a list of the instances of parametric polymorphism from the constraints. let instances = nub [ (name, i) | UnitParamPosUse (name, _, i) <- universeBi cons ] + + -- Also generate a list of 'dummy' instances to ensure that every + -- 'toplevel' function and subroutine is thoroughly expanded and + -- analysed, even if it is not used in the current ProgramFile. (It + -- might be part of a library module, for instance). + pf <- gets usProgramFile + dummies <- forM (topLevelFuncsAndSubs pf) $ \ pu -> do + id <- genCallId + return (puName pu, id) + + whenDebug $ do + D.traceM ("instances: " ++ show instances ++ "\n") + D.traceM ("dummies: " ++ show dummies ++ "\n") + -- Work through the instances, expanding their templates, and -- substituting the callId into the abstract parameters. - concreteCons <- foldM (substInstance []) [] instances + concreteCons <- liftM2 (++) (foldM (substInstance False []) [] instances) + (foldM (substInstance True []) [] dummies) + dumpConsM "applyTemplates: concreteCons" concreteCons -- Also include aliases in the final set of constraints, where -- aliases are implemented by simply asserting that they are equal @@ -305,14 +474,15 @@ let transAlias (UnitName a) | a `M.member` aliasMap = UnitAlias a transAlias u = u - return . transformBi transAlias . filter (not . isParametric) $ cons ++ concreteCons ++ aliases + dumpConsM "aliases" aliases + return . transformBi transAlias $ cons ++ concreteCons ++ aliases -- | Look up the Parametric templates for a given function or -- subroutine, and do the substitutions. Process any additional -- polymorphic calls that are uncovered, unless they are recursive -- calls that have already been seen in the current call stack. -substInstance :: [F.Name] -> Constraints -> (F.Name, Int) -> UnitSolver Constraints -substInstance callStack output (name, callId) = do +substInstance :: Bool -> [F.Name] -> Constraints -> (F.Name, Int) -> UnitSolver Constraints +substInstance isDummy callStack output (name, callId) = do tmap <- gets usTemplateMap -- Look up the templates associated with the given function or @@ -322,8 +492,12 @@ -- -- The reason for this is because functions called by functions can -- be used in a parametric polymorphic way. - template <- transformBiM callIdRemap $ [] `fromMaybe` M.lookup name tmap + -- npc <- nameParamConstraints name -- In case it is an imported function, use this. + let npc = [] -- disabled for now + template <- transformBiM callIdRemap $ npc `fromMaybe` M.lookup name tmap + dumpConsM ("substInstance " ++ show isDummy ++ " " ++ show callStack ++ " " ++ show (name, callId) ++ " template lookup") template + -- Reset the usCallIdRemap field so that it is ready for the next -- set of templates. modify $ \ s -> s { usCallIdRemap = IM.empty } @@ -336,11 +510,46 @@ -- unit-assignments as the first call. return [] else - foldM (substInstance (name:callStack)) [] instances + foldM (substInstance False (name:callStack)) [] instances - -- Convert any remaining abstract parametric units into concrete ones. - return . instantiate (name, callId) $ output ++ template ++ template' + 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 `fmap` gets usNameParamMap + 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 + -- variables from current context when looking at dummy (name, callId) + (if isDummy then output ++ template + else instantiate callId (output ++ template)) ++ + + -- Only instantiate explicitly annotated polymorphic + -- variables from nested function/subroutine calls. + instantiate callId template' ++ + + -- any imported variables + importedVariables + + dumpConsM ("final output for " ++ show (name, callId)) output' + + return output' + +foldUnits units + | null units = UnitlessVar + | otherwise = foldl1 UnitMul units + +-- | Generate constraints from a NameParamMap entry. +nameParamConstraints :: F.Name -> UnitSolver Constraints +nameParamConstraints fname = do + let filterForName (NPKParam n _) _ = n == fname + filterForName _ _ = False + nlst <- (M.toList . M.filterWithKey filterForName) `fmap` gets usNameParamMap + return [ ConEq (UnitParamPosAbs (fname, pos)) (foldUnits units) | (NPKParam _ pos, units) <- nlst ] + -- | If given a usage of a parametric unit, rewrite the callId field -- to follow an existing mapping in the usCallIdRemap state field, or -- generate a new callId and add it to the usCallIdRemap state field. @@ -358,25 +567,46 @@ | Just i' <- IM.lookup i idMap -> return (UnitParamLitUse (l, i'), idMap) | otherwise -> genCallId >>= \ i' -> return (UnitParamLitUse (l, i'), IM.insert i i' idMap) - _ -> return (info, idMap) + UnitParamEAPUse (v, i) + | Just i' <- IM.lookup i idMap -> return (UnitParamEAPUse (v, i'), idMap) + | otherwise -> genCallId >>= \ i' -> + return (UnitParamEAPUse (v, i'), IM.insert i i' idMap) + _ -> return (info, idMap) --- | Convert a parametric template into a particular use -instantiate (name, callId) = transformBi $ \ info -> case info of + +-- | Convert a parametric template into a particular use. +instantiate :: Data a => Int -> a -> a +instantiate callId = transformBi $ \ info -> case info of UnitParamPosAbs (name, position) -> UnitParamPosUse (name, position, callId) UnitParamLitAbs litId -> UnitParamLitUse (litId, callId) UnitParamVarAbs (fname, vname) -> UnitParamVarUse (fname, vname, callId) + UnitParamEAPAbs vname -> UnitParamEAPUse (vname, callId) _ -> info +-- | Return a list of ProgramUnits that might be considered 'toplevel' +-- in the ProgramFile, e.g., possible exports. These must be analysed +-- independently of whether they are actually used in the same file, +-- because other files might use them. +topLevelFuncsAndSubs :: F.ProgramFile a -> [F.ProgramUnit a] +topLevelFuncsAndSubs (F.ProgramFile _ pus) = topLevel =<< pus + where + topLevel (F.PUModule _ _ _ _ (Just contains)) = topLevel =<< contains + topLevel (F.PUMain _ _ _ _ (Just contains)) = topLevel =<< contains + topLevel f@(F.PUFunction {}) = return f + topLevel s@(F.PUSubroutine {}) = return s + topLevel _ = [] + -------------------------------------------------- -- | Gather all constraints from the main blocks of the AST, as well as from the varUnitMap extractConstraints :: UnitSolver Constraints extractConstraints = do pf <- gets usProgramFile + dmap <- (M.union (extractDeclMap pf) . combinedDeclMap . M.elems) `fmap` asks uoModFiles varUnitMap <- gets usVarUnitMap return $ [ con | b <- mainBlocks pf, con@(ConEq {}) <- universeBi b ] ++ - [ ConEq (UnitVar v) u | (v, u) <- M.toList varUnitMap ] + [ ConEq (toUnitVar dmap v) u | (v, u) <- M.toList varUnitMap ] -- | A list of blocks considered to be part of the 'main' program. mainBlocks :: F.ProgramFile UA -> [F.Block UA] @@ -392,6 +622,16 @@ [ () | UnitParamVarAbs _ <- universeBi info ] ++ [ () | UnitParamLitAbs _ <- universeBi info ] +-- | Does the constraint contain only Parametric elements? +isAllParametric :: Constraint -> Bool +isAllParametric = all f . universeBi + where + f i = case i of + UnitParamPosAbs _ -> True + UnitParamVarAbs _ -> True + UnitParamLitAbs _ -> True + _ -> False + -------------------------------------------------- -- | Decorate the AST with unit info. @@ -403,9 +643,7 @@ propagateExp :: F.Expression UA -> UnitSolver (F.Expression UA) propagateExp e = fmap uoLiterals ask >>= \ lm -> case e of - F.ExpValue _ _ (F.ValVariable _) -> return e -- all variables should already be annotated - F.ExpValue _ _ (F.ValInteger _) -> return e -- all literal numbers should already be annotated - F.ExpValue _ _ (F.ValReal _) -> return e -- all literal numbers should already be annotated + F.ExpValue _ _ _ -> return e -- all values should already be annotated F.ExpBinary _ _ F.Multiplication e1 e2 -> setF2 UnitMul (getUnitInfoMul lm e1) (getUnitInfoMul lm e2) F.ExpBinary _ _ F.Division e1 e2 -> setF2 UnitMul (getUnitInfoMul lm e1) (flip UnitPow (-1) `fmap` (getUnitInfoMul lm e2)) F.ExpBinary _ _ F.Exponentiation e1 e2 -> setF2 UnitPow (getUnitInfo e1) (constantExpression e2) @@ -413,7 +651,10 @@ | isOp RelOp o -> setF2C ConEq (getUnitInfo e1) (getUnitInfo e2) F.ExpFunctionCall {} -> propagateFunctionCall e F.ExpSubscript _ _ e1 _ -> return $ maybeSetUnitInfo (getUnitInfo e1) e - _ -> whenDebug (tell ("propagateExp: unhandled: " ++ show e)) >> return e + F.ExpUnary _ _ _ e1 -> return $ maybeSetUnitInfo (getUnitInfo e1) e + _ -> do + whenDebug . tell $ "propagateExp: " ++ show (getSpan e) ++ " unhandled: " ++ show e + return e where -- Shorter names for convenience functions. setF2 f u1 u2 = return $ maybeSetUnitInfoF2 f u1 u2 e @@ -422,30 +663,42 @@ propagateFunctionCall :: F.Expression UA -> UnitSolver (F.Expression UA) propagateFunctionCall e@(F.ExpFunctionCall a s f Nothing) = do - (info, _) <- callHelper f [] - return . setUnitInfo info $ F.ExpFunctionCall a s f Nothing + (info, _) <- callHelper f [] + let cons = intrinsicHelper info f [] + return . setConstraint (ConConj cons) . setUnitInfo info $ F.ExpFunctionCall a s f Nothing propagateFunctionCall e@(F.ExpFunctionCall a s f (Just (F.AList a' s' args))) = do (info, args') <- callHelper f args - return . setUnitInfo info $ F.ExpFunctionCall a s f (Just (F.AList a' s' args')) + let cons = intrinsicHelper info f args' + return . setConstraint (ConConj cons) . setUnitInfo info $ F.ExpFunctionCall a s f (Just (F.AList a' s' args')) propagateStatement :: F.Statement UA -> UnitSolver (F.Statement UA) propagateStatement stmt = case stmt of - F.StExpressionAssign _ _ e1 e2 -> do - return $ maybeSetUnitConstraintF2 ConEq (getUnitInfo e1) (getUnitInfo e2) stmt + F.StExpressionAssign _ _ e1 e2 -> literalAssignmentSpecialCase e1 e2 stmt F.StCall a s sub (Just (F.AList a' s' args)) -> do - (_, args') <- callHelper sub args - return $ F.StCall a s sub (Just (F.AList a' s' args')) + (info, args') <- callHelper sub args + let cons = intrinsicHelper info sub args' + return . setConstraint (ConConj cons) $ F.StCall a s sub (Just (F.AList a' s' args')) F.StDeclaration {} -> transformBiM propagateDeclarator stmt _ -> return stmt propagateDeclarator :: F.Declarator UA -> UnitSolver (F.Declarator UA) propagateDeclarator decl = case decl of - F.DeclVariable _ _ e1 _ (Just e2) -> do - return $ maybeSetUnitConstraintF2 ConEq (getUnitInfo e1) (getUnitInfo e2) decl - F.DeclArray _ _ e1 _ _ (Just e2) -> do - return $ maybeSetUnitConstraintF2 ConEq (getUnitInfo e1) (getUnitInfo e2) decl + F.DeclVariable _ _ e1 _ (Just e2) -> literalAssignmentSpecialCase e1 e2 decl + F.DeclArray _ _ e1 _ _ (Just e2) -> literalAssignmentSpecialCase e1 e2 decl _ -> return decl +-- Allow literal assignment to overload the non-polymorphic +-- unit-assignment of the non-zero literal. +literalAssignmentSpecialCase e1 e2 ast + | u2@(Just (UnitLiteral _)) <- getUnitInfo e2 = do + return $ maybeSetUnitConstraintF2 ConEq (getUnitInfo e1) u2 ast + | isLiteralNonZero e2 = do + u2 <- genUnitLiteral + return $ maybeSetUnitConstraintF2 ConEq (getUnitInfo e1) (Just u2) ast + | otherwise = do + -- otherwise express the constraint between LHS and RHS of assignment. + return $ maybeSetUnitConstraintF2 ConEq (getUnitInfo e1) (getUnitInfo e2) ast + propagatePU :: F.ProgramUnit UA -> UnitSolver (F.ProgramUnit UA) propagatePU pu = do let name = puName pu @@ -458,16 +711,25 @@ -- explicit unit and the UnitParamPosAbs corresponding to the -- parameter. This way all other uses of the parameter get linked to -- the explicit unit annotation as well. - givenCons <- fmap catMaybes . forM (indexedParams pu) $ \ (i, param) -> do + givenCons <- forM (indexedParams pu) $ \ (i, param) -> do case M.lookup param varMap of - Just (UnitParamPosAbs {}) -> return Nothing - Just u -> return . Just . ConEq u $ UnitParamPosAbs (name, i) - _ -> return Nothing + Just (UnitParamPosAbs {}) -> return . ConEq (UnitParamVarAbs (name, param)) $ UnitParamPosAbs (name, i) + Just u -> return . ConEq u $ UnitParamPosAbs (name, i) + _ -> return . ConEq (UnitParamVarAbs (name, param)) $ UnitParamPosAbs (name, i) let cons = givenCons ++ bodyCons - modifyTemplateMap (M.insert name cons) - return (setConstraint (ConConj cons) pu) + case pu of F.PUFunction {} -> modifyTemplateMap (M.insert name cons) + F.PUSubroutine {} -> modifyTemplateMap (M.insert name cons) + _ -> return () + -- Set the unitInfo field of a function program unit to be the same + -- as the unitInfo of its result. + let pu' = case (pu, indexedParams pu) of + (F.PUFunction {}, (0, res):_) -> setUnitInfo (UnitParamPosAbs (name, 0) `fromMaybe` M.lookup res varMap) pu + _ -> pu + + return (setConstraint (ConConj cons) pu') + -------------------------------------------------- -- | Check if x contains an abstract parametric reference under the given name. @@ -489,6 +751,16 @@ let info = UnitParamPosUse (name, 0, callId) return (info, args') +-- FIXME: use this function to create a list of constraints on intrinsic call-sites... +intrinsicHelper (UnitParamPosUse (_, _, callId)) f@(F.ExpValue _ _ (F.ValIntrinsic _)) args + | Just (retU, argUs) <- M.lookup sname intrinsicUnits = zipWith eachArg [0..numArgs] (retU:argUs) + where + numArgs = length args + sname = srcName f + vname = varName f + eachArg i u = ConEq (UnitParamPosUse (vname, i, callId)) (instantiate callId u) +intrinsicHelper _ _ _ = [] + -- | Generate a unique identifier for a call-site. genCallId :: UnitSolver Int genCallId = do @@ -543,7 +815,8 @@ -- | Set the Constraint field on a piece of AST. setConstraint :: F.Annotated f => Constraint -> f UA -> f UA -setConstraint c = modifyAnnotation (onPrev (\ ua -> ua { unitConstraint = Just c })) +setConstraint (ConConj []) = id +setConstraint c = modifyAnnotation (onPrev (\ ua -> ua { unitConstraint = Just c })) -------------------------------------------------- @@ -573,11 +846,7 @@ F.PUSubroutine a s r n p b subs -> flip fmap (f b) $ \ b' -> F.PUSubroutine a s r n p b' subs F.PUFunction a s r rec n p res b subs -> flip fmap (f b) $ \ b' -> F.PUFunction a s r rec n p res b' subs F.PUBlockData a s n b -> flip fmap (f b) $ \ b' -> F.PUBlockData a s n b' - --- Is it a literal, literally? -isLiteral (F.ExpValue _ _ (F.ValReal _)) = True -isLiteral (F.ExpValue _ _ (F.ValInteger _)) = True -isLiteral _ = False + F.PUComment {} -> return pu -- no blocks -------------------------------------------------- @@ -652,6 +921,11 @@ -------------------------------------------------- +dumpConsM str = whenDebug . D.traceM . unlines . ([replicate 50 '-', str ++ ":"]++) . (++[replicate 50 '^']) . map f + where + f (ConEq u1 u2) = show (flattenUnits u1) ++ " === " ++ show (flattenUnits u2) + f (ConConj cons) = intercalate " && " (map f cons) + debugLogging :: UnitSolver () debugLogging = whenDebug $ do (tell . unlines . map (\ (ConEq u1 u2) -> " ***AbsConstraint: " ++ show (flattenUnits u1) ++ " === " ++ show (flattenUnits u2) ++ "\n")) =<< extractConstraints @@ -667,26 +941,36 @@ forM_ (universeBi pf) $ \ pu -> case pu of F.PUFunction {} | Just (ConConj cons) <- getConstraint pu -> - whenDebug . tell . unlines $ (puName pu ++ ":"):map (\ (ConEq u1 u2) -> " constraint: " ++ show (flattenUnits u1) ++ " === " ++ show (flattenUnits u2)) cons + tell . unlines $ (puName pu ++ ":"):map (\ (ConEq u1 u2) -> " constraint: " ++ show (flattenUnits u1) ++ " === " ++ show (flattenUnits u2)) cons F.PUSubroutine {} | Just (ConConj cons) <- getConstraint pu -> - whenDebug . tell . unlines $ (puName pu ++ ":"):map (\ (ConEq u1 u2) -> " constraint: " ++ show (flattenUnits u1) ++ " === " ++ show (flattenUnits u2)) cons + tell . unlines $ (puName pu ++ ":"):map (\ (ConEq u1 u2) -> " constraint: " ++ show (flattenUnits u1) ++ " === " ++ show (flattenUnits u2)) cons _ -> return () - let (unsolvedM, inconsists, colA) = constraintsToMatrix cons - let solvedM = rref unsolvedM - tell "\n--------------------------------------------------\n" - tell $ show colA + let (lhsM, rhsM, _, lhsColA, rhsColA) = constraintsToMatrices cons + tell "\n--------------------------------------------------\nLHS Cols:\n" + tell $ show lhsColA + tell "\n--------------------------------------------------\nRHS Cols:\n" + tell $ show rhsColA + tell "\n--------------------------------------------------\nLHS M:\n" + tell $ show lhsM + tell "\n--------------------------------------------------\nRHS M:\n" + tell $ show rhsM + tell "\n--------------------------------------------------\nSolved (RREF) M:\n" + let augM = if H.rows rhsM == 0 || H.cols rhsM == 0 then lhsM else H.fromBlocks [[lhsM, rhsM]] + tell . show . rref $ augM + -- tell "\n--------------------------------------------------\nSolved (SVD) M:\n" + -- tell $ show (H.linearSolveSVD lhsM rhsM) + -- tell "\n--------------------------------------------------\nSingular Values:\n" + -- tell $ show (H.singularValues lhsM) tell "\n--------------------------------------------------\n" - tell $ show unsolvedM + tell $ "Rank LHS: " ++ show (H.rank lhsM) ++ "\n" tell "\n--------------------------------------------------\n" - tell . show $ (H.takeRows (H.rank solvedM) solvedM) + let augA = if H.rows rhsM == 0 || H.cols rhsM == 0 then lhsM else H.fromBlocks [[lhsM, rhsM]] + tell $ "Rank Augmented: " ++ show (H.rank augA) ++ "\n" + tell "\n--------------------------------------------------\nGenUnitAssignments:\n" + let unitAssignments = genUnitAssignments cons + tell . unlines $ map (\ (u1s, u2) -> " ***UnitAssignment: " ++ show u1s ++ " === " ++ show (flattenUnits u2) ++ "\n") unitAssignments tell "\n--------------------------------------------------\n" - tell $ "Rank: " ++ show (H.rank solvedM) ++ "\n" - tell $ "Is inconsistent RREF? " ++ show (isInconsistentRREF solvedM) ++ "\n" - tell $ "Inconsistent rows: " ++ show (inconsistentConstraints cons) ++ "\n" - tell "--------------------------------------------------\n" - tell $ "Critical Variables: " ++ show (criticalVariables cons) ++ "\n" - tell $ "Infer Variables: " ++ show (inferVariables cons) ++ "\n" -------------------------------------------------- @@ -700,3 +984,85 @@ puSrcName pu | F.Named n <- FA.puSrcName pu = n | otherwise = "_nameless" + +-------------------------------------------------- + +-- | name => (return-unit, parameter-units) +intrinsicUnits :: M.Map F.Name (UnitInfo, [UnitInfo]) +intrinsicUnits = + M.fromList + [ ("abs", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) + , ("iabs", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) + , ("dabs", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) + , ("cabs", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) + , ("aimag", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) + , ("aint", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) + , ("dint", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) + , ("anint", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) + , ("dnint", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) + , ("cmplx", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) + , ("conjg", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) + , ("dble", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) + , ("dim", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'a", "'a")])) + , ("idim", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'a", "'a")])) + , ("ddim", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'a", "'a")])) + , ("dprod", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) + , ("ceiling", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) + , ("floor", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) + , ("int", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) + , ("ifix", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) + , ("idint", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) + , ("max", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) -- special case: arbitrary # of parameters + , ("min", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) -- special case: arbitrary # of parameters + , ("min0", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) -- special case: arbitrary # of parameters + , ("amin1", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) -- special case: arbitrary # of parameters + , ("dmin1", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) -- special case: arbitrary # of parameters + , ("amin0", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) -- special case: arbitrary # of parameters + , ("min1", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) -- special case: arbitrary # of parameters + , ("mod", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")])) + , ("modulo", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")])) + , ("amod", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")])) + , ("dmod", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")])) + , ("nint", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) + , ("real", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) + , ("float", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) + , ("sngl", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) + , ("sign", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")])) + , ("isign", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")])) + , ("dsign", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")])) + , ("present", (UnitParamEAPAbs ("'a", "'a"), [UnitlessVar])) + , ("sqrt", (UnitParamEAPAbs ("'a", "'a"), [UnitPow (UnitParamEAPAbs ("'a", "'a")) 2])) + , ("dsqrt", (UnitParamEAPAbs ("'a", "'a"), [UnitPow (UnitParamEAPAbs ("'a", "'a")) 2])) + , ("csqrt", (UnitParamEAPAbs ("'a", "'a"), [UnitPow (UnitParamEAPAbs ("'a", "'a")) 2])) + , ("exp", (UnitlessVar, [UnitlessVar])) + , ("dexp", (UnitlessVar, [UnitlessVar])) + , ("cexp", (UnitlessVar, [UnitlessVar])) + , ("alog", (UnitlessVar, [UnitlessVar])) + , ("dlog", (UnitlessVar, [UnitlessVar])) + , ("clog", (UnitlessVar, [UnitlessVar])) + , ("alog10", (UnitlessVar, [UnitlessVar])) + , ("dlog10", (UnitlessVar, [UnitlessVar])) + , ("sin", (UnitlessVar, [UnitlessVar])) + , ("dsin", (UnitlessVar, [UnitlessVar])) + , ("csin", (UnitlessVar, [UnitlessVar])) + , ("cos", (UnitlessVar, [UnitlessVar])) + , ("dcos", (UnitlessVar, [UnitlessVar])) + , ("ccos", (UnitlessVar, [UnitlessVar])) + , ("tan", (UnitlessVar, [UnitlessVar])) + , ("dtan", (UnitlessVar, [UnitlessVar])) + , ("asin", (UnitlessVar, [UnitlessVar])) + , ("dasin", (UnitlessVar, [UnitlessVar])) + , ("acos", (UnitlessVar, [UnitlessVar])) + , ("dacos", (UnitlessVar, [UnitlessVar])) + , ("atan", (UnitlessVar, [UnitlessVar])) + , ("datan", (UnitlessVar, [UnitlessVar])) + , ("atan2", (UnitlessVar, [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'a", "'a")])) + , ("datan2", (UnitlessVar, [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'a", "'a")])) + , ("sinh", (UnitlessVar, [UnitlessVar])) + , ("dsinh", (UnitlessVar, [UnitlessVar])) + , ("cosh", (UnitlessVar, [UnitlessVar])) + , ("dcosh", (UnitlessVar, [UnitlessVar])) + , ("tanh", (UnitlessVar, [UnitlessVar])) + , ("dtanh", (UnitlessVar, [UnitlessVar])) ] + +-- Others: reshape, merge need special handling diff --git a/src/Camfort/Specification/Units/Monad.hs b/src/Camfort/Specification/Units/Monad.hs --- a/src/Camfort/Specification/Units/Monad.hs +++ b/src/Camfort/Specification/Units/Monad.hs @@ -15,6 +15,7 @@ -} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} {- | Defines the monad for the units-of-measure modules -} @@ -22,38 +23,31 @@ ( UA, VV, UnitSolver, UnitOpts(..), unitOpts0, UnitLogs, UnitState(..), LiteralsOpt(..), UnitException , whenDebug, modifyVarUnitMap, modifyGivenVarSet, modifyUnitAliasMap , VarUnitMap, GivenVarSet, UnitAliasMap, TemplateMap, CallIdMap - , modifyTemplateMap, modifyProgramFile, modifyProgramFileM, modifyCallIdRemapM - , runUnitSolver, evalUnitSolver, execUnitSolver ) + , modifyTemplateMap, modifyNameParamMap, modifyProgramFile, modifyProgramFileM, modifyCallIdRemapM + , runUnitSolver, evalUnitSolver, execUnitSolver + , CompiledUnits(..), NameParamMap, NameParamKey(..), emptyCompiledUnits ) where import Control.Monad.RWS.Strict import Control.Monad.Trans.Except +import Data.Binary (Binary) +import Data.Typeable (Typeable) import Data.Char (toLower) import Data.Data (Data) import Data.List (find, isPrefixOf) +import GHC.Generics (Generic) import qualified Data.Map.Strict as M import qualified Data.IntMap.Strict as IM import qualified Data.Set as S import qualified Language.Fortran.Analysis as FA import qualified Language.Fortran.Analysis.Renaming as FAR import qualified Language.Fortran.AST as F +import Language.Fortran.Util.ModFile import Camfort.Specification.Units.Environment (UnitInfo, UnitAnnotation, Constraints(..), VV) import Camfort.Analysis.Annotations (Annotation, A, UA) +import qualified Data.ByteString.Char8 as B --------------------------------------------------- --- | The monad -type UnitSolver a = ExceptT UnitException (RWS UnitOpts UnitLogs UnitState) a - --------------------------------------------------- - --- Not in use, but might be useful someday. -type UnitException = () - --------------------------------------------------- - --- Read-only options for the unit solver. - -- | Some options about how to handle literals. data LiteralsOpt = LitPoly -- ^ All literals are polymorphic. @@ -71,16 +65,56 @@ ms = [ ("poly", LitPoly), ("unitless", LitUnitless), ("mixed", LitMixed) , ("litpoly", LitPoly), ("litunitless", LitUnitless), ("litmixed", LitMixed) ] +-- | Options for the unit solver data UnitOpts = UnitOpts - { uoDebug :: Bool -- ^ debugging mode? - , uoLiterals :: LiteralsOpt -- ^ how to handle literals - , uoNameMap :: FAR.NameMap -- ^ map of unique names to original names + { uoDebug :: Bool -- ^ debugging mode? + , uoLiterals :: LiteralsOpt -- ^ how to handle literals + , uoNameMap :: FAR.NameMap -- ^ map of unique names to original names + , uoModFiles :: M.Map String ModFile -- ^ map of included modules } - deriving (Show, Read, Data, Eq, Ord) + deriving (Show, Data, Eq, Ord) unitOpts0 :: UnitOpts -unitOpts0 = UnitOpts False LitMixed M.empty +unitOpts0 = UnitOpts False LitMixed M.empty M.empty +-- | Function/subroutine name -> associated, parametric polymorphic constraints +type TemplateMap = M.Map F.Name Constraints + +-- | Things that can be exported from modules +data NameParamKey + = NPKParam F.Name Int -- ^ Function/subroutine name, position of parameter + | NPKVariable VV -- ^ variable + deriving (Ord, Eq, Show, Data, Typeable, Generic) + +instance Binary NameParamKey + +-- | mapped to a list of units (to be multiplied together) +type NameParamMap = M.Map NameParamKey [UnitInfo] + +-- | The data-structure stored in 'fortran-src mod files' +data CompiledUnits = CompiledUnits { cuTemplateMap :: TemplateMap + , cuNameParamMap :: NameParamMap } + deriving (Ord, Eq, Show, Data, Typeable, Generic) + +instance Binary CompiledUnits + +emptyCompiledUnits :: CompiledUnits +emptyCompiledUnits = CompiledUnits M.empty M.empty + +-------------------------------------------------- + +-- | The monad +type UnitSolver a = ExceptT UnitException (RWS UnitOpts UnitLogs UnitState) a + +-------------------------------------------------- + +-- Not in use, but might be useful someday. +type UnitException = () + +-------------------------------------------------- + +-- Read-only options for the unit solver. + -- | Only run the argument if debugging mode enabled. whenDebug :: UnitSolver () -> UnitSolver () whenDebug m = fmap uoDebug ask >>= \ d -> when d m @@ -98,8 +132,6 @@ type GivenVarSet = S.Set F.Name -- | Alias name => definition type UnitAliasMap = M.Map String UnitInfo --- | Function/subroutine name -> associated, parametric polymorphic constraints -type TemplateMap = M.Map F.Name Constraints -- | Map of CallId to CallId type CallIdMap = IM.IntMap Int @@ -110,6 +142,7 @@ , usGivenVarSet :: GivenVarSet , usUnitAliasMap :: UnitAliasMap , usTemplateMap :: TemplateMap + , usNameParamMap :: NameParamMap , usLitNums :: Int , usCallIds :: Int , usCallIdRemap :: CallIdMap @@ -121,6 +154,7 @@ , usGivenVarSet = S.empty , usUnitAliasMap = M.empty , usTemplateMap = M.empty + , usNameParamMap = M.empty , usLitNums = 0 , usCallIds = 0 , usCallIdRemap = IM.empty @@ -138,6 +172,9 @@ modifyTemplateMap :: (TemplateMap -> TemplateMap) -> UnitSolver () modifyTemplateMap f = modify (\ s -> s { usTemplateMap = f (usTemplateMap s) }) + +modifyNameParamMap :: (NameParamMap -> NameParamMap) -> UnitSolver () +modifyNameParamMap f = modify (\ s -> s { usNameParamMap = f (usNameParamMap s) }) modifyProgramFile :: (F.ProgramFile UA -> F.ProgramFile UA) -> UnitSolver () modifyProgramFile f = modify (\ s -> s { usProgramFile = f (usProgramFile s) }) diff --git a/src/Camfort/Specification/Units/Parser.y b/src/Camfort/Specification/Units/Parser.y --- a/src/Camfort/Specification/Units/Parser.y +++ b/src/Camfort/Specification/Units/Parser.y @@ -19,18 +19,19 @@ %tokentype { Token } %token - unit { TId "unit" } - id { TId $$ } - one { TNum "1" } - num { TNum $$ } - ',' { TComma } - '-' { TMinus } - '**' { TExponentiation } - '/' { TDivision } - '::' { TDoubleColon } - '=' { TEqual } - '(' { TLeftPar } - ')' { TRightPar } + unit { TId "unit" } + record { TRecord } + id { TId $$ } + one { TNum "1" } + num { TNum $$ } + ',' { TComma } + '-' { TMinus } + '**' { TExponentiation } + '/' { TDivision } + '::' { TDoubleColon } + '=' { TEqual } + '(' { TLeftPar } + ')' { TRightPar } %left '/' %left '**' @@ -53,7 +54,15 @@ | one { Unitless } | '(' one ')' { Unitless } | '(' ')' { Unitless } +| record '(' RECORD_DECLS ')' { UnitRecord $3 } +RECORD_DECLS :: { [(String, UnitOfMeasure)] } +: RECORD_DECL ',' RECORD_DECLS { $1 : $3 } +| RECORD_DECL { [$1] } + +RECORD_DECL :: { (String, UnitOfMeasure) } +: UEXP '::' id { ($3, $1) } + UEXP_LEVEL1 :: { UnitOfMeasure } : UEXP_LEVEL1 UEXP_LEVEL2 { UnitProduct $1 $2 } | UEXP '/' UEXP_LEVEL2 { UnitQuotient $1 $3 } @@ -95,6 +104,7 @@ | UnitProduct UnitOfMeasure UnitOfMeasure | UnitQuotient UnitOfMeasure UnitOfMeasure | UnitExponentiation UnitOfMeasure UnitPower + | UnitRecord [(String, UnitOfMeasure)] deriving Data instance Show UnitOfMeasure where @@ -103,6 +113,7 @@ show (UnitProduct uom1 uom2) = show uom1 ++ " " ++ show uom2 show (UnitQuotient uom1 uom2) = show uom1 ++ " / " ++ show uom2 show (UnitExponentiation uom exp) = show uom ++ "** (" ++ show exp ++ ")" + show (UnitRecord recs) = "record (" ++ intercalate ", " (map (\ (n, u) -> n ++ " :: " ++ show u) recs) ++ ")" data UnitPower = UnitPowerInteger Integer @@ -123,6 +134,7 @@ | TEqual | TLeftPar | TRightPar + | TRecord | TId String | TNum String deriving (Show) @@ -158,9 +170,10 @@ lexer' ('(':xs) = addToTokens TLeftPar xs lexer' (')':xs) = addToTokens TRightPar xs lexer' (x:xs) - | isLetter x = aux (\c -> isAlphaNum c || c `elem` ['\'','_','-']) TId - | isNumber x = aux isNumber TNum - | otherwise = failWith $ "Not valid unit syntax at " ++ show (x:xs) ++ "\n" + | isLetter x || x == '\'' = aux (\ c -> isAlphaNum c || c `elem` ['\'','_','-']) + (\ s -> if s == "record" then TRecord else TId s) + | isNumber x = aux isNumber TNum + | otherwise = failWith $ "Not valid unit syntax at " ++ show (x:xs) ++ "\n" where aux p cons = let (target, rest) = span p xs diff --git a/src/Camfort/Specification/Units/Synthesis.hs b/src/Camfort/Specification/Units/Synthesis.hs --- a/src/Camfort/Specification/Units/Synthesis.hs +++ b/src/Camfort/Specification/Units/Synthesis.hs @@ -14,7 +14,7 @@ limitations under the License. -} -{-# LANGUAGE PatternGuards, ScopedTypeVariables, ImplicitParams, DoAndIfThenElse, ConstraintKinds #-} +{-# LANGUAGE PatternGuards, ScopedTypeVariables, ImplicitParams, DoAndIfThenElse, ConstraintKinds, TupleSections #-} module Camfort.Specification.Units.Synthesis (runSynthesis) @@ -37,18 +37,21 @@ import qualified Language.Fortran.Analysis as FA import qualified Language.Fortran.Analysis.Renaming as FAR import qualified Language.Fortran.Util.Position as FU +import Language.Fortran.ParserMonad (FortranVersion(Fortran90)) import qualified Camfort.Specification.Units.Parser as P import Camfort.Analysis.CommentAnnotator import Camfort.Analysis.Annotations hiding (Unitless) import Camfort.Specification.Units.Environment import Camfort.Specification.Units.Monad +import Camfort.Specification.Units.InferenceFrontend (puName, puSrcName) import qualified Debug.Trace as D -- | Insert unit declarations into the ProgramFile as comments. runSynthesis :: Char -> [(VV, UnitInfo)] -> UnitSolver [(VV, UnitInfo)] runSynthesis marker vars = do - modifyProgramFileM $ descendBiM (synthBlocks marker vars) -- descendBiM finds the head of lists + -- descendBiM finds the head of lists + modifyProgramFileM $ descendBiM (synthProgramUnits marker vars) <=< descendBiM (synthBlocks marker vars) return vars -- Should be invoked on the beginning of a list of blocks @@ -75,9 +78,9 @@ -- Create a zero-length span for the new comment node. let newSS = FU.SrcSpan (lp {FU.posColumn = 0}) (lp {FU.posColumn = 0}) -- Build the text of the comment with the unit annotation. - let txt = marker:" " ++ showUnitDecl (e, u) + let txt = marker:" " ++ showUnitDecl (FA.srcName e, u) let space = FU.posColumn lp - 1 - let newB = F.BlComment newA newSS . insertSpacing space $ commentText pf txt + let newB = F.BlComment newA newSS . F.Comment . insertSpacing pf space $ commentText pf txt return $ Just newB where vname = FA.varName e @@ -86,14 +89,53 @@ return (b:reverse newBs ++ bs) synthBlock _ _ bs b = return (b:bs) +-- Should be invoked on the beginning of a list of program units +synthProgramUnits :: Char -> [(VV, UnitInfo)] -> [F.ProgramUnit UA] -> UnitSolver [F.ProgramUnit UA] +synthProgramUnits marker vars pus = do + fmap reverse . foldM (synthProgramUnit marker vars) [] $ pus + +-- Process an individual program unit while building up a list of +-- program units (in reverse order) to ultimately replace the original +-- list of program units. We're looking for functions, in particular, +-- in order to possibly insert a unit annotation before them. +synthProgramUnit :: Char -> [(VV, UnitInfo)] -> [F.ProgramUnit UA] -> F.ProgramUnit UA -> UnitSolver [F.ProgramUnit UA] +synthProgramUnit marker vars pus pu@(F.PUFunction a ss@(FU.SrcSpan lp up) _ _ _ _ mret _ _) = do + pf <- usProgramFile `fmap` get + gvSet <- usGivenVarSet `fmap` get + let (vname, sname) = case mret of Just e -> (FA.varName e, FA.srcName e) + Nothing -> (puName pu, puSrcName pu) + case lookup (vname, sname) vars of + -- if return var has a unit & not a member of the already-given variables + Just u | vname `S.notMember` gvSet -> do + let newA = a { FA.prevAnnotation = (FA.prevAnnotation a) { + prevAnnotation = (prevAnnotation (FA.prevAnnotation a)) { + refactored = Just lp } } } + -- Create a zero-length span for the new comment node. + let newSS = FU.SrcSpan (lp {FU.posColumn = 0}) (lp {FU.posColumn = 0}) + -- Build the text of the comment with the unit annotation. + let txt = marker:" " ++ showUnitDecl (sname, u) + let space = FU.posColumn lp - 1 + let newPU = F.PUComment newA newSS . F.Comment . insertSpacing pf space $ commentText pf txt + + -- recursively descend to find program units inside of current one + fmap (:newPU:pus) $ descendBiM (synthProgramUnits marker vars) pu + + -- otherwise, nevermind, but still recursively descend to find + -- program units inside of current one + _ -> fmap (:pus) $ descendBiM (synthProgramUnits marker vars) pu +synthProgramUnit marker vars pus pu = fmap (:pus) $ descendBiM (synthProgramUnits marker vars) pu + -- Insert the correct comment markers around the given text string, depending on Fortran version. --- FIXME: use Fortran meta information when I have finished adding it to ProgramFile. commentText :: F.ProgramFile UA -> String -> String -commentText _ text = "!" ++ text +commentText pf text | isModernFortran pf = "!" ++ text + | otherwise = "c" ++ text -- Insert a given amount of spacing before the string. -insertSpacing :: Int -> String -> String -insertSpacing n = (replicate n ' ' ++) +insertSpacing :: F.ProgramFile UA -> Int -> String -> String +insertSpacing pf n | isModernFortran pf = (replicate n ' ' ++) + | otherwise = id -- Pretty print a unit declaration. -showUnitDecl (e, u) = "unit(" ++ show u ++ ") :: " ++ FA.srcName e +showUnitDecl (sname, u) = "unit(" ++ show u ++ ") :: " ++ sname + +isModernFortran (F.ProgramFile (F.MetaInfo { F.miVersion = v }) _ ) = v >= Fortran90 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 @@ -68,7 +68,7 @@ (r ++ r', pfs'', pfM) where (pfs', (r, cg)) = runState (analyseAndRmCommons pfs) ("", []) - meta = F.MetaInfo PM.Fortran90 + meta = F.MetaInfo PM.Fortran90 "" (r', pfM) = introduceModules meta d cg pfs'' = updateUseDecls pfs' cg @@ -229,7 +229,7 @@ [(Filename, F.ProgramFile A)] -> [TLCommon A] -> [(Filename, F.ProgramFile A)] updateUseDecls fps tcs = map perPF fps where - perPF (f, p@(F.ProgramFile (F.MetaInfo v) _ _)) = + perPF (f, p@(F.ProgramFile (F.MetaInfo v _) _)) = (f, transformBi (importIncludeCommons v) $ transformBi (matchPUnit v f) p) tcrs = mkTLCommonRenamers tcs @@ -335,6 +335,7 @@ getUnitStartPosition (F.PUFunction _ _ _ _ _ _ _ bs _) = FU.getSpan (head bs) getUnitStartPosition (F.PUBlockData _ s _ []) = s getUnitStartPosition (F.PUBlockData _ _ _ bs) = FU.getSpan (head bs) +getUnitStartPosition (F.PUComment _ s _) = s renamerToUse :: RenamerCoercer -> [(F.Name, F.Name)] renamerToUse Nothing = [] @@ -419,7 +420,7 @@ mkModuleFile :: F.MetaInfo -> Directory -> TLCommon A -> (Report, (Filename, F.ProgramFile A)) mkModuleFile meta dir (_, (_, (name, varTys))) = - (r, (path, F.ProgramFile meta [([], mod)] [])) + (r, (path, F.pfSetFilename path $ F.ProgramFile meta [mod])) where modname = commonName name path = dir ++ modname ++ ".f90" diff --git a/src/Camfort/Transformation/DataTypeIntroduction.hs b/src/Camfort/Transformation/DataTypeIntroduction.hs new file mode 100644 --- /dev/null +++ b/src/Camfort/Transformation/DataTypeIntroduction.hs @@ -0,0 +1,104 @@ +{- + Copyright 2016, 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 FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} + +module Camfort.Transformation.DataTypeIntroduction where + +import qualified Language.Fortran.AST as F +import qualified Language.Fortran.Analysis as FA +import qualified Language.Fortran.Analysis.DataFlow as FAD +import qualified Language.Fortran.Analysis.Renaming as FAR +import qualified Language.Fortran.Analysis.BBlocks as FAB +import qualified Language.Fortran.Analysis.Types as FAT +import qualified Language.Fortran.Util.Position as FU +import qualified Language.Fortran.ParserMonad as PM +import qualified Language.Fortran.PrettyPrint as PP + +import qualified Data.Graph.Inductive.PatriciaTree as G +import qualified Data.Graph.Inductive.Graph as IGr +import qualified Data.Map.Lazy as M +import Data.Generics.Uniplate.Operations + +import qualified Data.Set as S +import Control.Monad.State.Lazy + +import Camfort.Helpers +import Camfort.Helpers.Syntax +import Camfort.Analysis.Annotations + +import qualified Data.IntMap as IM + +-- Array-subscript interference graphs, in a map from +-- the array variable to the interference graph +type IGraphs = M.Map F.Name (G.Gr F.Name Int) + +-- Top-level +dataTypeIntro :: + [(Filename, F.ProgramFile A)] -> (Report, [(Filename, F.ProgramFile A)]) +dataTypeIntro pfs = (r, []) + where + r = buildInterferenceGraph pfs + +-- Stub, coalesce LVA information +-- TODO, build interference graph +buildInterferenceGraph :: [(Filename, F.ProgramFile A)] -> String +buildInterferenceGraph = show . (foldr IM.union IM.empty) . map analysePerPF + +-- Stub, generate LVA information +analysePerPF :: + (Filename, F.ProgramFile A) -> FAD.InOutMap (S.Set F.Name) +analysePerPF (fname, pf) = undefined + where + -- (report, pf'') = transformBiM (perStmt lva) pf + -- initialise analysis + pf' = FAB.analyseBBlocks . FAR.analyseRenames . FA.initAnalysis $ pf + -- get map of program unit ==> basic block graph + bbm = FAB.genBBlockMap pf' + -- build the supergraph of global dependency + sgr = FAB.genSuperBBGr bbm + -- extract the supergraph itself + gr = FAB.superBBGrGraph sgr + -- live variables + lva = FAD.liveVariableAnalysis gr + +-- Core of the transformation happens here on assignment statements +--perStmt :: FAD.InOutMap -> S.Set F.Name +-- -> F.Statement (FA.Analysis A) -> State IGraphs (F.Statement (FA.Analysis A)) +perStmt lva x = + case (FA.insLabel (F.getAnnotation x)) of + Just label -> case (IM.lookup label lva) of + Just (lva_in, _) -> undefined -- transformBiM (perStmt lva_in) x + +{- +perExpr :: FAD.InOutMap (S.Set F.Name) + -> F.Expression (FA.Analysis A) -> State IGraphs (F.Expression (FA.Analysis A)) +perExpr lva_in x@(F.ExpSubscript _ _ (F.ExpValue _ _ (F.ValVariable arrVar)) subs) = do + let subscript_vars = [v | (F.ValVariable v) <- universeBi (F.aStrip subs) ] + let intefering = [(v, w) | v <- subscript_vars, + w <- subscript_vars, v `S.member` lva_in && w `S.member` lva_in] + igraphs <- get + case (M.lookup arrVar igraphs) of + Just igraph -> return x + -- TODO: update graph here + Nothing -> do + let g0 = IGr.mkGraph undefined -- [(0, u),(1, v)] [(0, 1, ())] + let m = M.fromList [(arrVar, g0)] + put (m `M.union` igraphs) + return x +perExpr _ x = return x +-} diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -17,20 +17,13 @@ module Main where -import Data.Generics.Uniplate.Operations import System.Console.GetOpt -import System.Directory import System.Environment -import System.IO -import Camfort.Analysis.Annotations hiding (Unitless) import Camfort.Helpers -import Camfort.Output -import Camfort.Input import Camfort.Functionality import Data.Text (pack, unpack, split) -import Data.Maybe {-| The entry point to CamFort. Displays user information, and handlers which functionality is being requested -} @@ -42,17 +35,29 @@ let (func : (inp : _)) = args in case lookup func functionality of Just (fun, _) -> do + (opts, _) <- compilerOpts args + (numReqArgs, outp) <- - if func `elem` outputNotRequired - then if length args >= 3 && (head (args !! 2) == '-') - then return (2, "") - else -- case where an unnecessary output is specified - return (3, "") - else if length args >= 3 - then return (3, args !! 2) - else error $ usage ++ "This mode requires an output " - ++ "file/directory to be specified." - (opts, _) <- compilerOpts (drop numReqArgs args) + if RefactorInPlace `elem` opts + -- Does not check to see if an output directory + -- is also specified since flags come last and therefore + -- override any specification of an output directory + -- (which would come earlier). + then return (2, inp) + else + if func `elem` outputNotRequired + then if length args >= 3 && (head (args !! 2) == '-') + then return (2, "") + else -- case where an unnecessary output is specified + return (3, "") + else if length args >= 3 + then return (3, args !! 2) + else fail $ usage ++ "\nThis mode requires an output\ + \ file/directory to be specified\n\ + \ or use the --inplace flag to set\ + \ the ouput location to be the input\ + \ location." + let excluded_files = map unpack . split (==',') . pack . getExcludes fun inp (excluded_files opts) outp opts Nothing -> putStrLn fullUsageInfo @@ -71,6 +76,8 @@ options = [ Option ['v','?'] ["version"] (NoArg Version) "show version number" + , Option [] ["inplace"] (NoArg RefactorInPlace) + "refactor in place (replaces input files)" , Option ['e'] ["exclude"] (ReqArg Excludes "FILES") "files to exclude (comma separated list, no spaces)" , Option ['l'] ["units-literals"] (ReqArg (Literals . read) "ID") @@ -78,6 +85,9 @@ , Option ['m'] ["stencil-inference-mode"] (ReqArg (StencilInferMode . read . (++ "Mode")) "ID") "stencil specification inference mode. ID = Do, Assign, or Both" + , Option ['I'] ["include-dir"] + (ReqArg IncludeDir "DIR") + "directory to search for precompiled files" , Option [] ["debug"] (NoArg Debug) "enable debug mode" , Option [] ["doxygen"] (NoArg Doxygen) @@ -107,7 +117,8 @@ refactorings = [("common", (common, "common block elimination")), ("equivalence", (equivalences, "equivalence elimination")), - ("dead", (dead, "dead-code elimination"))] + ("dead", (dead, "dead-code elimination")), + ("datatype", (datatypes, "derived data type introduction"))] {-| List of analses provided by CamFort -} analyses :: [(String @@ -125,7 +136,8 @@ \units-of-measure for maximum coverage")), ("units-check", (unitsCheck, "unit-of-measure checking")), ("units-infer", (unitsInfer, "unit-of-measure inference")), - ("units-synth", (unitsSynth, "unit-of-measure synthesise specs.")) ] + ("units-synth", (unitsSynth, "unit-of-measure synthesise specs.")), + ("units-compile", (unitsCompile, "units-of-measure compile module information.")) ] -- * Usage and about information version = "0.902" 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 @@ -54,7 +54,7 @@ -- Some helper functions varGen x = ExpValue ea p (ValVariable x) intGen i = ExpValue ea p (ValInteger (show i)) -wrapBlocks bs = ProgramFile (MetaInfo { miVersion = Fortran90 }) [ ([], pu) ] [] +wrapBlocks bs = ProgramFile (MetaInfo { miVersion = Fortran90, miFilename = "" }) [ pu ] where pu = PUModule ea p "my_module" bs Nothing @@ -67,56 +67,56 @@ pf2 = wrapBlocks bs2 bs2 = - [ BlComment ea p "something" + [ BlComment ea p (Comment "something") , BlStatement ea p Nothing (StPause ea p Nothing) ] pf2e = wrapBlocks bs2e bs2e = - [ BlComment (A (Just (bs2e !! 1)) (Just "hello")) p "something" + [ BlComment (A (Just (bs2e !! 1)) (Just "hello")) p (Comment "something") , BlStatement ea p Nothing (StPause ea p Nothing) ] pf3 = wrapBlocks bs3 bs3 = - [ BlComment ea p "mistral" - , BlComment ea p "orhan" - , BlComment ea p "jean-pierre" - , BlComment ea p "contrastin" + [ BlComment ea p (Comment "mistral") + , BlComment ea p (Comment "orhan") + , BlComment ea p (Comment "jean-pierre") + , BlComment ea p (Comment "contrastin") , BlStatement ea p Nothing (StPause ea p Nothing) ] pf3e = wrapBlocks bs3e bs3e = - [ BlComment (A (Just (last bs3e)) (Just "!!!mistral")) p "mistral" - , BlComment (A (Just (last bs3e)) (Just "!!!orhan")) p "orhan" - , BlComment (A (Just (last bs3e)) (Just "!!!jean-pierre")) p "jean-pierre" - , BlComment (A (Just (last bs3e)) (Just "!!!contrastin")) p "contrastin" + [ BlComment (A (Just (last bs3e)) (Just "!!!mistral")) p (Comment "mistral") + , BlComment (A (Just (last bs3e)) (Just "!!!orhan")) p (Comment "orhan") + , BlComment (A (Just (last bs3e)) (Just "!!!jean-pierre")) p (Comment "jean-pierre") + , BlComment (A (Just (last bs3e)) (Just "!!!contrastin")) p (Comment "contrastin") , BlStatement ea p Nothing (StPause ea p Nothing) ] pf4 = wrapBlocks bs4 bs4 = - [ BlComment ea p "mistral" - , BlComment ea p "contrastin" + [ BlComment ea p (Comment "mistral") + , BlComment ea p (Comment "contrastin") , BlStatement ea p Nothing (StPause ea p Nothing) - , BlComment ea p "dominic" - , BlComment ea p "orchard" + , BlComment ea p (Comment "dominic") + , BlComment ea p (Comment "orchard") , BlStatement ea p Nothing (StExpressionAssign ea p (varGen "x") (intGen 42)) ] pf4e = wrapBlocks bs4e bs4e = - [ BlComment (A (Just (bs4e !! 2)) (Just "!!!mistral")) p "mistral" - , BlComment (A (Just (bs4e !! 2)) (Just "!!!contrastin")) p "contrastin" + [ BlComment (A (Just (bs4e !! 2)) (Just "!!!mistral")) p (Comment "mistral") + , BlComment (A (Just (bs4e !! 2)) (Just "!!!contrastin")) p (Comment "contrastin") , BlStatement ea p Nothing (StPause ea p Nothing) - , BlComment (A (Just (last bs4e)) (Just "!!!dominic")) p "dominic" - , BlComment (A (Just (last bs4e)) (Just "!!!orchard")) p "orchard" + , BlComment (A (Just (last bs4e)) (Just "!!!dominic")) p (Comment "dominic") + , BlComment (A (Just (last bs4e)) (Just "!!!orchard")) p (Comment "orchard") , BlStatement ea p Nothing (StExpressionAssign ea p (varGen "x") (intGen 42)) ] pf5 = wrapBlocks bs5 bs5 = - [ BlComment ea p "comment 1" - , BlComment ea p "comment 2" + [ BlComment ea p (Comment "comment 1") + , BlComment ea p (Comment "comment 2") , BlStatement ea p Nothing (StPause ea p Nothing) ] pf5e = wrapBlocks bs5e bs5e = - [ BlComment (A (Just (last bs5e)) Nothing) p "comment 1" - , BlComment (A (Just (last bs5e)) Nothing) p "comment 2" + [ BlComment (A (Just (last bs5e)) Nothing) p (Comment "comment 1") + , BlComment (A (Just (last bs5e)) Nothing) p (Comment "comment 2") , BlStatement ea p Nothing (StPause ea p Nothing) ] diff --git a/tests/Camfort/Helpers/VecSpec.hs b/tests/Camfort/Helpers/VecSpec.hs deleted file mode 100644 --- a/tests/Camfort/Helpers/VecSpec.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE DataKinds, FlexibleInstances, FlexibleContexts, ScopedTypeVariables #-} -module Camfort.Helpers.VecSpec where - -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck (Arbitrary(..), Gen(..)) - -import Camfort.Helpers.Vec - -instance Arbitrary a => Arbitrary (Vec Z a) where - arbitrary = return Nil -instance (Arbitrary (Vec n a), Arbitrary a) => Arbitrary (Vec (S n) a) where - arbitrary = do x <- arbitrary :: Gen a - xs <- arbitrary :: Gen (Vec n a) - return $ Cons x xs - -spec :: Spec -spec = - describe "Vector" $ - it "TODO" - pending diff --git a/tests/Camfort/Specification/Stencils/CheckSpec.hs b/tests/Camfort/Specification/Stencils/CheckSpec.hs --- a/tests/Camfort/Specification/Stencils/CheckSpec.hs +++ b/tests/Camfort/Specification/Stencils/CheckSpec.hs @@ -6,6 +6,7 @@ import Camfort.Specification.Stencils.CheckBackend import Camfort.Specification.Stencils.CheckFrontend import qualified Camfort.Specification.Stencils.Grammar as SYN +import Camfort.Specification.Stencils.Model import Camfort.Specification.Stencils.Syntax import Test.Hspec @@ -27,38 +28,38 @@ parseAndConvert "= stencil forward(depth=1, dim=1) :: x" `shouldBe` (Right $ Right [(["x"], Specification $ - Multiple $ Exact (Spatial (Sum [Product [Forward 1 1 True]])))]) + Mult $ Exact (Spatial (Sum [Product [Forward 1 1 True]])))]) it "parse and convert simple exact stencil (2)" $ parseAndConvert "= stencil forward(depth=1, dim=1) :: x, y, z" `shouldBe` (Right $ Right [(["x","y","z"], Specification $ - Multiple $ Exact (Spatial (Sum [Product [Forward 1 1 True]])))]) + Mult $ Exact (Spatial (Sum [Product [Forward 1 1 True]])))]) - it "parse and convert simple exact stencil with irreflexive (2a)" $ - parseAndConvert "= stencil centered(depth=1, dim=2, irreflexive) :: x, y, z" + it "parse and convert simple exact stencil with nonpointed (2a)" $ + parseAndConvert "= stencil centered(depth=1, dim=2, nonpointed) :: x, y, z" `shouldBe` (Right $ Right [(["x","y","z"], Specification $ - Multiple $ Exact (Spatial (Sum [Product [Centered 1 2 False]])))]) + Mult $ Exact (Spatial (Sum [Product [Centered 1 2 False]])))]) it "parse and convert simple upper bounded stencil (3)" $ parseAndConvert "= stencil atmost, forward(depth=1, dim=1) :: x" `shouldBe` (Right $ Right [(["x"], Specification $ - Multiple $ Bound Nothing (Just $ Spatial + Mult $ Bound Nothing (Just $ Spatial (Sum [Product [Forward 1 1 True]])))]) it "parse and convert simple lower bounded stencil (4)" $ parseAndConvert "= stencil atleast, backward(depth=2, dim=1) :: x" `shouldBe` (Right $ Right [(["x"], Specification $ - Multiple $ Bound (Just $ Spatial + Mult $ Bound (Just $ Spatial (Sum [Product [Backward 2 1 True]])) Nothing)]) it "parse and convert stencil requiring distribution (5)" $ parseAndConvert "= stencil atleast, readonce, (forward(depth=1, dim=1) * ((centered(depth=1, dim=2)) + backward(depth=3, dim=4))) :: frob" `shouldBe` (Right $ Right [(["frob"], Specification $ - Single $ Bound (Just $ Spatial + Once $ Bound (Just $ Spatial (Sum [Product [Forward 1 1 True, Centered 1 2 True], Product [Forward 1 1 True, Backward 3 4 True]])) Nothing)]) diff --git a/tests/Camfort/Specification/Stencils/ConsistencySpec.hs b/tests/Camfort/Specification/Stencils/ConsistencySpec.hs new file mode 100644 --- /dev/null +++ b/tests/Camfort/Specification/Stencils/ConsistencySpec.hs @@ -0,0 +1,37 @@ +module Camfort.Specification.Stencils.ConsistencySpec (spec) where + +import qualified Camfort.Helpers.Vec as V + +import Camfort.Specification.Stencils.Model +import Camfort.Specification.Stencils.Consistency +import Camfort.Specification.Stencils.Syntax + +import qualified Data.Set as S +import Algebra.Lattice + +import Test.Hspec + +spec :: Spec +spec = + describe "Consistency spec" $ do + let fivePointSpec = Specification . Once . Exact . Spatial $ + Sum [ Product [ Centered 1 1 True, Centered 0 2 True ] + , Product [ Centered 1 2 True, Centered 0 1 True ] ] + let offFivePoint = + return (V.Cons (Offsets . S.fromList $ [-1]) + (V.Cons (Offsets . S.fromList $ [0]) V.Nil)) + \/ + return (V.Cons (Offsets . S.fromList $ [0]) + (V.Cons (Offsets . S.fromList $ [0]) V.Nil)) + \/ + return (V.Cons (Offsets . S.fromList $ [1]) + (V.Cons (Offsets . S.fromList $ [0]) V.Nil)) + \/ + return (V.Cons (Offsets . S.fromList $ [0]) + (V.Cons (Offsets . S.fromList $ [-1]) V.Nil)) + \/ + return (V.Cons (Offsets . S.fromList $ [0]) + (V.Cons (Offsets . S.fromList $ [1]) V.Nil)) + let fivePointIndices = Once offFivePoint + it "finds read once five point stencil consistent with its indices" $ + fivePointSpec `consistent` fivePointIndices `shouldBe` Consistent diff --git a/tests/Camfort/Specification/Stencils/DenotationalSemanticsSpec.hs b/tests/Camfort/Specification/Stencils/DenotationalSemanticsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Camfort/Specification/Stencils/DenotationalSemanticsSpec.hs @@ -0,0 +1,41 @@ +module Camfort.Specification.Stencils.DenotationalSemanticsSpec (spec) where + +import qualified Camfort.Helpers.Vec as V + +import Camfort.Specification.Stencils.Model +import Camfort.Specification.Stencils.Consistency +import Camfort.Specification.Stencils.Syntax +import Camfort.Specification.Stencils.DenotationalSemantics + +import qualified Data.Set as S +import Algebra.Lattice + +import Test.Hspec + +spec :: Spec +spec = + describe "Denotational semantics spec" $ do + let fivePointSpatial = Spatial $ + Sum [ Product [ Centered 1 1 True, Centered 0 2 True ] + , Product [ Centered 1 2 True, Centered 0 1 True ] ] + it "transforms five point spatial correctly to union normal form" $ do + let regFivePoint = Right $ + return (V.Cons (IntervHoled (-1) 1 True) + (V.Cons (IntervHoled 0 0 True) V.Nil)) + \/ + return (V.Cons (IntervHoled 0 0 True) + (V.Cons (IntervHoled (-1) 1 True) V.Nil)) + shouldBe (regionsToIntervals (V.Succ (V.Succ V.Zero)) fivePointSpatial) + regFivePoint + + it "handles interval to region example" $ do + let reg = + return (V.Cons (IntervHoled 0 0 True) + (V.Cons (IntervHoled 0 1 False) V.Nil)) + \/ + return (V.Cons (IntervHoled 0 2 False) + (V.Cons (IntervHoled 0 2 False) V.Nil)) + let spec = Right $ Spatial $ + Sum [ Product [ Centered 0 1 True, Forward 1 2 False ] + , Product [ Forward 2 1 False, Forward 2 2 False ] ] + intervalsToRegions reg `shouldBe` spec diff --git a/tests/Camfort/Specification/Stencils/GrammarSpec.hs b/tests/Camfort/Specification/Stencils/GrammarSpec.hs --- a/tests/Camfort/Specification/Stencils/GrammarSpec.hs +++ b/tests/Camfort/Specification/Stencils/GrammarSpec.hs @@ -15,10 +15,10 @@ Right (SpecDec (Spatial [] (Or (Var "r1") (Var "r2"))) ["a"]) {- Should no longer be possible - it "just reflexive stencil" $ - parse "= stencil reflexive(dims=1,2) :: a" + it "just pointed stencil" $ + parse "= stencil pointed(dims=1,2) :: a" `shouldBe` - Right (SpecDec (Spatial [Reflexive [1, 2]] Nothing) ["a"]) + Right (SpecDec (Spatial [Pointed [1, 2]] Nothing) ["a"]) -} @@ -29,16 +29,16 @@ {- Should no longer be possible it "basic monfieid stencil (2)" $ - parse "= stencil atleast, reflexive(dims=1,2), \ + parse "= stencil atleast, pointed(dims=1,2), \ \ forward(depth=1, dim=1) :: x" `shouldBe` - Right (SpecDec (Spatial [AtLeast,Reflexive [1,2]] (Just $ Forward 1 1)) ["x"]) + Right (SpecDec (Spatial [AtLeast,Pointed [1,2]] (Just $ Forward 1 1)) ["x"]) - it "basic stencil with reflexive and irreflexive" $ - parse "= stencil atleast, reflexive(dims=2), \ - \ irreflexive(dims=1), forward(depth=1, dim=1) :: frob" + it "basic stencil with pointed and nonpointed" $ + parse "= stencil atleast, pointed(dims=2), \ + \ nonpointed(dims=1), forward(depth=1, dim=1) :: frob" `shouldBe` - Right (SpecDec (Spatial [AtLeast, Irreflexive [1], Reflexive [2]] + Right (SpecDec (Spatial [AtLeast, Nonpointed [1], Pointed [2]] (Just $ Forward 1 1)) ["frob"]) -} @@ -53,33 +53,33 @@ Right (RegionDec "r" (Or (Forward 1 1 True) (Backward 2 2 True))) it "region defn irreflx syntactic permutation" $ - parse "= region :: r = forward(irreflexive,dim=1,depth=1) + backward(depth=2,irreflexive,dim=2)" + parse "= region :: r = forward(nonpointed,dim=1,depth=1) + backward(depth=2,nonpointed,dim=2)" `shouldBe` Right (RegionDec "r" (Or (Forward 1 1 False) (Backward 2 2 False))) {- Should no longer be possible it "complex stencil" $ - parse "= stencil atleast, reflexive(dims=1,2), readonce, \ + parse "= stencil atleast, pointed(dims=1,2), readonce, \ \ (forward(depth=1, dim=1) + r) * backward(depth=3, dim=4) \ \ :: frob" `shouldBe` - Right (SpecDec (Spatial [AtLeast,ReadOnce,Reflexive [1,2]] + Right (SpecDec (Spatial [AtLeast,ReadOnce,Pointed [1,2]] (Just $ And (Or (Forward 1 1) (Var "r")) (Backward 3 4))) ["frob"]) it "invalid stencil (atLeast/atMost)" $ - parse "= stencil atleast, atmost, reflexive(dims=1,2), \ + parse "= stencil atleast, atmost, pointed(dims=1,2), \ \ forward(depth=1, dim=1) :: x" `shouldBe` (Left $ ProbablyAnnotation $ "Conflicting modifiers: cannot use 'atLeast' and 'atMost' together") - it "invalid stencil (reflexive/irreflexive on same dim)" $ - parse "= stencil atleast, irreflexive(dims=2), reflexive(dims=1,2), \ + it "invalid stencil (pointed/nonpointed on same dim)" $ + parse "= stencil atleast, nonpointed(dims=2), pointed(dims=1,2), \ \ forward(depth=1, dim=1) :: x" `shouldBe` (Left $ ProbablyAnnotation $ "Conflicting modifiers: stencil marked as both\ - \ irreflexive and reflexive in dimensions = 2") + \ nonpointed and pointed in dimensions = 2") -} diff --git a/tests/Camfort/Specification/Stencils/InferenceBackendSpec.hs b/tests/Camfort/Specification/Stencils/InferenceBackendSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Camfort/Specification/Stencils/InferenceBackendSpec.hs @@ -0,0 +1,32 @@ +module Camfort.Specification.Stencils.InferenceBackendSpec (spec) where + +import Camfort.Specification.Stencils.InferenceBackend +import Camfort.Specification.Stencils.Syntax +import Camfort.Specification.Stencils.Model +import qualified Camfort.Helpers.Vec as V + +import Test.Hspec + +spec :: Spec +spec = + describe "Inference backend" $ do + describe "spans to approximate regions" $ do + + it "handles spans of a(i-2) + a(i) + a(i+2)" $ do + let spans = [ (V.Cons (-2) V.Nil, V.Cons (-2) V.Nil) + , (V.Cons 0 V.Nil, V.Cons 0 V.Nil) + , (V.Cons 2 V.Nil, V.Cons 2 V.Nil) ] + let region = Right $ Bound + (Just . Spatial $ Sum [ Product [ Centered 0 1 True ]]) + (Just . Spatial $ Sum [ Product [ Centered 2 1 True ]]) + spansToApproxSpatial spans `shouldBe` region + + it "handles spans of a(i,0) + a(0,j)" $ do + let spans = [ ( V.Cons 0 (V.Cons absoluteRep V.Nil) + , V.Cons 0 (V.Cons absoluteRep V.Nil) ) + , ( V.Cons absoluteRep (V.Cons 0 V.Nil) + , V.Cons absoluteRep (V.Cons 0 V.Nil) ) ] + let region = Right . Exact . Spatial $ + Sum [ Product [ Centered 0 1 True ] + , Product [ Centered 0 2 True ] ] + spansToApproxSpatial spans `shouldBe` region diff --git a/tests/Camfort/Specification/Stencils/ModelSpec.hs b/tests/Camfort/Specification/Stencils/ModelSpec.hs --- a/tests/Camfort/Specification/Stencils/ModelSpec.hs +++ b/tests/Camfort/Specification/Stencils/ModelSpec.hs @@ -1,217 +1,151 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE DataKinds #-} module Camfort.Specification.Stencils.ModelSpec (spec) where -import Camfort.Helpers.Vec -import Camfort.Specification.Stencils -import Camfort.Specification.Stencils.Synthesis -import Camfort.Specification.Stencils.Model -import Camfort.Specification.Stencils.Syntax hiding (Spec) -import qualified Camfort.Specification.Stencils.Syntax as Syn - -import Camfort.Analysis.Annotations -import qualified Language.Fortran.AST as F -import Language.Fortran.Util.Position +import Algebra.Lattice +import qualified Data.Set as S +import Data.List.NonEmpty +import qualified Camfort.Helpers.Vec as V -import Data.Bits -import Data.List -import Data.Set (toList) +import Camfort.Specification.Stencils.Model import Test.Hspec -import Test.QuickCheck -import Test.Hspec.QuickCheck spec :: Spec -spec = do - describe "Consistency of model vs access patterns" $ do - let singleOneDimSpec = Single $ Exact $ Spatial $ Sum - [ Product [ Forward 1 1 True ] ] - it "1D readOnce - positive" $ do - let acs = Single [[0], [1]] - consistent acs singleOneDimSpec `shouldBe` True - - it "1D readOnce - negative" $ do - let acs = Multiple [[0], [1]] - consistent acs singleOneDimSpec `shouldBe` False - - let reflCentOneDimSpec = Single $ Exact $ Spatial $ Sum - [ Product [ Centered 1 1 False ] ] - it "1D centered irreflexive - positive" $ do - let acs = Single [[-1], [1]] - consistent acs reflCentOneDimSpec `shouldBe` True - - let centeredAcs = Single [[-1], [0], [1]] - it "1D centered irreflexive - negative" $ - consistent centeredAcs reflCentOneDimSpec `shouldBe` False - - it "1D centered irreflexive lower bound - positive" $ do - let spec = Single $ Bound - (Just $ Spatial $ Sum [ Product [ Centered 1 1 False ] ]) - Nothing - consistent centeredAcs spec `shouldBe` True - - it "1D backward irreflexive lower bound - positive" $ do - let spec = Single $ Bound - (Just $ Spatial $ Sum [ Product [ Backward 1 1 False ] ]) - Nothing - consistent (Single [[-1]]) spec `shouldBe` True - - it "1D centered irreflexive upper bound - negative" $ do - let spec = Single $ Bound - Nothing - (Just $ Spatial $ Sum [ Product [ Centered 1 1 False ] ]) - consistent centeredAcs spec `shouldBe` False - - it "1D double bounded" $ do - let acs = Single [ [-3], [-2], [-1], [0], [1], [3] ] - let spec = Single $ Bound - (Just $ Spatial $ Sum [ Product [ Centered 1 1 True ] ]) - (Just $ Spatial $ Sum [ Product [ Centered 1 3 True ] ]) - consistent acs spec `shouldBe` True - - it "1D spec 3D access" $ do - let acs = Single [ [0,1,-2], [absoluteRep, 2,3] ] - let spec = Single $ Exact $ - Spatial $ Sum [ Product [ Forward 2 2 False ] ] - consistent acs spec `shouldBe` True - - let twoDimSpec = Single $ Exact $ - Spatial $ Sum [ Product [ Centered 0 1 True, Forward 1 2 True ] ] - - it "2 dimensional spec example" $ do - let acs = Single [ [0,0], [0,1] ] - consistent acs twoDimSpec `shouldBe` True - - it "Constant access not allowed in otherwise fine access pattern" $ do - let acs = Single [ [0,0], [0,1], [absoluteRep, absoluteRep] ] - consistent acs twoDimSpec `shouldBe` False - - describe "Stencils - Model" $ do - describe "Test soundness of model 1" modelHasLeftInverse - describe "Test soundness of model 2" $ modelHasApproxLeftInverse variations2 - describe "Test soundness of model 3" $ modelHasApproxLeftInverse variations3 - - describe "Consistency of model with paper" $ do - describe "Quickcheck" $ it "" $ property propPairwisePerm - - describe "Manual for absolute rep" $ do - it "Check absolute rep (0)" $ - sort (pp [1,2,absoluteRep] [5,1,7]) - `shouldBe` sort (pairwisePerm [1,2,absoluteRep] [5,1,7]) - - it "Check absolute rep (1)" $ - sort (pp [1,absoluteRep] [5,1]) - `shouldBe` sort (pairwisePerm [1,absoluteRep] [5,1]) - - it "Check absolute rep (2)" $ - sort (pp [absoluteRep,2,absoluteRep] [absoluteRep,1,7]) - `shouldBe` sort (pairwisePerm [absoluteRep,2,absoluteRep] [absoluteRep,1,7]) - - -propPairwisePerm :: [Int] -> [Int] -> Bool -propPairwisePerm x y = - if length x == length y && length x < 16 - then (sort . nub $ pp x y) == (sort . nub $ pairwisePerm x y) - else True - -pp :: [Int] -> [Int] -> [[Int]] -pp x y = - let n = length x - in map (\i -> - map (\j -> ((x !! j) `times` not (testBit i j)) - `plus` - ((y !! j) `times` testBit i j) - ) [0..(n-1)] - ) [0 :: Int .. ((2^n)-1)] - where times x True = x - times x False = 0 - plus x y = x + y - - -variations :: [([[Int]], Syn.Multiplicity (Syn.Approximation Spatial))] -variations = - [ ([ [1], [0] ], - Multiple $ Exact $ Spatial (Sum [Product [Forward 1 1 True]])) - - , ([ [absoluteRep,1], [absoluteRep,0] ], - Multiple $ Exact $ Spatial (Sum [Product [Forward 1 2 True]])) - - , ([ [1,1], [0,1], [1,0], [0,0] ], - Multiple $ Exact $ Spatial (Sum [Product [Forward 1 1 True, Forward 1 2 True]])) +spec = + describe "Model spec" $ do + let regFivePoint = + return (V.Cons (IntervHoled (-1) 1 True) + (V.Cons (IntervHoled 0 0 True) V.Nil)) + \/ + return (V.Cons (IntervHoled 0 0 True) + (V.Cons (IntervHoled (-1) 1 True) V.Nil)) - , ([ [-1, 1], [0, 1] ], - Multiple $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Forward 1 2 False]])) + describe "unfCompare" $ do + let reg1 = + return (V.Cons (IntervHoled 0 2 False) (V.Cons (IntervHoled 0 2 False) V.Nil)) + \/ + return (V.Cons (IntervHoled 0 1 True) (V.Cons (IntervHoled 0 2 False) V.Nil)) + let reg2 = return $ V.Cons (IntervHoled 0 2 True) (V.Cons (IntervHoled 0 2 False) V.Nil) + it "compares equal regions" $ + unfCompare reg1 reg2 `shouldBe` EQ - , ([ [-1], [0] ], - Multiple $ Exact $ Spatial (Sum [Product [Backward 1 1 True]])) + let reg3 = + reg2 \/ return (V.Cons (IntervHoled 0 3 False) (V.Cons (IntervHoled 0 0 True) V.Nil)) + it "compares greater regions" $ + unfCompare reg3 reg2 `shouldBe` GT - , ([ [absoluteRep,-1], [absoluteRep,0] ], - Multiple $ Exact $ Spatial (Sum [Product [Backward 1 2 True]])) + let reg4 = reg1 \/ return (V.Cons IntervInfinite $ V.Cons IntervInfinite V.Nil) + it "compares smaller regions" $ + unfCompare reg3 reg4 `shouldBe` LT - , ([ [-1,-1], [0,-1], [-1,0], [0,0] ], - Multiple $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Backward 1 2 True]])) + let prod1 = return $ V.Cons (Offsets . S.fromList $ [2,3,5]) + (V.Cons (Offsets . S.fromList $ [10, 15]) V.Nil) + let prod2 = return $ V.Cons (Offsets . S.fromList $ [2,3,4,5]) + (V.Cons (Offsets . S.fromList $ [10, 12, 15]) V.Nil) + it "compare equal offset products" $ + unfCompare prod1 prod2 `shouldBe` LT - , ( [ [0,-1], [1,-1], [0,0], [1,0], [1,1], [0,1], [2,-1], [2,0], [2,1] ], - Multiple $ Exact $ Spatial - (Sum [Product [ Forward 2 1 True, Centered 1 2 True ] ] )) + let prod3 = prod1 \/ + return (V.Cons (Offsets . S.fromList $ [ 4 ]) + (V.Cons (Offsets . S.fromList $ [ 10, 12, 15 ]) V.Nil)) + \/ + return (V.Cons (Offsets . S.fromList $ [ 2, 3, 4, 5 ]) + (V.Cons (Offsets . S.fromList $ [ 12 ]) V.Nil)) + it "compare equal offset products" $ + unfCompare prod3 prod2 `shouldBe` EQ - , ( [ [-1,0], [-1,1], [0,0], [0,1], [1,1], [1,0], [-1,2], [0,2], [1,2] ], - Multiple $ Exact $ Spatial - (Sum [Product [ Forward 2 2 True, Centered 1 1 True ] ] )) - ] + let regBack = return $ + V.Cons (IntervHoled (-1) 0 True) (V.Cons IntervInfinite V.Nil) + let off = return $ + V.Cons (Offsets . S.fromList $ [-1, 0]) (V.Cons SetOfIntegers V.Nil) + it "compare equal offset and interval" $ + unfCompare regBack off `shouldBe` EQ -variations2 :: [( Syn.Multiplicity (Syn.Approximation [[Int]]) - , Int - , Syn.Multiplicity (Syn.Approximation Spatial) )] -variations2 = - [ - -- Stencil which has some absolute component (not represented in the spec) - ( Multiple $ Exact [ [0, absoluteRep], [1, absoluteRep] ] - , 2 - , Multiple $ Exact $ Spatial (Sum [Product [Forward 1 1 True]]) - ) + let offFivePoint = + return (V.Cons (Offsets . S.fromList $ [-1]) + (V.Cons (Offsets . S.fromList $ [0]) V.Nil)) + \/ + return (V.Cons (Offsets . S.fromList $ [0]) + (V.Cons (Offsets . S.fromList $ [0]) V.Nil)) + \/ + return (V.Cons (Offsets . S.fromList $ [1]) + (V.Cons (Offsets . S.fromList $ [0]) V.Nil)) + \/ + return (V.Cons (Offsets . S.fromList $ [0]) + (V.Cons (Offsets . S.fromList $ [-1]) V.Nil)) + \/ + return (V.Cons (Offsets . S.fromList $ [0]) + (V.Cons (Offsets . S.fromList $ [1]) V.Nil)) + it "compare equal offset and interval" $ + unfCompare regFivePoint offFivePoint `shouldBe` EQ - -- Spec on bounds - , ( Multiple $ Bound Nothing (Just [ [0, absoluteRep], [1, absoluteRep] - , [2, absoluteRep] ]) - , 2 - , Multiple $ Bound Nothing - (Just $ Spatial (Sum [Product [Forward 2 1 True]])) - ) - ] + describe "optimisation" $ do + it "eliminates subsumed products" $ do + let regFivePointPlus = + return (V.Cons (IntervHoled 0 1 True) + (V.Cons (IntervHoled 0 0 True) V.Nil)) + \/ + regFivePoint + \/ + return (V.Cons (IntervHoled 0 1 False) + (V.Cons (IntervHoled 0 0 True) V.Nil)) + \/ + return (V.Cons (IntervHoled 0 0 True) + (V.Cons (IntervHoled (-1) 0 True) V.Nil)) + optimise regFivePointPlus `shouldBe` regFivePoint -variations3 :: [( Syn.Multiplicity (Syn.Approximation [[Int]]) - , Int - , Syn.Multiplicity (Syn.Approximation Spatial) )] -variations3 = - [ - -- Spec on bounds - ( Multiple $ - Bound Nothing (Just [ [0, absoluteRep, 0], [1, absoluteRep, 0] - , [2, absoluteRep, 0], [0, absoluteRep, 1] - , [1, absoluteRep, 1], [2, absoluteRep, 1]]) - , 3 - , Multiple $ - Bound Nothing (Just $ Spatial (Sum [Product [ Forward 1 3 True - , Forward 2 1 True ]])) - ) - ] + it "applies union lemma" $ do + let reg = + return (V.Cons (IntervHoled (-1) 1 False) + (V.Cons (IntervHoled (-2) 0 False) + (V.Cons (IntervHoled (-2) 2 True) V.Nil))) + \/ + return (V.Cons (IntervHoled 0 0 True) + (V.Cons (IntervHoled (-2) 0 False) + (V.Cons (IntervHoled (-2) 2 True) V.Nil))) + \/ + return (V.Cons (IntervHoled (-1) 1 True) + (V.Cons (IntervHoled 0 2 False) + (V.Cons (IntervHoled (-2) 2 True) V.Nil))) + let reg' = + return (V.Cons (IntervHoled (-1) 1 True) + (V.Cons (IntervHoled (-2) 2 False) + (V.Cons (IntervHoled (-2) 2 True) V.Nil))) + optimise reg `shouldBe` reg' -modelHasLeftInverse = mapM_ check (zip variations [0..]) - where - check ((ixs, spec), n) = - it ("("++show n++")") $ - sort mdl `shouldBe` sort ixs - where - mdl = toList . fromExact . fromMult . model' $ spec - model' = flip model $ length . head $ ixs + it "another contains approximation" $ do + let reg = + return (V.Cons (IntervHoled 0 2 False) + (V.Cons (IntervHoled 0 2 False) V.Nil)) + \/ + return (V.Cons (IntervHoled 0 2 False) + (V.Cons (IntervHoled 0 2 False) V.Nil)) + \/ + return (V.Cons (IntervHoled 0 0 True) + (V.Cons (IntervHoled 0 1 False) V.Nil)) + let reg' = + return (V.Cons (IntervHoled 0 2 False) + (V.Cons (IntervHoled 0 2 False) V.Nil)) + \/ + return (V.Cons (IntervHoled 0 0 True) + (V.Cons (IntervHoled 0 1 False) V.Nil)) + optimise reg `shouldBe` reg' -modelHasApproxLeftInverse vars = mapM_ check (zip vars [(0 :: Int)..]) - where - check ((ixs, dims, spec), n) = - it ("("++show n++")") $ mdl `shouldBe` fmap sort <$> ixs - where - mdl = - let ?globalDimensionality = dims - in fmap (sort . toList) <$> mkModel spec + it "another subsumption example" $ do + let reg = + return (V.Cons (IntervHoled 0 2 True) + (V.Cons (IntervHoled (-1) 1 True) V.Nil)) + \/ + return (V.Cons (IntervHoled (-1) 0 True) + (V.Cons (IntervHoled 0 1 True) V.Nil)) + \/ + return (V.Cons (IntervHoled 0 2 True) + (V.Cons (IntervHoled 0 1 True) V.Nil)) + let reg' = + return (V.Cons (IntervHoled 0 2 True) + (V.Cons (IntervHoled (-1) 1 True) V.Nil)) + \/ + return (V.Cons (IntervHoled (-1) 0 True) + (V.Cons (IntervHoled 0 1 True) V.Nil)) + optimise reg `shouldBe` reg' 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 @@ -4,13 +4,15 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeOperators #-} module Camfort.Specification.StencilsSpec (spec) where +import GHC.TypeLits + import Control.Monad.Writer.Strict hiding (Sum, Product) import Data.List -import Camfort.Functionality import Camfort.Helpers.Vec import Camfort.Input import Camfort.Specification.Stencils @@ -19,14 +21,11 @@ import Camfort.Specification.Stencils.InferenceBackend import Camfort.Specification.Stencils.InferenceFrontend import Camfort.Specification.Stencils.Syntax hiding (Spec) -import Camfort.Analysis.Annotations import qualified Language.Fortran.AST as F -import Language.Fortran.Util.Position import Language.Fortran.ParserMonad import Camfort.Reprint import Camfort.Output -import Data.Map.Strict (toList) import qualified Data.IntMap as IM import qualified Data.Set as S import Data.Functor.Identity @@ -36,32 +35,10 @@ import Test.Hspec import Test.QuickCheck -import Test.Hspec.QuickCheck spec :: Spec spec = describe "Stencils" $ do - describe "Idempotence of spanBounding" $ do - it "(0)" $ property $ prop_spanBoundingIdem zeroN - it "(1)" $ property $ prop_spanBoundingIdem oneN - it "(2)" $ property $ prop_spanBoundingIdem twoN - it "(3)" $ property $ prop_spanBoundingIdem threeN - it "(4)" $ property $ prop_spanBoundingIdem fourN - - describe "Associativity of spanBounding" $ do - it "(0)" $ property $ prop_spanBoundingAssoc zeroN - it "(1)" $ property $ prop_spanBoundingAssoc oneN - it "(2)" $ property $ prop_spanBoundingAssoc twoN - it "(3)" $ property $ prop_spanBoundingAssoc threeN - it "(4)" $ property $ prop_spanBoundingAssoc fourN - - describe "Un-permutable permutations on vectors" $ do - it "(0)" $ property $ prop_perms_invertable zeroN - it "(1)" $ property $ prop_perms_invertable oneN - it "(2)" $ property $ prop_perms_invertable twoN - it "(3)" $ property $ prop_perms_invertable threeN - it "(4)" $ property $ prop_perms_invertable fourN - describe "Some checks on containing spans" $ do it "(0)" $ containedWithin (Cons 1 (Cons 1 Nil), Cons 2 (Cons 2 Nil)) (Cons 0 (Cons 0 Nil), Cons 3 (Cons 3 Nil)) @@ -98,32 +75,32 @@ ] :: [Vec (S (S (S Z))) Int]) it "composeRegions (1,0)-(1,0) span and (2,0)-(2,0) span" $ - shouldBe (composeConsecutiveSpans + shouldBe (coalesce (Cons 1 (Cons 0 Nil), Cons 1 (Cons 0 Nil)) (Cons 2 (Cons 0 Nil), Cons 2 (Cons 0 Nil))) - [(Cons 1 (Cons 0 Nil), Cons 2 (Cons 0 Nil))] + $ Just (Cons 1 (Cons 0 Nil), Cons 2 (Cons 0 Nil)) it "composeRegions failing on (1,0)-(2,0) span and (4,0)-(5,0) span" $ - shouldBe (composeConsecutiveSpans + shouldBe (coalesce (Cons 1 (Cons 0 Nil), Cons 2 (Cons 0 Nil)) (Cons 4 (Cons 0 Nil), Cons 5 (Cons 0 Nil))) - [] + Nothing it "composeRegions failing on (1,0)-(2,0) span and (3,1)-(3,1) span" $ - shouldBe (composeConsecutiveSpans + shouldBe (coalesce (Cons 1 (Cons 0 Nil), Cons 2 (Cons 0 Nil)) (Cons 3 (Cons 1 Nil), Cons 3 (Cons 1 Nil))) - [] + Nothing it "five point stencil 2D" $ -- Sort the expected value for the sake of easy equality - shouldBe (inferMinimalVectorRegions fivepoint) + shouldBe (sort $ inferMinimalVectorRegions fivepoint) (sort [ (Cons (-1) (Cons 0 Nil), Cons 1 (Cons 0 Nil)) , (Cons 0 (Cons (-1) Nil), Cons 0 (Cons 1 Nil)) ]) it "seven point stencil 3D" $ shouldBe - (inferMinimalVectorRegions sevenpoint) + (sort $ inferMinimalVectorRegions sevenpoint) (sort [ (Cons (-1) (Cons 0 (Cons 0 Nil)), Cons 1 (Cons 0 (Cons 0 Nil))) , (Cons 0 (Cons (-1) (Cons 0 Nil)), Cons 0 (Cons 1 (Cons 0 Nil))) @@ -133,32 +110,32 @@ it "five point stencil 2D" $ inferFromIndices (VL fivepoint) `shouldBe` - (Specification $ Single $ Exact $ Spatial - (Sum [ Product [ Centered 0 1 True, Centered 1 2 True] - , Product [ Centered 0 2 True, Centered 1 1 True] + (Specification $ Once $ Exact $ Spatial + (Sum [ Product [ Centered 1 1 True, Centered 0 2 True] + , Product [ Centered 0 1 True, Centered 1 2 True] ])) it "seven point stencil 2D" $ inferFromIndices (VL sevenpoint) `shouldBe` - (Specification $ Single $ Exact $ Spatial - (Sum [ Product [ Centered 0 1 True, Centered 0 2 True, Centered 1 3 True] - , Product [ Centered 0 1 True, Centered 0 3 True, Centered 1 2 True] - , Product [ Centered 0 2 True, Centered 0 3 True, Centered 1 1 True] + (Specification $ Once $ Exact $ Spatial + (Sum [ Product [ Centered 1 1 True, Centered 0 2 True, Centered 0 3 True] + , Product [ Centered 0 1 True, Centered 1 2 True, Centered 0 3 True] + , Product [ Centered 0 1 True, Centered 0 2 True, Centered 1 3 True] ])) it "five point stencil 2D with blip" $ inferFromIndices (VL fivepointErr) `shouldBe` - (Specification $ Single $ Exact $ Spatial - (Sum [ Product [ Forward 1 1 True, Forward 1 2 True], + (Specification $ Once $ Exact $ Spatial + (Sum [ Product [ Centered 1 1 True, Centered 0 2 True], Product [ Centered 0 1 True, Centered 1 2 True], - Product [ Centered 0 2 True, Centered 1 1 True] ])) + Product [ Forward 1 1 True, Forward 1 2 True] ])) it "centered forward" $ inferFromIndices (VL centeredFwd) `shouldBe` - (Specification $ Single $ Exact $ Spatial + (Specification $ Once $ Exact $ Spatial (Sum [ Product [ Forward 1 1 True , Centered 1 2 True] ])) @@ -182,29 +159,29 @@ [Neighbour "i" 0, Neighbour "j" 0] [[offsetToIx "i" 1, offsetToIx "j" 1], [offsetToIx "i" 0, offsetToIx "j" 0]] - `shouldBe` (Just $ Specification $ Single $ Exact + `shouldBe` (Just $ Specification $ Once $ Exact (Spatial (Sum [Product [Forward 1 1 False, Forward 1 2 False], Product [Centered 0 1 True, Centered 0 2 True]]))) it "consistent (2) a(i,c,j) = b(i,j+1) + b(i,j) \ - \:: forward(depth=1,dim=2)*reflexive(dim=1)" $ + \:: forward(depth=1,dim=2)*pointed(dim=1)" $ indicesToSpec' ["i", "j"] [Neighbour "i" 0, Constant (F.ValInteger "0"), Neighbour "j" 0] [[offsetToIx "i" 0, offsetToIx "j" 1], [offsetToIx "i" 0, offsetToIx "j" 0]] - `shouldBe` (Just $ Specification $ Single $ Exact + `shouldBe` (Just $ Specification $ Once $ Exact (Spatial - (Sum [Product [Forward 1 2 True, Centered 0 1 True]]))) + (Sum [Product [Centered 0 1 True, Forward 1 2 True]]))) it "consistent (3) a(i+1,c,j) = b(j,i+1) + b(j,i) \ - \:: backward(depth=1,dim=2)*reflexive(dim=1)" $ + \:: backward(depth=1,dim=2)*pointed(dim=1)" $ indicesToSpec' ["i", "j"] [Neighbour "i" 1, Constant (F.ValInteger "0"), Neighbour "j" 0] [[offsetToIx "j" 0, offsetToIx "i" 1], [offsetToIx "j" 0, offsetToIx "i" 0]] - `shouldBe` (Just $ Specification $ Single $ Exact + `shouldBe` (Just $ Specification $ Once $ Exact (Spatial - (Sum [Product [Backward 1 2 True, Centered 0 1 True]]))) + (Sum [Product [Centered 0 1 True, Backward 1 2 True]]))) it "consistent (4) a(i+1,j) = b(0,i+1) + b(0,i) \ \:: backward(depth=1,dim=2)" $ @@ -212,28 +189,26 @@ [Neighbour "i" 1, Neighbour "j" 0] [[offsetToIx "j" absoluteRep, offsetToIx "i" 1], [offsetToIx "j" absoluteRep, offsetToIx "i" 0]] - `shouldBe` (Just $ Specification $ Single $ Exact + `shouldBe` (Just $ Specification $ Once $ Exact (Spatial (Sum [Product [Backward 1 2 True]]))) it "consistent (5) a(i) = b(i,i+1) \ - \:: reflexive(dim=1)*forward(depth=1,dim=2,irreflexive)" $ + \:: pointed(dim=1)*forward(depth=1,dim=2,nonpointed)" $ indicesToSpec' ["i", "j"] [Neighbour "i" 0] [[offsetToIx "i" 0, offsetToIx "i" 1]] - `shouldBe` (Just $ Specification $ Single $ Exact + `shouldBe` (Just $ Specification $ Once $ Exact (Spatial - (Sum [Product [Forward 1 2 False, - Centered 0 1 True]]))) + (Sum [Product [Centered 0 1 True, + Forward 1 2 False]]))) it "consistent (6) a(i) = b(i) + b(0) \ - \:: reflexive(dim=1)" $ + \:: pointed(dim=1)" $ indicesToSpec' ["i", "j"] [Neighbour "i" 0] [[offsetToIx "i" 0], [offsetToIx "i" absoluteRep]] - `shouldBe` (Just $ Specification $ Single $ Exact - (Spatial - (Sum [Product [Centered 0 1 True]]))) + `shouldBe` Nothing it "inconsistent (1) RHS" $ indicesToSpec' ["i", "j"] @@ -272,18 +247,18 @@ fst (callAndSummarise (infer AssignMode '=') program) `shouldBe` "\ntests/fixtures/Specification/Stencils/example2.f\n\ - \(24:8)-(24:53) stencil readOnce, (reflexive(dim=1))*(centered(depth=1, dim=2)) \ - \+ (reflexive(dim=2))*(centered(depth=1, dim=1)) :: a\n\ \(32:7)-(32:26) stencil readOnce, (backward(depth=1, dim=1)) :: a\n\ - \(41:8)-(41:103) stencil readOnce, (centered(depth=1, dim=1)) \ - \+ (centered(depth=1, dim=2)) :: a\n\ - \(42:8)-(42:37) stencil readOnce, (reflexive(dim=1))*(reflexive(dim=2)) :: a" + \(26:8)-(26:29) stencil readOnce, (pointed(dim=1))*(pointed(dim=2)) :: a\n\ + \(24:8)-(24:53) stencil readOnce, (pointed(dim=1))*(centered(depth=1, dim=2)) \ + \+ (centered(depth=1, dim=1))*(pointed(dim=2)) :: a\n\ + \(41:8)-(41:94) stencil readOnce, (centered(depth=1, dim=2)) \ + \+ (centered(depth=1, dim=1)) :: a" it "stencil check" $ fst (callAndSummarise (\f p -> (check f p, p)) program) `shouldBe` "\ntests/fixtures/Specification/Stencils/example2.f\n\ - \(23:1)-(23:86) Correct.\n(31:1)-(31:56) Correct." + \(23:1)-(23:82) Correct.\n(31:1)-(31:56) Correct." it "stencil synth" $ (B.unpack . runIdentity @@ -311,33 +286,7 @@ fst (callAndSummarise (infer AssignMode '=') program) `shouldBe` "\ntests/fixtures/Specification/Stencils/example4.f\n\ - \(6:8)-(6:33) stencil (reflexive(dim=1)) :: x" - - -{- Properties of `spanBoundingBox`: idempotent and associative -} -prop_spanBoundingIdem :: Natural n -> Span (Vec n Int) -> Bool -prop_spanBoundingIdem w x = spanBoundingBox x x == normaliseSpan x - -prop_spanBoundingAssoc :: Natural n -> Span (Vec n Int) - -> Span (Vec n Int) - -> Span (Vec n Int) -> Bool -prop_spanBoundingAssoc w x y z = - (==) (spanBoundingBox x (spanBoundingBox y z)) - (spanBoundingBox (spanBoundingBox x y) z) - -{- Permutations that come with 'unpermute' functions are invertable -} -prop_perms_invertable :: (Permutable n) => Natural n -> Vec n Int -> Bool -prop_perms_invertable w xs = - replicate (fact (lengthV xs)) xs == map (\(xs, f) -> f xs) (permutationsV xs) - where - fact 0 = 1 - fact n = n * fact (n - 1) - -zeroN = Zero -oneN = Succ zeroN -twoN = Succ oneN -threeN = Succ twoN -fourN = Succ threeN + \(6:8)-(6:33) stencil readOnce, (pointed(dim=1)) :: x" -- Indices for the 2D five point stencil (deliberately in an odd order) fivepoint = [ Cons (-1) (Cons 0 Nil), Cons 0 (Cons (-1) Nil) @@ -362,7 +311,7 @@ , Cons 1 (Cons 1 Nil) ] :: [ Vec (S (S Z)) Int ] {- Construct arbtirary vectors and test up to certain sizes -} -instance Arbitrary a => Arbitrary (Vec Z a) where +instance {-# OVERLAPPING #-} Arbitrary a => Arbitrary (Vec Z a) where arbitrary = return Nil instance (Arbitrary (Vec n a), Arbitrary a) => Arbitrary (Vec (S n) a) where @@ -384,68 +333,68 @@ variations = [ ( [ [0,0] ] - , Single $ Exact $ Spatial (Sum [Product [ Centered 0 1 True, Centered 0 2 True]]) + , Once $ Exact $ Spatial (Sum [Product [ Centered 0 1 True, Centered 0 2 True]]) ) , ( [ [1,0] ] - , Single $ Exact $ Spatial (Sum [Product [Forward 1 1 False, Centered 0 2 True]]) + , Once $ Exact $ Spatial (Sum [Product [Forward 1 1 False, Centered 0 2 True]]) ) , ( [ [1,0], [0,0], [0,0] ] - , Multiple $ Exact $ Spatial (Sum [Product [Forward 1 1 True, Centered 0 2 True]]) + , Mult $ Exact $ Spatial (Sum [Product [Forward 1 1 True, Centered 0 2 True]]) ) , ( [ [0,1], [0,0] ] - , Single $ Exact $ Spatial (Sum [Product [Forward 1 2 True, Centered 0 1 True]]) + , Once $ Exact $ Spatial (Sum [Product [Centered 0 1 True, Forward 1 2 True]]) ) , ( [ [1,1], [0,1], [1,0], [0,0] ] - , Single $ Exact $ Spatial (Sum [Product [Forward 1 1 True, Forward 1 2 True]]) + , Once $ Exact $ Spatial (Sum [Product [Forward 1 1 True, Forward 1 2 True]]) ) , ( [ [-1,0], [0,0] ] - , Single $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Centered 0 2 True]]) + , Once $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Centered 0 2 True]]) ) , ( [ [0,-1], [0,0], [0,-1] ] - , Multiple $ Exact $ Spatial (Sum [Product [Backward 1 2 True, Centered 0 1 True]]) + , Mult $ Exact $ Spatial (Sum [Product [Centered 0 1 True, Backward 1 2 True]]) ) , ( [ [-1,-1], [0,-1], [-1,0], [0,0], [0, -1] ] - , Multiple $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Backward 1 2 True]]) + , Mult $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Backward 1 2 True]]) ) , ( [ [0,-1], [1,-1], [0,0], [1,0], [1,1], [0,1] ] - , Single $ Exact $ Spatial $ Sum [ Product [ Forward 1 1 True, Centered 1 2 True] ] + , Once $ Exact $ Spatial $ Sum [ Product [ Forward 1 1 True, Centered 1 2 True] ] ) -- Stencil which is non-contiguous in one direction , ( [ [0, 4], [1, 4] ] - , Single $ Bound (Just (Spatial (Sum [ Product [ Forward 1 1 True ] ]))) - (Just (Spatial (Sum [ Product [ Forward 1 1 True - , Forward 4 2 True ] ]))) + , Once $ Bound Nothing + (Just (Spatial (Sum [ Product [ Forward 1 1 True + , Forward 4 2 False ] ]))) ) ] variationsRel = [ -- Stencil which has non-relative indices in one dimension (Neighbour "i" 0, Constant (F.ValInteger "0"), [ [0, absoluteRep], [1, absoluteRep] ] - , Single $ Exact $ Spatial (Sum [Product [Forward 1 1 True]]) + , Once $ Exact $ Spatial (Sum [Product [Forward 1 1 True]]) ) , (Neighbour "i" 1, Neighbour "j" 0, [ [0,0] ] - , Single $ Exact $ Spatial (Sum [Product [ Backward 1 1 False, Centered 0 2 True]]) + , Once $ Exact $ Spatial (Sum [Product [ Backward 1 1 False, Centered 0 2 True]]) ) , (Neighbour "i" 0, Neighbour "j" 1, [ [0,1] ] - , Single $ Exact $ Spatial (Sum [Product [Centered 0 1 True, Centered 0 2 True]]) + , Once $ Exact $ Spatial (Sum [Product [Centered 0 1 True, Centered 0 2 True]]) ) , (Neighbour "i" 1, Neighbour "j" (-1), [ [1,0], [0,0], [0,0] ] - , Multiple $ Exact $ Spatial (Sum [Product [Forward 1 2 False, Backward 1 1 True]]) + , Mult $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Forward 1 2 False]]) ) , (Neighbour "i" 0, Neighbour "j" (-1), [ [0,1], [0,0] ] - , Single $ Exact $ Spatial (Sum [Product [Forward 2 2 False, Centered 0 1 True]]) + , Once $ Exact $ Spatial (Sum [Product [Centered 0 1 True, Forward 2 2 False]]) ) -- [0,1] [0,0] [0,-1] , (Neighbour "i" 1, Neighbour "j" 0, [ [1,1], [1,0], [1,-1] ] - , Single $ Exact $ Spatial (Sum [Product [Centered 0 1 True, Centered 1 2 True]]) + , Once $ Exact $ Spatial (Sum [Product [Centered 0 1 True, Centered 1 2 True]]) ) , (Neighbour "i" 1, Neighbour "j" 0, [ [-2,0], [-1,0] ] - , Single $ Bound (Just (Spatial (Sum [Product [ Centered 0 2 True ]]))) - (Just (Spatial (Sum [Product [ Backward 3 1 True - , Centered 0 2 True ]])))) + , Once $ Bound Nothing + (Just (Spatial (Sum [Product [ Backward 3 1 False + , Centered 0 2 True ]])))) , (Constant (F.ValInteger "0"), Neighbour "j" 0, [ [absoluteRep,1], [absoluteRep,0], [absoluteRep,-1] ] - , Single $ Exact $ Spatial (Sum [Product [Centered 1 2 True]]) + , Once $ Exact $ Spatial (Sum [Product [Centered 1 2 True]]) ) ] @@ -465,13 +414,13 @@ variations3D = [ ( [ [-1,0,-1], [0,0,-1], [-1,0,0], [0,0,0] ] - , Single $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Backward 1 3 True, Centered 0 2 True]]) + , Once $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Centered 0 2 True, Backward 1 3 True]]) ) , ( [ [1,1,0], [0,1,0] ] - , Single $ Exact $ Spatial (Sum [Product [Forward 1 1 True, Forward 1 2 False, Centered 0 3 True]]) + , Once $ Exact $ Spatial (Sum [Product [Forward 1 1 True, Forward 1 2 False, Centered 0 3 True]]) ) , ( [ [-1,0,-1], [0,0,-1], [-1,0,0], [0,0,0] ] - , Single $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Backward 1 3 True, Centered 0 2 True]]) + , Once $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Centered 0 2 True, Backward 1 3 True]]) ) ] diff --git a/tests/Camfort/Specification/UnitsSpec.hs b/tests/Camfort/Specification/UnitsSpec.hs --- a/tests/Camfort/Specification/UnitsSpec.hs +++ b/tests/Camfort/Specification/UnitsSpec.hs @@ -4,8 +4,11 @@ import qualified Data.ByteString.Char8 as B import Language.Fortran.Parser.Any +import Language.Fortran.ParserMonad (fromRight) +import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA import qualified Language.Fortran.Analysis.Renaming as FAR +import Data.Generics.Uniplate.Operations import Camfort.Input import Camfort.Functionality import Camfort.Output @@ -56,32 +59,73 @@ uOpts = unitOpts0 { uoNameMap = FAR.extractNameMap pf', uoDebug = True, uoLiterals = litMode } (r, state, logs) = runUnitSolver uOpts pf' $ initInference >> m +runUnitInference litMode pf = case r of + Right vars -> ([ (FA.varName e, u) | e <- declVariables pf' + , u <- maybeToList ((FA.varName e, FA.srcName e) `lookup` vars) ] + , usConstraints state) + _ -> ([], usConstraints state) + where + pf' = FA.initAnalysis . fmap mkUnitAnnotation . fmap (const unitAnnotation) $ pf + uOpts = unitOpts0 { uoNameMap = M.empty, uoDebug = False, uoLiterals = litMode } + (r, state, logs) = runUnitSolver uOpts pf' $ initInference >> fmap chooseImplicitNames runInferVariables + +declVariables :: F.ProgramFile UA -> [F.Expression UA] +declVariables pf = flip mapMaybe (universeBi pf) $ \ d -> case d of + F.DeclVariable _ _ v@(F.ExpValue _ _ (F.ValVariable _)) _ _ -> Just v + F.DeclArray _ _ v@(F.ExpValue _ _ (F.ValVariable _)) _ _ _ -> Just v + _ -> Nothing + + spec :: Spec spec = do + let showClean = show . nub . sort . head . rights . (:[]) . fst describe "Unit Inference Frontend" $ do describe "Literal Mode" $ do it "litTest1 Mixed" $ do - head (fromJust (head (rights [fst (runUnits LitMixed litTest1 runInconsistentConstraints)]))) `shouldSatisfy` - conParamEq (ConEq (UnitName "a") (UnitMul (UnitName "a") (UnitVar ("j", "j")))) + (fromJust (head (rights [fst (runUnits LitMixed litTest1 runInconsistentConstraints)]))) `shouldSatisfy` + any (conParamEq (ConEq (UnitVar ("k", "k")) (UnitMul (UnitVar ("j", "j")) (UnitVar ("j", "j"))))) it "litTest1 Poly" $ do - head (fromJust (head (rights [fst (runUnits LitPoly litTest1 runInconsistentConstraints)]))) `shouldSatisfy` - conParamEq (ConEq (UnitName "a") (UnitMul (UnitName "a") (UnitVar ("j", "j")))) + (fromJust (head (rights [fst (runUnits LitPoly litTest1 runInconsistentConstraints)]))) `shouldSatisfy` + any (conParamEq (ConEq (UnitVar ("k", "k")) (UnitMul (UnitVar ("j", "j")) (UnitVar ("j", "j"))))) it "litTest1 Unitless" $ do - head (fromJust (head (rights [fst (runUnits LitUnitless litTest1 runInconsistentConstraints)]))) `shouldSatisfy` - conParamEq (ConEq (UnitName "a") (UnitVar ("k", "k"))) + (fromJust (head (rights [fst (runUnits LitUnitless litTest1 runInconsistentConstraints)]))) `shouldSatisfy` + any (conParamEq (ConEq UnitlessLit (UnitVar ("j", "j")))) + it "Polymorphic non-zero literal is not OK" $ do + head (rights [fst (runUnits LitMixed inconsist1 runInconsistentConstraints)]) `shouldSatisfy` isJust + describe "Polymorphic functions" $ do it "squarePoly1" $ do - show (sort (head (rights [fst (runUnits LitMixed squarePoly1 runInferVariables)]))) `shouldBe` - show (sort [(("a", "a"),UnitName "m"),(("b", "b"), UnitName "s"),(("x", "x"),UnitPow (UnitName "m") 2.0),(("y", "y"),UnitPow (UnitName "s") 2.0)]) + showClean (runUnits LitMixed squarePoly1 (fmap chooseImplicitNames runInferVariables)) `shouldBe` + "[((\"a\",\"a\"),m),((\"b\",\"b\"),s),((\"m\",\"m\"),'b),((\"n\",\"n\"),'a),((\"square\",\"square\"),('a)**2),((\"squarep\",\"squarep\"),('b)**2),((\"x\",\"x\"),m**2),((\"y\",\"y\"),s**2)]" describe "Recursive functions" $ do it "Recursive Addition is OK" $ do - show (sort (head (rights [fst (runUnits LitMixed recursive1 runInferVariables)]))) `shouldBe` - show (sort [(("y", "y"),UnitName "m"),(("z", "z"), UnitName "m")]) + showClean (runUnits LitMixed recursive1 (fmap chooseImplicitNames runInferVariables)) `shouldBe` + "[((\"b\",\"b\"),'a),((\"n\",\"n\"),1),((\"r\",\"r\"),'a),((\"x\",\"x\"),1),((\"y\",\"y\"),m),((\"z\",\"z\"),m)]" describe "Recursive functions" $ do it "Recursive Multiplication is not OK" $ do - head (fromJust (head (rights [fst (runUnits LitMixed recursive2 runInconsistentConstraints)]))) `shouldSatisfy` - conParamEq (ConEq (UnitParamPosAbs ("recur", 0)) (UnitParamPosAbs ("recur", 2))) + (fromJust (head (rights [fst (runUnits LitMixed recursive2 runInconsistentConstraints)]))) `shouldSatisfy` + any (conParamEq (ConEq (UnitParamPosAbs ("recur", 0)) (UnitParamPosAbs ("recur", 2)))) + describe "Explicitly annotated parametric polymorphic unit variables" $ do + it "inside-outside" $ do + showClean (runUnits LitMixed insideOutside runInferVariables) `shouldBe` + "[((\"inside\",\"inside\"),('a)**2),((\"k\",\"k\"),'a),((\"m\",\"m\"),('a)**2),((\"outside\",\"outside\"),('a)**2),((\"x\",\"x\"),'a),((\"y\",\"y\"),'a)]" + it "eapVarScope" $ do + show (sort (fst (runUnitInference LitMixed eapVarScope))) `shouldBe` + "[(\"f\",('a)**3),(\"g\",'a),(\"j\",'a),(\"k\",('a)**3),(\"x\",'a),(\"y\",'a)]" + it "eapVarApp" $ do + show (sort (fst (runUnitInference LitMixed eapVarApp))) `shouldBe` + "[(\"f\",('a)**2),(\"fj\",'a),(\"fk\",('a)**2),(\"fl\",('a)**4),(\"fx\",'a),(\"g\",'b),(\"gm\",'b),(\"gn\",'b),(\"gx\",'b),(\"h\",m**2),(\"hx\",m),(\"hy\",m**2)]" + describe "Implicit parametric polymorphic unit variables" $ do + it "inferPoly1" $ do + show (sort (fst (runUnitInference LitMixed inferPoly1))) `shouldBe` + "[(\"fst\",'a),(\"id\",'c),(\"snd\",'d),(\"sqr\",('f)**2),(\"x1\",'c),(\"x2\",'f),(\"x3\",'a),(\"x4\",'e),(\"y3\",'b),(\"y4\",'d)]" + + describe "Intrinsic functions" $ do + it "sqrtPoly" $ do + show (sort (fst (runUnitInference LitMixed sqrtPoly))) `shouldBe` + "[(\"a\",m**2),(\"b\",s**4),(\"c\",j**2),(\"n\",'a),(\"x\",m),(\"y\",s),(\"z\",j)]" + describe "Unit Inference Backend" $ do describe "Flatten constraints" $ do it "testCons1" $ do @@ -111,7 +155,7 @@ criticalVariables testCons5 `shouldSatisfy` null describe "Infer Variables" $ do it "testCons5" $ do - inferVariables testCons5 `shouldBe` testCons5_infer + show (inferVariables testCons5) `shouldBe` show testCons5_infer describe "Check that (restricted) double to ratios is consistent" $ do it "test all in -10/-10 ... 10/10, apart from /0" $ do and [testDoubleToRationalSubset x y | x <- [-10..10], y <- [-10..10]] @@ -193,7 +237,7 @@ else True -------------------------------------------------- -litTest1 = flip fortranParser "litTest1.f90" . B.pack $ unlines +litTest1 = flip fortranParser' "litTest1.f90" . B.pack $ unlines [ "program main" , " != unit(a) :: x" , " real :: x, j, k" @@ -204,7 +248,7 @@ , " x = x * j ! inconsistent" , "end program main" ] -squarePoly1 = flip fortranParser "squarePoly1.f90" . B.pack $ unlines +squarePoly1 = flip fortranParser' "squarePoly1.f90" . B.pack $ unlines [ "! Demonstrates parametric polymorphism through functions-calling-functions." , "program squarePoly" , " implicit none" @@ -227,7 +271,7 @@ , " end function" , "end program" ] -recursive1 = flip fortranParser "recursive1.f90" . B.pack $ unlines +recursive1 = flip fortranParser' "recursive1.f90" . B.pack $ unlines [ "program main" , " != unit(m) :: y" , " integer :: x = 5, y = 2, z" @@ -244,7 +288,7 @@ , " end function recur" , "end program main" ] -recursive2 = flip fortranParser "recursive2.f90" . B.pack $ unlines +recursive2 = flip fortranParser' "recursive2.f90" . B.pack $ unlines [ "program main" , " != unit(m) :: y" , " integer :: x = 5, y = 2, z" @@ -260,3 +304,130 @@ , " end if" , " end function recur" , "end program main" ] + +insideOutside = flip fortranParser' "insideOutside.f90" . B.pack $ unlines + [ "module insideOutside" + , "contains" + , " function outside(x)" + , " != unit 'a :: x" + , " real :: x, k, m, outside" + , " k = x" + , " outside = inside(k) * 2" + , " m = outside" + , " contains" + , " function inside(y)" + , " != unit 'a ** 2 :: inside" + , " real :: y, inside" + , " inside = y * y" + , " end function inside" + , " end function outside" + , "end module insideOutside" ] + +eapVarScope = flip fortranParser' "eapVarScope.f90" . B.pack $ unlines + [ "module eapVarScope" + , "contains" + , " function f(x)" + , " != unit 'a :: x" + , " real :: x, k, f" + , " k = g(x) * g(x * x)" + , " f = k" + , " end function f" + , " function g(y)" + , " != unit 'a :: y" + , " real :: y, j, g" + , " j = y" + , " g = j" + , " end function g" + , "end module eapVarScope" ] + +eapVarApp = flip fortranParser' "eapVarApp.f90" . B.pack $ unlines + [ "module eapVarApp" + , "contains" + , " function f(fx)" + , " != unit 'a :: fx" + , " real :: fx, fj, fk, fl, f" + , " fj = fx" + , " fk = g(fj*fj)" + , " fl = fj * g(fj * fj * fj)" + , " f = fk" + , " end function f" + , " function g(gx)" + , " != unit 'b :: gx" + , " real :: gx, gn, gm, g" + , " gm = gx" + , " gn = gm" + , " g = gn" + , " end function g" + , " function h(hx)" + , " != unit m :: hx" + , " real :: hx, h, hy" + , " hy = f(hx)" + , " h = hy" + , " end function h" + , "end module eapVarApp" ] + +inferPoly1 = flip fortranParser' "inferPoly1.f90" . B.pack $ unlines + [ "module inferPoly1" + , "contains" + , " function id(x1)" + , " real :: x1, id" + , " id = x1" + , " end function id" + , " function sqr(x2)" + , " real :: x2, sqr" + , " sqr = x2 * x2" + , " end function sqr" + , " function fst(x3,y3)" + , " real :: x3, y3, fst" + , " fst = x3" + , " end function fst" + , " function snd(x4,y4)" + , " real :: x4, y4, snd" + , " snd = y4" + , " end function snd" + , "end module inferPoly1" ] + +-- This should be inconsistent because of the use of the literal "10" +-- in the parametric polymorphic function sqr. +inconsist1 = flip fortranParser' "inconsist1.f90" . B.pack $ unlines + [ "program inconsist1" + , " implicit none" + , " real :: a, b" + , " != unit(m) :: x" + , " real :: x = 1" + , " != unit(s) :: t" + , " real :: t = 2" + , " a = sqr(x) " + , " b = sqr(t)" + , " contains " + , " real function sqr(y)" + , " real :: y" + , " real :: z = 10" + , " sqr = y * y + z" + , " end function" + , "end program inconsist1" ] + +-- Test intrinsic function sqrt() +sqrtPoly = flip fortranParser' "sqrtPoly.f90" . B.pack $ unlines + [ "program sqrtPoly" + , " implicit none" + , " != unit m :: x" + , " real :: x" + , " != unit s :: y" + , " real :: y" + , " != unit J :: z" + , " real :: z" + , " integer :: a" + , " integer :: b" + , " integer :: c" + , " x = sqrt(a)" + , " y = sqrt(sqrt(b))" + , " z = sqrt(square(sqrt(c)))" + , "contains" + , " real function square(n)" + , " real :: n" + , " square = n * n" + , " end function square" + , "end program sqrtPoly" ] + +fortranParser' = \x -> fromRight . (fortranParser x) diff --git a/tests/fixtures/Specification/Stencils/example2.f b/tests/fixtures/Specification/Stencils/example2.f --- a/tests/fixtures/Specification/Stencils/example2.f +++ b/tests/fixtures/Specification/Stencils/example2.f @@ -20,7 +20,7 @@ if (.true.) then c= region :: r2 = centered(depth=1, dim=2) x = a(i-1,j) + a(i,j) + a(i+1,j) + abs(0) -c= stencil readOnce, (reflexive(dim=1))*r2 + (reflexive(dim=2))*r1 :: a +c= stencil readOnce, (pointed(dim=1))*r2 + (pointed(dim=2))*r1 :: a b(i,j) = (x + a(i,j-1) + a(i,j+1)) / 5.0 c No specification should be inferred here b(0,0) = a(i, j) @@ -38,7 +38,7 @@ do j=1, jmx x = a(1,j+1) + a(1,j-1) if (.true.) then - a(i,j) = a(modulo(i,imax),1) + a(modulo(i+1,imax) ,1) + a(modulo(i-1,imax),1) + a(1,j) + x + a(i,j) = a(mod(i,imax),1) + a(mod(i+1,imax) ,1) + a(mod(i-1,imax),1) + a(1,j) + x a(i,j) = a(i,j) + a(1,1) end if end do