diff --git a/camfort.cabal b/camfort.cabal --- a/camfort.cabal +++ b/camfort.cabal @@ -1,7 +1,9 @@ name: camfort -version: 0.902 +version: 0.903 synopsis: CamFort - Cambridge Fortran infrastructure description: CamFort is a tool for the analysis, transformation, verification of Fortran code. +homepage: https://camfort.github.io +bug-reports: https://github.com/camfort/camfort/issues copyright: 2012-2016 University of Cambridge author: Dominic Orchard, Matthew Danish, Mistral Contrastin, Andrew Rice, Oleg Oshmyan @@ -31,16 +33,19 @@ other-modules: Camfort.Analysis.Annotations Camfort.Analysis.CommentAnnotator Camfort.Analysis.Simple + Camfort.Specification.Parser Camfort.Specification.Stencils.Annotation Camfort.Specification.Stencils.CheckBackend Camfort.Specification.Stencils.CheckFrontend Camfort.Specification.Stencils.Consistency Camfort.Specification.Stencils.DenotationalSemantics + Camfort.Specification.Stencils.Generate Camfort.Specification.Stencils.InferenceBackend Camfort.Specification.Stencils.InferenceFrontend Camfort.Specification.Stencils.Model Camfort.Specification.Stencils.Syntax - Camfort.Specification.Stencils.Grammar + Camfort.Specification.Stencils.Parser + Camfort.Specification.Stencils.Parser.Types Camfort.Specification.Stencils.Synthesis Camfort.Specification.Stencils Camfort.Specification.Units @@ -49,10 +54,10 @@ Camfort.Specification.Units.Environment Camfort.Specification.Units.Monad Camfort.Specification.Units.Parser + Camfort.Specification.Units.Parser.Types Camfort.Specification.Units.Synthesis Camfort.Transformation.CommonBlockElim Camfort.Transformation.DeadCode - Camfort.Transformation.DataTypeIntroduction Camfort.Transformation.EquivalenceElim Camfort.Helpers Camfort.Helpers.Syntax @@ -64,29 +69,30 @@ Main build-depends: base >= 4.6 && < 5, - ghc-prim >= 0.3.1.0, - containers >= 0.5.0.0, - uniplate >= 1.6.10, - syz >= 0.2, - syb >= 0.4, - matrix >=0.2.2, - vector >= 0.1, - hmatrix >= 0.15, - mtl >= 2.1, - text >= 0.11.2.3, - array >= 0.4, - directory >= 1.2, - transformers >= 0.4, - GenericPretty >= 1.2, - QuickCheck >= 2.8, - fortran-src == 0.1.0.6, - filepath, - fgl >= 5.5, - bytestring >= 0.10, - binary >= 0.8.3.0, - lattices >= 1.5, - sbv >= 5.14, - partial-order >= 0.1.2 + ghc-prim >= 0.3.1.0 && < 0.6, + containers >= 0.5.0.0 && < 0.6, + uniplate >= 1.6.10 && < 2, + syz >= 0.2 && < 0.3, + syb >= 0.4 && < 0.7, + matrix >= 0.2.2 && < 0.4, + vector >= 0.1 && < 0.12, + hmatrix >= 0.15 && < 0.19, + mtl >= 2.1 && < 3, + text >= 0.11.2.3 && < 2, + array >= 0.4 && < 0.6, + directory >= 1.2 && < 2, + transformers >= 0.4 && < 0.6, + GenericPretty >= 1.2 && < 2, + QuickCheck >= 2.8 && < 3, + fortran-src >= 0.2.0.0 && < 0.3, + filepath >= 1.4 && < 2, + fgl >= 5.5 && < 6, + bytestring >= 0.10 && < 0.11, + binary >= 0.8.3.0 && < 0.9, + lattices >= 1.5 && < 2, + sbv >= 7.0 && < 8, + partial-order >= 0.1.2, + optparse-applicative >= 0.13.2.0 && < 0.14 default-language: Haskell2010 library @@ -95,6 +101,7 @@ exposed-modules: Camfort.Analysis.Annotations Camfort.Analysis.CommentAnnotator Camfort.Analysis.Simple + Camfort.Specification.Parser Camfort.Specification.Stencils.Annotation Camfort.Specification.Stencils.CheckBackend Camfort.Specification.Stencils.CheckFrontend @@ -104,7 +111,9 @@ Camfort.Specification.Stencils.InferenceFrontend Camfort.Specification.Stencils.Model Camfort.Specification.Stencils.Syntax - Camfort.Specification.Stencils.Grammar + Camfort.Specification.Stencils.Generate + Camfort.Specification.Stencils.Parser + Camfort.Specification.Stencils.Parser.Types Camfort.Specification.Stencils.Synthesis Camfort.Specification.Stencils Camfort.Specification.Units @@ -113,10 +122,10 @@ Camfort.Specification.Units.Environment Camfort.Specification.Units.Monad Camfort.Specification.Units.Parser + Camfort.Specification.Units.Parser.Types Camfort.Specification.Units.Synthesis Camfort.Transformation.CommonBlockElim Camfort.Transformation.DeadCode - Camfort.Transformation.DataTypeIntroduction Camfort.Transformation.EquivalenceElim Camfort.Helpers Camfort.Helpers.Syntax @@ -127,28 +136,28 @@ Camfort.Reprint build-depends: base >= 4.6 && < 5, - ghc-prim >= 0.3.1.0, - containers >= 0.5.0.0, - uniplate >= 1.6.10, - syz >= 0.2, - syb >= 0.4, - matrix >=0.2.2, - hmatrix >= 0.17.0.1, - mtl >= 2.1, - text >= 0.11.2.3, - array >= 0.4, - directory >= 1.2, - transformers >= 0.4, - vector >= 0.1, - GenericPretty >= 1.2, - fortran-src == 0.1.0.6, - filepath, - bytestring >= 0.10, - fgl >= 5.5, - binary >= 0.8.3.0, - lattices >= 1.5, - sbv >= 5.14, - partial-order >= 0.1.2 + ghc-prim >= 0.3.1.0 && < 0.6, + containers >= 0.5.0.0 && < 0.6, + uniplate >= 1.6.10 && < 2, + syz >= 0.2 && < 0.3, + syb >= 0.4 && < 0.7, + matrix >= 0.2.2 && < 0.4, + hmatrix >= 0.15 && < 0.19, + mtl >= 2.1 && < 3, + text >= 0.11.2.3 && < 2, + array >= 0.4 && < 0.6, + directory >= 1.2 && < 2, + transformers >= 0.4 && < 0.6, + vector >= 0.1 && < 0.12, + GenericPretty >= 1.2 && < 2, + fortran-src >= 0.2.0.0 && < 0.3, + filepath >= 1.4 && < 2, + bytestring >= 0.10 && < 0.11, + fgl >= 5.5 && < 6, + binary >= 0.8.3.0 && < 0.9, + lattices >= 1.5 && < 2, + sbv >= 7.0 && < 8, + partial-order >= 0.1.2 && < 0.2 default-language: Haskell2010 test-suite spec @@ -156,32 +165,36 @@ main-is: Spec.hs hs-source-dirs: tests other-modules: Camfort.Analysis.CommentAnnotatorSpec + Camfort.Specification.ParserSpec Camfort.Specification.Stencils.CheckSpec Camfort.Specification.Stencils.ConsistencySpec Camfort.Specification.Stencils.DenotationalSemanticsSpec - Camfort.Specification.Stencils.GrammarSpec + Camfort.Specification.Stencils.ParserSpec Camfort.Specification.Stencils.InferenceBackendSpec Camfort.Specification.Stencils.ModelSpec Camfort.Specification.StencilsSpec + Camfort.Specification.Units.InferenceBackendSpec + Camfort.Specification.Units.InferenceFrontendSpec + Camfort.Specification.Units.ParserSpec Camfort.Specification.UnitsSpec Camfort.Transformation.CommonSpec Camfort.Transformation.EquivalenceElimSpec build-depends: base >= 4.6 && < 5, - containers >= 0.5, - filepath >= 1.4, - directory >= 1.2, - hspec >= 2.2, - QuickCheck >= 2.8, - 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, + containers >= 0.5.0.0 && < 0.6, + filepath >= 1.4 && < 2, + directory >= 1.2 && < 2, + hspec >= 2.2 && < 3, + QuickCheck >= 2.8 && < 3, + fortran-src >= 0.2.0.0 && < 0.3, + uniplate >= 1.6.10 && < 2, + mtl >= 2.1 && < 3, + bytestring >= 0.10 && < 0.11, + array >= 0.4 && < 0.6, + hmatrix >= 0.15 && < 0.19, + text >= 0.11.2.3 && < 2, + binary >= 0.8.3.0 && < 0.9, + lattices >= 1.5 && < 2, + sbv >= 7.0 && < 8, + partial-order >= 0.1.2 && < 0.2, camfort default-language: Haskell2010 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 @@ -18,23 +18,41 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} -module Camfort.Analysis.Annotations where +module Camfort.Analysis.Annotations + ( + -- * Annotation Datatype + Annotation(..) + , A + , UA + , unitAnnotation + -- ** Predicates + , pRefactored + -- ** Transformation Helpers + , onPrev + -- ** Specification Annotation Helpers + , getAstSpec + , getParseSpec + , getRegionSpec + , giveAstSpec + , giveParseSpec + , giveRegionSpec + -- * Other Helpers + , Report + , buildCommentText + ) where import Data.Data -import Data.Generics.Uniplate.Operations import Data.Maybe (isJust) -import Data.Map.Lazy hiding (map) -import Debug.Trace - import Camfort.Specification.Units.Environment -import qualified Camfort.Specification.Units.Parser as P +import qualified Camfort.Specification.Units.Parser.Types as P import Camfort.Analysis.CommentAnnotator import qualified Camfort.Specification.Stencils.Syntax as StencilSpec -import qualified Camfort.Specification.Stencils.Grammar as StencilComment +import qualified Camfort.Specification.Stencils.Parser.Types as StencilComment import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA +import Language.Fortran.ParserMonad (FortranVersion(Fortran90)) import qualified Language.Fortran.Util.Position as FU type Report = String @@ -50,14 +68,50 @@ , deleteNode :: Bool -- Stencil specification annotations -- TODO: move these into their own annotation - , stencilSpec :: Maybe - -- If defined, either an unprocessed syntax tree - (Either StencilComment.Specification - -- Or a parser AST of a RegionEnv or SpecDecls - (Either StencilSpec.RegionEnv StencilSpec.SpecDecls)) + , stencilSpec :: Maybe SpecAnnotation , stencilBlock :: Maybe (F.Block (FA.Analysis Annotation)) } deriving (Eq, Show, Typeable, Data) +-- | Specification annotation. +data SpecAnnotation + -- | Unprocessed syntax tree. + = ParserSpec StencilComment.Specification + -- | Region definition. + | RegionDecl StencilSpec.RegionDecl + -- | Normalised AST specification. + | ASTSpec StencilSpec.SpecDecls + deriving (Eq, Show, Data) + +-- | Set the annotation's stencil specification to a parsed specification. +giveParseSpec :: StencilComment.Specification -> Annotation -> Annotation +giveParseSpec spec ann = ann { stencilSpec = Just $ ParserSpec spec } + +-- | Set the annotation's stencil specification to a region alias. +giveRegionSpec :: StencilSpec.RegionDecl -> Annotation -> Annotation +giveRegionSpec spec ann = ann { stencilSpec = Just $ RegionDecl spec } + +-- | Set the annotation's stencil specification to a normalized specification. +giveAstSpec :: StencilSpec.SpecDecls -> Annotation -> Annotation +giveAstSpec spec ann = ann { stencilSpec = Just $ ASTSpec spec } + +-- | Retrieve a parsed specification from an annotation. +getParseSpec :: Annotation -> Maybe StencilComment.Specification +getParseSpec s = case stencilSpec s of + (Just (ParserSpec spec)) -> Just spec + _ -> Nothing + +-- | Retrieve a region environment from an annotation. +getRegionSpec :: Annotation -> Maybe StencilSpec.RegionDecl +getRegionSpec s = case stencilSpec s of + (Just (RegionDecl renv)) -> Just renv + _ -> Nothing + +-- | Retrieve a normalized specification from an annotation. +getAstSpec :: Annotation -> Maybe StencilSpec.SpecDecls +getAstSpec s = case stencilSpec s of + (Just (ASTSpec ast)) -> Just ast + _ -> Nothing + -- Predicate on whether an AST has been refactored pRefactored :: Annotation -> Bool pRefactored = isJust . refactored @@ -96,5 +150,8 @@ onPrev :: (a -> a) -> FA.Analysis a -> FA.Analysis a onPrev f ann = ann { FA.prevAnnotation = f (FA.prevAnnotation ann) } -modifyAnnotation :: F.Annotated f => (a -> a) -> f a -> f a -modifyAnnotation f x = F.setAnnotation (f (F.getAnnotation x)) x +-- | Build a Fortran comment string appropriate for the Fortran version. +buildCommentText :: F.MetaInfo -> Int -> String -> String +buildCommentText mi col text | isModernFortran = replicate col ' ' ++ "!" ++ text + | otherwise = "c" ++ text + where isModernFortran = F.miVersion mi >= Fortran90 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 @@ -16,112 +16,109 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternGuards #-} -module Camfort.Analysis.CommentAnnotator ( annotateComments - , Logger - , ASTEmbeddable(..) - , Linkable(..) - , AnnotationParseError(..) - , AnnotationParser - , failWith - ) where +module Camfort.Analysis.CommentAnnotator + ( annotateComments + , isComment + , ASTEmbeddable(..) + , Linkable(..) + ) where -import Control.Monad.Writer.Strict (Writer(..), tell) -import Data.Generics.Uniplate.Operations + import Data.Data (Data) -import Debug.Trace +import Data.Generics.Uniplate.Operations import Language.Fortran.AST import Language.Fortran.Util.Position -type Logger = Writer [ String ] -type AnnotationParser ast = String -> Either AnnotationParseError ast - -data AnnotationParseError = - NotAnnotation - | ProbablyAnnotation String - deriving (Eq, Show) - --- A parser that throws an annotation parsing error -failWith :: AnnotationParser ast -failWith = Left . ProbablyAnnotation +import Camfort.Specification.Parser ( looksLikeASpec + , runParser + , SpecParseError + , SpecParser) -annotateComments :: forall a ast . (Data a, Linkable a, ASTEmbeddable a ast) - => AnnotationParser ast - -> ProgramFile a - -> Logger (ProgramFile a) -annotateComments parse pf = do - pf' <- transformBiM (writeASTProgramUnits parse) =<< transformBiM (writeASTBlocks parse) pf +annotateComments :: forall m e a ast . + (Monad m, Data a, Linkable a, ASTEmbeddable a ast) + => SpecParser e ast + -> (SrcSpan -> SpecParseError e -> m ()) + -> ProgramFile a + -> m (ProgramFile a) +annotateComments parser handleErr pf = do + pf' <- transformBiM writeASTProgramUnits =<< transformBiM writeASTBlocks pf return . descendBi linkProgramUnits $ descendBi linkBlocks pf' where - 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 - writeASTBlocks _ b = return b + writeAST a d srcSpan comment = + if looksLikeASpec parser comment + then case runParser parser comment of + Left err -> handleErr srcSpan err >> pure d + Right ast -> pure $ setAnnotation (annotateWithAST a ast) d + else pure d - 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 + writeASTProgramUnits :: ProgramUnit a -> m (ProgramUnit a) + writeASTProgramUnits pu@(PUComment a srcSpan (Comment comment)) = + writeAST a pu srcSpan comment + writeASTProgramUnits pu = pure pu + writeASTBlocks :: Block a -> m (Block a) + writeASTBlocks b@(BlComment a srcSpan (Comment comment)) = + writeAST a b srcSpan comment + writeASTBlocks b = pure b + + -- | Link all comments to first non-comment in the list. + joinComments [ ] = [ ] + joinComments dss@(d:ds) + | isComment d = + let (comments, rest) = span isComment dss + -- 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) + -- returning a pair of processed blocks and unprocessed blocks + + -- pre-condition: first parameter is a list of comments + + -- default uses 'link' to associate every comment to the first following block + linkMulti = (map (fmap $ flip linker (head rest)) comments, rest) + in if null rest -- Does the group end with comments + then comments + else let (procs, unprocs) = linkMulti + in procs ++ joinComments unprocs + | otherwise = descendBi joinComments d + : joinComments ds + {-| Link all comment blocks to first non-comment block in the list. |-} linkBlocks :: (Data a, Linkable a) => [ Block a ] -> [ Block a ] - linkBlocks [ ] = [ ] - linkBlocks blocks@(b:bs) - | BlComment{} <- b = - let (comments, rest) = span isComment blocks - in if null rest -- Does the group of blocks end with comments - then comments - else let (bs, bs') = linkMultiple comments rest - in bs ++ linkBlocks bs' - | otherwise = (descendBi linkBlocks b) : linkBlocks bs - where - isComment BlComment{} = True - isComment _ = False + linkBlocks = joinComments {-| 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 + linkProgramUnits = joinComments class ASTEmbeddable a ast where annotateWithAST :: a -> ast -> a +-- | Instances of this class can be combined with 'Block' and 'ProgramUnit'. class Linkable a where + -- ^ Combine an @a@ with a 'Block' link :: a -> Block a -> a + -- ^ Combine an @a@ with a 'ProgramUnit' 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) - -- returning a pair of processed blocks and unprocessed blocks +-- | Interface for types that can be combined with 'Linkable' types. +class Linked a where + linker :: (Linkable b) => b -> a b -> b - -- pre-condition: first parameter is a list of comments +instance Linked Block where + linker = link - -- default uses 'link' to associate every comment to the first following block - linkMultiple :: [Block a] -> [Block a] -> ([Block a], [Block a]) - linkMultiple comments blocks = - (map (fmap $ flip link (head blocks)) comments, blocks) +instance Linked ProgramUnit where + linker = linkPU - 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) +-- | Interface for types that can have comments. +class HasComment a where + isComment :: a -> Bool -parserWarn :: SrcSpan -> String -> Logger () -parserWarn srcSpan err = tell [ "Error " ++ show srcSpan ++ ": " ++ err ] +instance HasComment (Block a) where + isComment BlComment{} = True + isComment _ = False + +instance HasComment (ProgramUnit a) where + isComment PUComment{} = True + isComment _ = False diff --git a/src/Camfort/Analysis/Simple.hs b/src/Camfort/Analysis/Simple.hs --- a/src/Camfort/Analysis/Simple.hs +++ b/src/Camfort/Analysis/Simple.hs @@ -30,6 +30,6 @@ {-| Counts the number of declarations (of variables) in a whole program -} countVariableDeclarations :: - forall a . Data a => Filename -> F.ProgramFile a -> (Int, F.ProgramFile a) -countVariableDeclarations _ x = - (sum [1 | x <- universeBi x :: [F.Declarator a]], x) + forall a . Data a => F.ProgramFile a -> (Int, F.ProgramFile a) +countVariableDeclarations x = + (sum [1 | _ <- universeBi x :: [F.Declarator a]], x) diff --git a/src/Camfort/Functionality.hs b/src/Camfort/Functionality.hs --- a/src/Camfort/Functionality.hs +++ b/src/Camfort/Functionality.hs @@ -21,19 +21,34 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} -module Camfort.Functionality where +module Camfort.Functionality ( + -- * Datatypes + AnnotationType(..) + -- * Commands + , ast + , countVarDecls + -- ** Stencil Analysis + , stencilsCheck + , stencilsInfer + , stencilsSynth + -- ** Unit Analysis + , unitsCriticals + , unitsCheck + , unitsInfer + , unitsSynth + , unitsCompile + -- ** Refactorings + , common + , dead + , equivalences + ) where -import System.FilePath import Control.Monad - -import Data.Generics.Uniplate.Operations -import Data.Data -import Data.Binary -import Data.Text (pack, unpack, split) +import System.FilePath (takeDirectory) import Camfort.Analysis.Simple -import Camfort.Transformation.DataTypeIntroduction import Camfort.Transformation.DeadCode import Camfort.Transformation.CommonBlockElim import Camfort.Transformation.EquivalenceElim @@ -44,165 +59,104 @@ import Camfort.Helpers import Camfort.Input -import qualified Language.Fortran.Parser.Any as FP 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] +data AnnotationType = ATDefault | Doxygen | Ford --- Extract excluces information from options -instance Default String where - defaultValue = "" -getExcludes :: Options -> String -getExcludes opts = head ([ e | Excludes e <- universeBi opts ] ++ [""]) --- Separates the comma-separated filenames -getExcludedFiles :: Options -> [String] -getExcludedFiles = map unpack . split (==',') . pack . getExcludes +-- | Retrieve the marker character compatible with the given +-- type of annotation. +markerChar :: AnnotationType -> Char +markerChar Doxygen = '<' +markerChar Ford = '!' +markerChar ATDefault = '=' + -- * Wrappers on all of the features -ast d excludes _ _ = do +ast d excludes = do xs <- readParseSrcDir d excludes - print (map (\(_, _, p) -> p) xs) + print . fmap fst $ xs -countVarDecls inSrc excludes _ _ = do +countVarDecls inSrc excludes = do putStrLn $ "Counting variable declarations in '" ++ inSrc ++ "'" - doAnalysisSummary countVariableDeclarations inSrc excludes Nothing + doAnalysisSummary countVariableDeclarations inSrc excludes -dead inSrc excludes outSrc _ = do +dead inSrc excludes outSrc = do putStrLn $ "Eliminating dead code in '" ++ inSrc ++ "'" report <- doRefactor (mapM (deadCode False)) inSrc excludes outSrc putStrLn report -common inSrc excludes outSrc _ = do +common inSrc excludes outSrc = do putStrLn $ "Refactoring common blocks in '" ++ inSrc ++ "'" isDir <- isDirectory inSrc let rfun = commonElimToModules (takeDirectory outSrc ++ "/") report <- doRefactorAndCreate rfun inSrc excludes outSrc putStrLn report -equivalences inSrc excludes outSrc _ = do +equivalences inSrc excludes outSrc = do putStrLn $ "Refactoring equivalences blocks in '" ++ inSrc ++ "'" 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] -> 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 - -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 +optsToUnitOpts :: LiteralsOpt -> Bool -> Maybe String -> IO UnitOpts +optsToUnitOpts m debug = maybe (pure o1) + (fmap (\modFiles -> o1 { uoModFiles = M.fromList modFiles }) . getModFilesWithNames) + where o1 = unitOpts0 { uoLiterals = m + , uoDebug = debug + , uoModFiles = M.empty } -unitsCheck inSrc excludes _ opt = do +unitsCheck inSrc excludes m debug incDir = do putStrLn $ "Checking units for '" ++ inSrc ++ "'" - uo <- optsToUnitOpts opt + uo <- optsToUnitOpts m debug incDir let rfun = concatMap (LU.checkUnits uo) - doAnalysisReportWithModFiles rfun putStrLn inSrc excludes =<< getModFiles opt + doAnalysisReportWithModFiles rfun putStrLn inSrc incDir excludes -unitsInfer inSrc excludes _ opt = do +unitsInfer inSrc excludes m debug incDir = do putStrLn $ "Inferring units for '" ++ inSrc ++ "'" - uo <- optsToUnitOpts opt + uo <- optsToUnitOpts m debug incDir let rfun = concatMap (LU.inferUnits uo) - doAnalysisReportWithModFiles rfun putStrLn inSrc excludes =<< getModFiles opt + doAnalysisReportWithModFiles rfun putStrLn inSrc incDir excludes -unitsCompile inSrc excludes outSrc opt = do +unitsCompile inSrc excludes m debug incDir outSrc = do putStrLn $ "Compiling units for '" ++ inSrc ++ "'" - uo <- optsToUnitOpts opt + uo <- optsToUnitOpts m debug incDir let rfun = LU.compileUnits uo - putStrLn =<< doCreateBinary rfun inSrc excludes outSrc =<< getModFiles opt + putStrLn =<< doCreateBinary rfun inSrc incDir excludes outSrc -unitsSynth inSrc excludes outSrc opt = do + +unitsSynth inSrc excludes m debug incDir outSrc annType = do putStrLn $ "Synthesising units for '" ++ inSrc ++ "'" - let marker - | Doxygen `elem` opt = '<' - | Ford `elem` opt = '!' - | otherwise = '=' - uo <- optsToUnitOpts opt + let marker = markerChar annType + uo <- optsToUnitOpts m debug incDir let rfun = mapM (LU.synthesiseUnits uo marker) - report <- doRefactorWithModFiles rfun inSrc excludes outSrc =<< getModFiles opt + report <- doRefactorWithModFiles rfun inSrc incDir excludes outSrc putStrLn report -unitsCriticals inSrc excludes _ opt = do +unitsCriticals inSrc excludes m debug incDir = do putStrLn $ "Suggesting variables to annotate with unit specifications in '" ++ inSrc ++ "'" - uo <- optsToUnitOpts opt + uo <- optsToUnitOpts m debug incDir let rfun = mapM (LU.inferCriticalVariables uo) - doAnalysisReportWithModFiles rfun (putStrLn . fst) inSrc excludes =<< getModFiles opt + doAnalysisReportWithModFiles rfun (putStrLn . fst) inSrc incDir excludes {- Stencils feature -} -stencilsCheck inSrc excludes _ _ = do +stencilsCheck inSrc excludes = do putStrLn $ "Checking stencil specs for '" ++ inSrc ++ "'" - let rfun = \f p -> (Stencils.check f p, p) - doAnalysisSummary rfun inSrc excludes Nothing + let rfun p = (Stencils.check p, p) + doAnalysisSummary rfun inSrc excludes -stencilsInfer inSrc excludes outSrc opt = do - putStrLn $ "Infering stencil specs for '" ++ inSrc ++ "'" - let rfun = Stencils.infer (getOption opt) '=' - doAnalysisSummary rfun inSrc excludes (Just outSrc) +stencilsInfer inSrc excludes inferMode = do + putStrLn $ "Inferring stencil specs for '" ++ inSrc ++ "'" + let rfun = Stencils.infer inferMode '=' + doAnalysisSummary rfun inSrc excludes -stencilsSynth inSrc excludes outSrc opt = do +stencilsSynth inSrc excludes inferMode annType outSrc = do putStrLn $ "Synthesising stencil specs for '" ++ inSrc ++ "'" - let marker - | Doxygen `elem` opt = '<' - | Ford `elem` opt = '!' - | otherwise = '=' - let rfun = Stencils.synth (getOption opt) marker + let rfun = Stencils.synth inferMode (markerChar annType) report <- doRefactor rfun inSrc excludes outSrc putStrLn report diff --git a/src/Camfort/Helpers.hs b/src/Camfort/Helpers.hs --- a/src/Camfort/Helpers.hs +++ b/src/Camfort/Helpers.hs @@ -17,23 +17,31 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-} -module Camfort.Helpers where +module Camfort.Helpers + ( + -- * Datatypes and Aliases + Directory + , FileOrDir + , Filename + , SourceText + -- * Directory Helpers + , checkDir + , getDir + , isDirectory + -- * Misc Helpers + , collect + , descendBiReverseM + , descendReverseM + ) where -import GHC.Generics -import Data.Generics.Zipper -import Data.Generics.Aliases import Data.Generics.Uniplate.Operations import qualified Data.Generics.Str as Str import Data.Data -import Data.Maybe -import Data.Monoid -import Data.List (elemIndices, group, sort, nub) +import Data.List (elemIndices, union) import qualified Data.ByteString.Char8 as B import System.Directory -import Data.List (union) import qualified Data.Map.Lazy as Map hiding (map, (\\)) import Control.Monad.Writer.Strict @@ -64,83 +72,6 @@ isDirectory :: FileOrDir -> IO Bool isDirectory s = doesDirectoryExist s --- Helpers -fanout :: (a -> b) -> (a -> c) -> a -> (b, c) -fanout f g x = (f x, g x) - -(<>) :: (a -> b) -> (a -> c) -> a -> (b, c) -f <> g = fanout f g - -(><) :: (a -> c) -> (b -> d) -> (a, b) -> (c, d) -f >< g = \(x, y) -> (f x, g y) - --- Lookup functions over relation s - -lookups :: Eq a => a -> [(a, b)] -> [b] -lookups _ [] = [] -lookups x ((a, b):xs) = if (x == a) then b : lookups x xs - else lookups x xs - -lookups' :: Eq a => a -> [((a, b), c)] -> [(b, c)] -lookups' _ [] = [] -lookups' x (((a, b), c):xs) = if (x == a) then (b, c) : lookups' x xs - else lookups' x xs - -{-| Computes all pairwise combinations -} -pairs :: [a] -> [(a, a)] -pairs [] = [] -pairs (x:xs) = (zip (repeat x) xs) ++ (pairs xs) - -{-| Functor composed with list functor -} -mfmap :: Functor f => (a -> b) -> [f a] -> [f b] -mfmap f = map (fmap f) - -{-| An infix `map` operation.-} -each = flip (map) - -{-| Is the Ordering an EQ? -} -cmpEq :: Ordering -> Bool -cmpEq EQ = True -cmpEq _ = False - -cmpFst :: (a -> a -> Ordering) -> (a, b) -> (a, b) -> Ordering -cmpFst c (x1, y1) (x2, y2) = c x1 x2 - -cmpSnd :: (b -> b -> Ordering) -> (a, b) -> (a, b) -> Ordering -cmpSnd c (x1, y1) (x2, y2) = c y1 y2 - -{-| used for type-level annotations giving documentation -} -type (:?) a (b :: k) = a - --- Helper function, reduces a list two elements at a time with a partial operation -foldPair :: (a -> a -> Maybe a) -> [a] -> [a] -foldPair f [] = [] -foldPair f [a] = [a] -foldPair f (a:(b:xs)) = case f a b of - Nothing -> a : (foldPair f (b : xs)) - Just c -> foldPair f (c : xs) - - -class PartialMonoid x where - -- Satisfies equations: - -- pmappend x pmempty = Just x - -- pmappend pempty x = Just x - -- (pmappend y z) >>= (\w -> pmappend x w) = (pmappend x y) >>= (\w -> pmappend w z) - - emptyM :: x - appendM :: x -> x -> Maybe x - -normalise :: (Ord t, PartialMonoid t) => [t] -> [t] -normalise = nub . reduce . sort - where reduce = foldPair appendM - -normaliseNoSort :: (Ord t, PartialMonoid t) => [t] -> [t] -normaliseNoSort = nub . reduce - where reduce = foldPair appendM - -normaliseBy :: Ord t => (t -> t -> Maybe t) -> [t] -> [t] -normaliseBy plus = nub . (foldPair plus) . sort - #if __GLASGOW_HASKELL__ < 800 instance Monoid x => Monad ((,) x) where return a = (mempty, a) @@ -148,39 +79,6 @@ in (mappend x x', b) #endif --- Data-type generic reduce traversal -reduceCollect :: (Data s, Data t, Uniplate t, Biplate t s) => (s -> Maybe a) -> t -> [a] -reduceCollect k x = execWriter (transformBiM (\y -> do case k y of - Just x -> tell [x] - Nothing -> return () - return y) x) - --- Data-type generic comonad-style traversal with zipper (contextual traversal) -everywhere :: (Zipper a -> Zipper a) -> Zipper a -> Zipper a -everywhere k z = everywhere' z - where - everywhere' = enterRight . enterDown . k - - enterDown z = - case (down' z) of - Just dz -> let dz' = everywhere' dz - in case (up $ dz') of - Just uz -> uz - Nothing -> dz' - Nothing -> z - - enterRight z = - case (right z) of - Just rz -> let rz' = everywhere' rz - in case (left $ rz') of - Just lz -> lz - Nothing -> rz' - Nothing -> z - - -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 } @@ -192,7 +90,7 @@ foldMap f (Reverse x) = foldMap f x instance Traversable (Reverse Str.Str) where - traverse f (Reverse Str.Zero) = pure $ Reverse Str.Zero + traverse _ (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) diff --git a/src/Camfort/Helpers/Syntax.hs b/src/Camfort/Helpers/Syntax.hs --- a/src/Camfort/Helpers/Syntax.hs +++ b/src/Camfort/Helpers/Syntax.hs @@ -25,29 +25,32 @@ syntax that are useful between different analyses and transformations. -} -module Camfort.Helpers.Syntax where +module Camfort.Helpers.Syntax + ( + -- * Variable renaming helpers + caml + -- * Comparison and ordering + , AnnotationFree(..) + , af + -- * Accessor functions for extracting various pieces of information + -- out of syntax trees + , extractVariable + -- * SrcSpan Helpers + , afterAligned + , deleteLine + , dropLine + , linesCovered + , toCol0 + ) where -- Standard imports import Data.Char -import Data.List -import Data.Monoid -import Control.Monad.State.Lazy -import Debug.Trace -- Data-type generics imports -import Data.Data import Data.Generics.Uniplate.Data -import Data.Generics.Uniplate.Operations -import Data.Generics.Zipper -import Data.Typeable --- CamFort specific functionality -import Camfort.Analysis.Annotations - import qualified Language.Fortran.AST as F import qualified Language.Fortran.Util.Position as FU -import Language.Fortran.Util.FirstParameter -import Language.Fortran.Util.SecondParameter -- * Comparison and ordering @@ -58,12 +61,9 @@ {-| short-hand constructor for 'AnnotationFree' -} af = AnnotationFree -{-| short-hand deconstructor for 'AnnotationFree' -} -unaf = annotationBound -- variable renaming helpers caml (x:xs) = toUpper x : xs -lower = map toLower -- Here begins varioous 'Eq' instances for instantiations of 'AnnotationFree' @@ -110,18 +110,18 @@ -- SrcSpan helpers dropLine :: FU.SrcSpan -> FU.SrcSpan -dropLine (FU.SrcSpan s1 (FU.Position o c l)) = - FU.SrcSpan s1 (FU.Position o 0 (l+1)) +dropLine (FU.SrcSpan s1 (FU.Position o _ l)) = + FU.SrcSpan s1 (FU.Position o 1 (l+1)) deleteLine :: FU.SrcSpan -> FU.SrcSpan -deleteLine (FU.SrcSpan (FU.Position ol cl ll) (FU.Position ou cu lu)) = - FU.SrcSpan (FU.Position ol (cl-1) ll) (FU.Position ou 0 (lu+1)) +deleteLine (FU.SrcSpan (FU.Position ol cl ll) (FU.Position ou _ lu)) = + FU.SrcSpan (FU.Position ol (cl-1) ll) (FU.Position ou 1 (lu+1)) linesCovered :: FU.Position -> FU.Position -> Int linesCovered (FU.Position _ _ l1) (FU.Position _ _ l2) = l2 - l1 + 1 -toCol0 (FU.Position o c l) = FU.Position o 0 l +toCol0 (FU.Position o _ l) = FU.Position o 1 l afterAligned :: FU.SrcSpan -> FU.Position -afterAligned (FU.SrcSpan (FU.Position o cA lA) (FU.Position _ cB lB)) = +afterAligned (FU.SrcSpan (FU.Position o cA _) (FU.Position _ _ lB)) = FU.Position o cA (lB+1) 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 @@ -25,9 +25,32 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} -module Camfort.Helpers.Vec where +module Camfort.Helpers.Vec + ( + -- * Datatypes + EqT(..) + , ExistsEqT(..) + , Nat(..) + , Natural(..) + , Vec(..) + , VecBox(..) + , VecList(..) + -- ** Vector Operations + , (!!) + , findIndex + , fromList + , fromLists + , length + , lengthN + , proveEqSize + , proveNonEmpty + , replace + , toList + , zip + , zipWith + ) where -import Prelude hiding (length, zipWith, take, drop, (!!)) +import Prelude hiding (length, zip, zipWith, take, drop, (!!)) import Data.Proxy @@ -45,13 +68,6 @@ data NatBox where NatBox :: Natural n -> NatBox deriving instance Show NatBox --- Conversions to and from the type-representation --- of natural numbers -toNatBox :: Int -> NatBox -toNatBox 0 = NatBox Zero -toNatBox n = case toNatBox (n-1) of - (NatBox n) -> NatBox (Succ n) - class IsNatural (n :: Nat) where fromNat :: Proxy n -> Int @@ -67,14 +83,14 @@ length :: Vec n a -> Int length Nil = 0 -length (Cons x xs) = 1 + length xs +length (Cons _ xs) = 1 + length xs lengthN :: Vec n a -> Natural n lengthN Nil = Zero -lengthN (Cons x xs) = Succ $ lengthN xs +lengthN (Cons _ xs) = Succ $ lengthN xs instance Functor (Vec n) where - fmap f Nil = Nil + fmap _ Nil = Nil fmap f (Cons x xs) = Cons (f x) (fmap f xs) deriving instance Eq a => Eq (Vec n a) @@ -96,7 +112,7 @@ 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 _ 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) @@ -112,11 +128,11 @@ | otherwise = go (acc + 1) p xs (!!) :: Vec n a -> Int -> a -Cons x v' !! 0 = x +Cons x _ !! 0 = x Cons _ v' !! n = v' !! (n - 1) replace :: Int -> a -> Vec n a -> Vec n a -replace 0 a (Cons x xs) = Cons a xs +replace 0 a (Cons _ 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." @@ -138,15 +154,6 @@ 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 @@ -158,14 +165,7 @@ 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 + (Cons _ _) -> Just $ ExistsEqT ReflEq {- Vector list repreentation where the size 'n' is existential quantified -} data VecList a where VL :: [Vec n a] -> VecList a @@ -184,4 +184,4 @@ 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 + preCondition _ _ = unsafeCoerce ReflEq diff --git a/src/Camfort/Input.hs b/src/Camfort/Input.hs --- a/src/Camfort/Input.hs +++ b/src/Camfort/Input.hs @@ -1,312 +1,248 @@ -{- - 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 +{- | +Module : Camfort.Input +Description : Handles input of code base and passing the files on to core functionality. +Copyright : Copyright 2017, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish +License : Apache-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. +Maintainer : dom.orchard@gmail.com -} -{-2 - -Handles input of code base (files and directories) - and passing them into the core functionality +{-# LANGUAGE DoAndIfThenElse #-} --} +module Camfort.Input + ( + -- * Classes + Default(..) + -- * Datatypes and Aliases + , FileProgram + -- * Builders for analysers and refactorings + , callAndSummarise + , doAnalysisReportWithModFiles + , doAnalysisSummary + , doRefactor + , doRefactorAndCreate + , doRefactorWithModFiles + -- * Source directory and file handling + , doCreateBinary + , readParseSrcDir + , getModFilesWithNames + ) where -{-# LANGUAGE DoAndIfThenElse #-} -{-# LANGUAGE ScopedTypeVariables #-} +import Control.Monad (forM) +import Data.Binary (decodeFileOrFail) +import qualified Data.ByteString.Char8 as B +import Data.Char (toUpper) +import Data.List (foldl', (\\), intercalate) +import Data.Maybe +import Data.Text.Encoding (encodeUtf8, decodeUtf8With) +import Data.Text.Encoding.Error (replace) +import System.Directory +import System.FilePath ((), takeExtension) -module Camfort.Input where +import qualified Language.Fortran.AST as F +import qualified Language.Fortran.Parser.Any as FP +import Language.Fortran.Util.ModFile import Camfort.Analysis.Annotations import Camfort.Helpers import Camfort.Output -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 -import Data.Text.Encoding.Error (replace) -import Data.Text.Encoding (encodeUtf8, decodeUtf8With) - -import System.Directory - --- Class for default values of some type 't' +-- | Class for default values of some type 't' class Default t where defaultValue :: t --- From a '[t]' extract the first occurence of an 'opt' value. --- If one does not exist, return the default 'opt' -getOption :: forall t opt . (Data opt, Data t, Default opt) => [t] -> opt -getOption [] = defaultValue -getOption (x : xs) = - case universeBi x :: [opt] of - [] -> getOption xs - (opt : _) -> opt +-- | Print a string to the user informing them of files excluded +-- from the operation. +printExcludes :: Filename -> [Filename] -> IO () +printExcludes _ [] = pure () +printExcludes _ [""] = pure () +printExcludes inSrc excludes = + putStrLn $ concat ["Excluding ", intercalate "," excludes, " from ", inSrc, "/"] -- * Builders for analysers and refactorings -{-| Performs an analysis provided by its first parameter which generates - information 's', which is then combined together (via a monoid) -} -doAnalysisSummary :: (Monoid s, Show' s) => (Filename -> F.ProgramFile A -> (s, F.ProgramFile A)) - -> FileOrDir -> [Filename] -> Maybe FileOrDir -> IO () -doAnalysisSummary aFun inSrc excludes outSrc = do - if excludes /= [] && excludes /= [""] - then putStrLn $ "Excluding " ++ intercalate "," excludes - ++ " from " ++ inSrc ++ "/" - else return () +-- | Perform an analysis that produces information of type @s@. +doAnalysisSummary :: (Monoid s, Show' s) + => (FileProgram -> (s, FileProgram)) + -> FileOrDir -> [Filename] -> IO () +doAnalysisSummary aFun inSrc excludes = do + printExcludes inSrc excludes ps <- readParseSrcDir inSrc excludes - let (out, ps') = callAndSummarise aFun ps + let (out, _) = callAndSummarise aFun ps putStrLn . show' $ out +-- | Perform an analysis that produces information of type @s@. +callAndSummarise :: (Monoid s) + => (FileProgram -> (s, a)) + -> [(FileProgram, SourceText)] + -> (s, [a]) callAndSummarise aFun = - foldl' (\(n, pss) (f, _, ps) -> let (n', ps') = aFun f ps - in (n `mappend` n', ps' : pss)) (mempty, []) + foldl' (\(n, pss) (ps, _) -> + let (n', ps') = aFun ps + in (n `mappend` n', ps' : pss)) (mempty, []) +-- | Perform an analysis which reports to the user, but does not output any files. +doAnalysisReportWithModFiles + :: ([FileProgram] -> r) + -> (r -> IO out) + -> FileOrDir + -> Maybe FileOrDir + -> [Filename] + -> IO out +doAnalysisReportWithModFiles rFun sFun inSrc incDir excludes = do + printExcludes inSrc excludes + ps <- readParseSrcDirWithModFiles inSrc incDir excludes -{-| Performs an analysis which reports to the user, - but does not output any files -} -doAnalysisReport :: ([(Filename, F.ProgramFile A)] -> r) - -> (r -> IO out) - -> FileOrDir -> [Filename] -> IO out -doAnalysisReport rFun sFun inSrc excludes = do - if excludes /= [] && excludes /= [""] - then putStrLn $ "Excluding " ++ intercalate "," excludes - ++ " from " ++ inSrc ++ "/" - else return () - ps <- readParseSrcDir inSrc excludes ----- - let report = rFun (map (\(f, inp, ast) -> (f, ast)) ps) + let report = rFun . fmap fst $ ps 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 -} - --- Refactoring where just a single list of filename/program file --- pairs is returned (the case when no files are being added) -doRefactor :: - ([(Filename, F.ProgramFile A)] -> (String, [(Filename, F.ProgramFile A)])) - -> FileOrDir -> [Filename] -> FileOrDir -> IO String -doRefactor rFun inSrc excludes outSrc = do - if excludes /= [] && excludes /= [""] - then putStrLn $ "Excluding " ++ intercalate "," excludes - ++ " from " ++ inSrc ++ "/" - else return () - ps <- readParseSrcDir inSrc excludes - let (report, ps') = rFun (map (\(f, inp, ast) -> (f, ast)) ps) - let outputs = reassociateSourceText ps ps' - outputFiles inSrc outSrc outputs - return report +-- | Perform a refactoring that does not add any new files. +doRefactor :: ([FileProgram] + -> (String, [FileProgram])) + -> FileOrDir -> [Filename] -> FileOrDir + -> IO String +doRefactor rFun inSrc excludes outSrc = + doRefactorWithModFiles rFun inSrc Nothing excludes outSrc -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 +doRefactorWithModFiles + :: ([FileProgram] -> (String, [FileProgram])) + -> FileOrDir + -> Maybe FileOrDir + -> [Filename] + -> FileOrDir + -> IO String +doRefactorWithModFiles rFun inSrc incDir excludes outSrc = do + printExcludes inSrc excludes + ps <- readParseSrcDirWithModFiles inSrc incDir excludes + let (report, ps') = rFun . fmap fst $ ps + let outputs = reassociateSourceText (fmap snd ps) ps' + outputFiles inSrc outSrc outputs + pure 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 -doRefactorAndCreate :: - ([(Filename, F.ProgramFile A)] - -> (String, [(Filename, F.ProgramFile A)], [(Filename, F.ProgramFile A)])) +-- | Perform a refactoring that may create additional files. +doRefactorAndCreate + :: ([FileProgram] -> (String, [FileProgram], [FileProgram])) -> FileOrDir -> [Filename] -> FileOrDir -> IO String doRefactorAndCreate rFun inSrc excludes outSrc = do - if excludes /= [] && excludes /= [""] - then putStrLn $ "Excluding " ++ intercalate "," excludes - ++ " from " ++ inSrc ++ "/" - else return () - ps <- readParseSrcDir inSrc excludes - let (report, ps', ps'') = rFun (map (\(f, inp, ast) -> (f, ast)) ps) - let outputs = reassociateSourceText ps ps' - let outputs' = map (\(f, pf) -> (f, B.empty, pf)) ps'' - outputFiles inSrc outSrc outputs - outputFiles inSrc outSrc outputs' - return report + printExcludes inSrc excludes + ps <- readParseSrcDir inSrc excludes + let (report, ps', ps'') = rFun . fmap fst $ ps + let outputs = reassociateSourceText (fmap snd ps) ps' + let outputs' = map (\pf -> (pf, B.empty)) ps'' + outputFiles inSrc outSrc outputs + outputFiles inSrc outSrc outputs' + pure 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 +-- | For refactorings which create additional files. +type FileProgram = F.ProgramFile A -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 +doCreateBinary + :: ([FileProgram] -> (String, [(Filename, B.ByteString)])) + -> FileOrDir + -> Maybe FileOrDir + -> [Filename] + -> FileOrDir + -> IO String +doCreateBinary rFun inSrc incDir excludes outSrc = do + printExcludes inSrc excludes + ps <- readParseSrcDirWithModFiles inSrc incDir excludes + let (report, bins) = rFun . fmap fst $ ps + outputFiles inSrc outSrc bins + pure report -reassociateSourceText :: [(Filename, SourceText, a)] - -> [(Filename, F.ProgramFile Annotation)] - -> [(Filename, SourceText, F.ProgramFile Annotation)] -reassociateSourceText ps ps' = zip3 (map fst ps') (map snd3 ps) (map snd ps') - where snd3 (a, b, c) = b +reassociateSourceText :: [SourceText] + -> [F.ProgramFile Annotation] + -> [(F.ProgramFile Annotation, SourceText)] +reassociateSourceText ps ps' = zip ps' ps -- * Source directory and file handling -{-| Read files from a direcotry, excluding those listed - by the second parameter -} --- * Source directory and file handling -readParseSrcDir :: FileOrDir -> [Filename] - -> IO [(Filename, SourceText, F.ProgramFile A)] -readParseSrcDir inp excludes = 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 readParseSrcFile files - -mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] -mapMaybeM f = fmap catMaybes . (mapM f) +-- | Read files from a directory. +readParseSrcDir :: FileOrDir -- ^ Directory to read from. + -> [Filename] -- ^ Excluded files. + -> IO [(FileProgram, SourceText)] +readParseSrcDir inp excludes = + readParseSrcDirWithModFiles inp Nothing excludes readParseSrcDirWithModFiles :: FileOrDir + -> Maybe 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 (Maybe (Filename, SourceText, F.ProgramFile A)) -readParseSrcFile f = do - inp <- flexReadFile f - 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 + -> IO [(FileProgram, SourceText)] +readParseSrcDirWithModFiles inp incDir excludes = do + isdir <- isDirectory inp + files <- + if isdir + then do + files <- getFortranFiles inp + -- Compute alternate list of excludes with the + -- the directory appended + let excludes' = excludes ++ map (\x -> inp ++ "/" ++ x) excludes + pure $ map (\y -> inp ++ "/" ++ y) files \\ excludes' + else pure [inp] + mapMaybeM (readParseSrcFileWithModFiles incDir) files + where + mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] + mapMaybeM f = fmap catMaybes . mapM f -readParseSrcFileWithModFiles :: ModFiles +readParseSrcFileWithModFiles :: Maybe FileOrDir -> 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] -rGetDirContents d = do - ds <- getDirectoryContents d - let ds' = ds \\ [".", ".."] -- remove '.' and '..' entries - rec ds' - where - rec [] = return [] - rec (x:xs) = do xs' <- rec xs - g <- doesDirectoryExist (d ++ "/" ++ x) - if g then - do x' <- rGetDirContents (d ++ "/" ++ x) - return $ (map (\y -> x ++ "/" ++ y) x') ++ xs' - else if isFortran x - then return (x : xs') - else return xs' + -> IO (Maybe (FileProgram, SourceText)) +readParseSrcFileWithModFiles incDir f = do + inp <- flexReadFile f + mods <- maybe (pure emptyModFiles) getModFiles incDir + let result = FP.fortranParserWithModFiles mods inp f + case result of + Right ast -> pure $ Just (fmap (const unitAnnotation) ast, inp) + Left err -> print err >> pure Nothing + where + -- | Read file using ByteString library and deal with any weird characters. + flexReadFile :: String -> IO B.ByteString + flexReadFile = fmap (encodeUtf8 . decodeUtf8With (replace ' ')) . B.readFile --- 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] +getFortranFiles :: FileOrDir -> IO [String] +getFortranFiles = + fmap (filter isFortran) . rGetDirContents + where + -- | True if the file has a valid fortran extension. + isFortran :: Filename -> Bool + isFortran x = takeExtension x `elem` (exts ++ extsUpper) + where exts = [".f", ".f90", ".f77", ".cmn", ".inc"] + extsUpper = map (map toUpper) exts -{-| predicate on which fileextensions are Fortran files -} -isFortran x = fileExt x `elem` (exts ++ extsUpper) - where exts = [".f", ".f90", ".f77", ".cmn", ".inc"] - extsUpper = map (map toUpper) exts +-- | Recursively get the contents of a directory. +rGetDirContents :: FileOrDir -> IO [Filename] +rGetDirContents d = do + ds <- listDirectory d + fmap concat . mapM rGetDirContents' $ ds + where + -- | Get contents of directory if path points to a valid + -- directory, otherwise return the path (a file). + rGetDirContents' path = do + let dPath = d path + isDir <- doesDirectoryExist dPath + if isDir then do + fmap (fmap (path )) (rGetDirContents dPath) + else pure [path] -{-| extract a filename's extension -} -fileExt x = let ix = elemIndices '.' x - in if null ix then "" - else Prelude.drop (Prelude.last ix) x +-- | Retrieve a list of ModFiles from the directory, each associated +-- to the name of the file they are contained within. +getModFilesWithNames :: FileOrDir -> IO [(Filename, ModFile)] +getModFilesWithNames dir = do + -- Figure out the camfort mod files and parse them. + modFileNames <- filter isModFile <$> rGetDirContents dir + forM modFileNames $ \ modFileName -> do + eResult <- decodeFileOrFail (dir ++ "/" ++ modFileName) -- FIXME, directory manipulation + case eResult of + Left (offset, msg) -> do + putStrLn $ modFileName ++ ": Error at offset " ++ show offset ++ ": " ++ msg + pure (modFileName, emptyModFile) + Right modFile -> do + putStrLn $ modFileName ++ ": successfully parsed precompiled file." + pure (modFileName, modFile) + where + isModFile :: Filename -> Bool + isModFile = (== modFileSuffix) . takeExtension --- | Read file using ByteString library and deal with any weird characters. -flexReadFile :: String -> IO B.ByteString -flexReadFile = fmap (encodeUtf8 . decodeUtf8With (replace ' ')) . B.readFile +-- | Retrieve the ModFiles from a directory. +getModFiles :: FileOrDir -> IO ModFiles +getModFiles = fmap (fmap snd) . getModFilesWithNames diff --git a/src/Camfort/Output.hs b/src/Camfort/Output.hs --- a/src/Camfort/Output.hs +++ b/src/Camfort/Output.hs @@ -20,10 +20,16 @@ {- Provides support for outputting source files and analysis information -} -module Camfort.Output where +module Camfort.Output + ( + -- * Classes + OutputFiles(..) + , Show'(..) + -- * Refactoring + , refactoring + ) where import qualified Language.Fortran.AST as F -import qualified Language.Fortran.Analysis as FA import qualified Language.Fortran.PrettyPrint as PP import qualified Language.Fortran.Util.Position as FU import qualified Language.Fortran.ParserMonad as FPM @@ -33,16 +39,11 @@ import Camfort.Helpers import Camfort.Helpers.Syntax -import System.FilePath import System.Directory import qualified Data.ByteString.Char8 as B import Data.Generics import Data.Functor.Identity -import Data.List hiding (zip) -import Data.Generics.Uniplate.Data -import Data.Generics.Zipper -import Debug.Trace import Control.Monad import Control.Monad.Trans.Class @@ -68,8 +69,6 @@ outputFiles :: FileOrDir -> FileOrDir -> [t] -> IO () outputFiles inp outp pdata = do outIsDir <- isDirectory outp - inIsDir <- isDirectory inp - inIsFile <- doesFileExist inp if outIsDir then do -- Output to a directory, create if missing createDirectoryIfMissing True outp @@ -96,7 +95,7 @@ newDir ++ listDiffL oldDir oldFilename where listDiffL [] ys = ys - listDiffL xs [] = [] + listDiffL _ [] = [] listDiffL (x:xs) (y:ys) | x==y = listDiffL xs ys | otherwise = ys @@ -108,16 +107,16 @@ 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 _) _)) = +instance OutputFiles (F.ProgramFile Annotation, SourceText) where + mkOutputText _ (ast@(F.ProgramFile (F.MetaInfo version _) _), input) = -- If we are create a file, call the pretty printer directly if B.null input then B.pack $ PP.pprintAndRender version ast (Just 0) -- Otherwise, applying the refactoring system with reprint else runIdentity $ reprint (refactoring version) ast input - outputFile (f, _, _) = f - isNewFile (_, inp, _) = B.null inp + outputFile (pf, _) = F.pfGetFilename pf + isNewFile (_, inp) = B.null inp {- Specifies how to do specific refactorings (uses generic query extension - remember extQ is non-symmetric) -} @@ -142,16 +141,15 @@ -> F.ProgramUnit Annotation -> StateT FU.Position (State Int) (SourceText, Bool) -- Output comments -refactorProgramUnits v inp e@(F.PUComment ann span (F.Comment comment)) = do +refactorProgramUnits _ inp (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 + (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 @@ -166,22 +164,20 @@ -> F.Block Annotation -> StateT FU.Position (State Int) (SourceText, Bool) -- Output comments -refactorBlocks v inp e@(F.BlComment ann span (F.Comment comment)) = do +refactorBlocks _ inp (F.BlComment 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 + (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)) + 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) -- Refactor use statements refactorBlocks v inp b@(F.BlStatement _ _ _ u@F.StUse{}) = do cursor <- get case refactored $ F.getAnnotation u of - Just (FU.Position _ rCol rLine) -> do + Just (FU.Position _ rCol _) -> do let (FU.SrcSpan lb _) = FU.getSpan u let (p0, _) = takeBounds (cursor, lb) inp let out = B.pack $ PP.pprintAndRender v b (Just (rCol -1)) @@ -194,11 +190,11 @@ -- Common blocks, equivalence statements, and declarations can all -- be refactored by the default refactoring -refactorBlocks v inp b@(F.BlStatement _ _ _ s@F.StEquivalence{}) = +refactorBlocks v inp (F.BlStatement _ _ _ s@F.StEquivalence{}) = refactorStatements v inp s -refactorBlocks v inp b@(F.BlStatement _ _ _ s@F.StCommon{}) = +refactorBlocks v inp (F.BlStatement _ _ _ s@F.StCommon{}) = refactorStatements v inp s -refactorBlocks v inp b@(F.BlStatement _ _ _ s@F.StDeclaration{}) = +refactorBlocks v inp (F.BlStatement _ _ _ s@F.StDeclaration{}) = refactorStatements v inp s -- Arbitrary statements can be refactored *as blocks* (in order to -- get good indenting) @@ -219,7 +215,7 @@ let a = F.getAnnotation e case refactored a of Nothing -> return (B.empty, False) - Just (FU.Position _ rCol rLine) -> do + Just (FU.Position _ rCol _) -> do let (FU.SrcSpan lb ub) = FU.getSpan e let (pre, _) = takeBounds (cursor, lb) inp let indent = if newNode a then Just (rCol - 1) else Nothing @@ -243,7 +239,7 @@ case B.uncons xs of Nothing -> 0 Just ('\n', xs) -> 1 + countLines xs - Just (x, xs) -> countLines xs + Just (_, xs) -> countLines xs {- 'removeNewLines xs n' removes at most 'n' new lines characters from the input string xs, returning the new string and the number of new @@ -265,6 +261,6 @@ case B.uncons xs of Nothing -> (xs, 0) Just (x, xs) -> (B.cons x xs', n) - where (xs', n') = removeNewLines xs n + where (xs', _) = removeNewLines xs n unpackFst (x, y) = (B.unpack x, y) diff --git a/src/Camfort/Reprint.hs b/src/Camfort/Reprint.hs --- a/src/Camfort/Reprint.hs +++ b/src/Camfort/Reprint.hs @@ -16,16 +16,17 @@ {-# LANGUAGE RankNTypes #-} -module Camfort.Reprint where +module Camfort.Reprint + ( reprint + , subtext + , takeBounds + ) where import Data.Generics.Zipper -import Camfort.Analysis.Annotations import Camfort.Helpers -import Camfort.Helpers.Syntax import qualified Data.ByteString.Char8 as B -import Data.Functor.Identity import Data.Data import Control.Monad.Trans.State.Lazy import qualified Language.Fortran.Util.Position as FU @@ -40,7 +41,7 @@ -- A refactoring takes a 'Typeable' value --- into a stateful SourceText (ByteString) transformer, +-- into a stateful SourceText (B.ByteString) transformer, -- which returns a pair of a stateful computation of an updated SourceText -- paired with a boolean flag denoting whether a refactoring has been -- performed. The state contains a FU.Position which is the "cursor" @@ -66,7 +67,7 @@ -- Otherwise go with the normal algorithm | otherwise = do -- Create an initial cursor at the start of the file - let cursor0 = FU.Position 0 0 1 + let cursor0 = FU.initPosition -- Enter the top-node of a zipper for 'tree' -- setting the cursor at the start of the file (out, cursorn) <- runStateT (enter refactoring (toZipper tree) input) cursor0 @@ -132,13 +133,45 @@ -- Given a lower-bound and upper-bound pair of FU.Positions, split the -- incoming SourceText based on the distanceF between the FU.Position pairs takeBounds :: (FU.Position, FU.Position) -> SourceText -> (SourceText, SourceText) -takeBounds (l, u) = takeBounds' ((ll, lc), (ul, uc)) B.empty +takeBounds (l, u) = subtext (ll, lc) (ll, lc) (ul, uc) where (FU.Position _ lc ll) = l (FU.Position _ uc ul) = u -takeBounds' ((ll, lc), (ul, uc)) tk inp = - if (ll == ul && lc == uc) || (ll > ul) then (B.reverse tk, inp) - else - case B.uncons inp of - Nothing -> (B.reverse tk, inp) - Just ('\n', ys) -> takeBounds' ((ll+1, 0), (ul, uc)) (B.cons '\n' tk) ys - Just (x, xs) -> takeBounds' ((ll, lc+1), (ul, uc)) (B.cons x tk) xs + +{-| + Split a text. + + Returns a tuple containing: + 1. the bit of input text between upper and lower bounds + 2. the remaining input text + + Takes: + 1. current cursor position + 2. lower bound + 3. upper bound + 4. input text + +-} +subtext :: (Int, Int) -> (Int, Int) -> (Int, Int) -> B.ByteString -> (B.ByteString, B.ByteString) +subtext cursor (lowerLn, lowerCol) (upperLn, upperCol) = + subtext' B.empty cursor + where + subtext' acc (cursorLn, cursorCol) input + + | cursorLn <= lowerLn && (cursorCol >= lowerCol ==> cursorLn < lowerLn) = + case B.uncons input of + Nothing -> (B.reverse acc, input) + Just ('\n', input') -> subtext' acc (cursorLn+1, 1) input' + Just (_, input') -> subtext' acc (cursorLn, cursorCol+1) input' + + | cursorLn <= upperLn && (cursorCol >= upperCol ==> cursorLn < upperLn) = + case B.uncons input of + Nothing -> (B.reverse acc, input) + Just ('\n', input') -> subtext' (B.cons '\n' acc) (cursorLn+1, 1) input' + Just (x, input') -> subtext' (B.cons x acc) (cursorLn, cursorCol+1) input' + + | otherwise = + (B.reverse acc, input) + +-- | Logical implication operator. +(==>) :: Bool -> Bool -> Bool; infix 2 ==> +a ==> b = a <= b diff --git a/src/Camfort/Specification/Parser.hs b/src/Camfort/Specification/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Camfort/Specification/Parser.hs @@ -0,0 +1,108 @@ +{- | +Module : Camfort.Specification.Parser +Description : Functionality common to all specification parsers. +Copyright : (c) 2017, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish +License : Apache-2.0 + +Maintainer : dom.orchard@gmail.com +Stability : experimental +-} + +{-# LANGUAGE FlexibleContexts #-} + +module Camfort.Specification.Parser + ( + -- * Specification Parsers + SpecParser + , looksLikeASpec + , mkParser + , runParser + -- ** Errors + , SpecParseError + , parseError + ) where + +import Control.Monad.Except (throwError) +import Data.List (isPrefixOf) +import qualified Data.Text as T + +data SpecParseError e + = ParseError e + | InvalidSpecificationCharacter Char + | MissingSpecificationCharacter + deriving (Eq) + +instance (Show e) => Show (SpecParseError e) where + show (InvalidSpecificationCharacter c) = + "Invalid character at start of specification: " ++ show c + show MissingSpecificationCharacter = "missing start of specification" + show (ParseError e) = show e + +-- | Embed an error as a specification parse error. +parseError :: e -> SpecParseError e +parseError = ParseError + +invalidSpecificationCharacter :: Char -> SpecParseError e +invalidSpecificationCharacter = InvalidSpecificationCharacter + +missingSpecificationCharacter :: SpecParseError e +missingSpecificationCharacter = MissingSpecificationCharacter + +-- | Parser for specifications of type @r@ that may fail with error type @e@. +data SpecParser e r = SpecParser + { + -- | The underlying parser. + parser :: String -> Either e r + -- | A list of keywords that indicate the type of specification (e.g., @"stencil"@ or @"access"@). + , specKeywords :: [String] + } + +-- | Does the character indicate the start of an abritrary specification? +-- +-- These characters are used to help distinguish specifications +-- from normal comments. +isSpecStartChar :: Char -> Bool +isSpecStartChar = (`elem` "=!<>") + +-- | Run the given parser on a string to produce a specification +-- (or a reason why it couldn't be parsed). +runParser :: SpecParser e r -> String -> Either (SpecParseError e) r +runParser p s = case stripInitial s of + Right s' -> case parser p s' of + Left e -> throwError $ parseError e + Right r -> pure r + Left e -> throwError e + where stripInitial = stripAnnChar . stripLeadingWhiteSpace + stripAnnChar [] = + throwError missingSpecificationCharacter + stripAnnChar (c:cs) | isSpecStartChar c = pure (stripLeadingWhiteSpace cs) + | otherwise = + throwError $ invalidSpecificationCharacter c + +-- | Define a specification parser. +mkParser :: (String -> Either e r) -- ^ Parser with error type @e@ and result type @r@. + -> [String] -- ^ Keywords that indicate the type of specification. + -> SpecParser e r +mkParser = SpecParser + +-- | Remove any whitespace characters at the beginning of the string. +stripLeadingWhiteSpace :: String -> String +stripLeadingWhiteSpace = T.unpack . T.strip . T.pack + +-- | Check if a comment is probably an attempt at a specification +-- that can be parsed by the given parser. +looksLikeASpec :: SpecParser e r -> String -> Bool +looksLikeASpec p text + | length (stripLeadingWhiteSpace text) >= 2 = + case stripLeadingWhiteSpace text of + -- Check the leading character is '=' for specification + c:cs -> isSpecStartChar c && testAnnotation cs + _ -> False + | otherwise = False + where + testAnnotation inp = case specKeywords p of + [] -> True + ks -> any (inp `hasPrefix`) ks + hasPrefix [] _ = False + hasPrefix (' ':xs) str = hasPrefix xs str + hasPrefix xs str = str `isPrefixOf` xs 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,6 +17,8 @@ module Camfort.Specification.Stencils (InferMode, infer, check, synth) where +import Control.Arrow ((***), first, second) + import Camfort.Specification.Stencils.CheckFrontend hiding (LogLine) import Camfort.Specification.Stencils.InferenceFrontend import Camfort.Specification.Stencils.Synthesis @@ -31,28 +33,33 @@ import Data.List + +-- | Helper for retrieving analysed blocks. +getBlocks = FAB.analyseBBlocks . FAR.analyseRenames . FA.initAnalysis + -------------------------------------------------- -- Stencil specification inference -- -------------------------------------------------- -- Top-level of specification inference -infer :: InferMode -> Char -> Filename +infer :: InferMode + -> Char -> F.ProgramFile Annotation -> (String, F.ProgramFile Annotation) -infer mode marker filename pf = +infer mode marker pf = -- Append filename to any outputs if null output - then ("", fmap FA.prevAnnotation pf'') - else ("\n" ++ filename ++ "\n" ++ output, fmap FA.prevAnnotation pf'') + then ("", infer1) + else ("\n" ++ filename ++ "\n" ++ output, infer1) where + filename = F.pfGetFilename pf output = intercalate "\n" . filter (not . white) - . map (formatSpec Nothing nameMap) $ results + . map formatSpecNoComment $ infer2 white = all (\x -> (x == ' ') || (x == '\t')) - (pf'', results) = stencilInference nameMap mode marker - . FAB.analyseBBlocks $ pf' - nameMap = FAR.extractNameMap pf' - pf' = FAR.analyseRenames . FA.initAnalysis $ pf + infer' = stencilInference mode marker . getBlocks $ pf + infer1 = fmap FA.prevAnnotation . fst $ infer' + infer2 = snd infer' -------------------------------------------------- -- Stencil specification synthesis -- @@ -61,39 +68,46 @@ -- Top-level of specification synthesis synth :: InferMode -> Char - -> [(Filename, F.ProgramFile A)] - -> (String, [(Filename, F.ProgramFile Annotation)]) -synth mode marker = foldr buildOutput ("", []) + -> [F.ProgramFile A] + -> (String, [F.ProgramFile Annotation]) +synth mode marker = first normaliseMsg . foldr buildOutput (("",""), []) where - buildOutput (f, pf) (r, pfs) = (r ++ r', (f, pf') : pfs) - where (r', pf') = synthPF mode marker f pf + buildOutput pf = + let f = F.pfGetFilename pf + in case synthWithCheck pf of + Left err -> first . first $ (++ mkMsg f err) + Right (warn,pf') -> second (if null warn + then id + else (++ mkMsg f warn)) *** (pf':) + synthWithCheck pf = + let blocks = getBlocks pf + checkRes = stencilChecking blocks in + case checkFailure checkRes of + Nothing -> + let inference = fmap FA.prevAnnotation . + fst $ stencilInference Synth marker blocks + in Right (maybe "" show (checkWarnings checkRes), inference) + Just err -> Left $ show err -synthPF :: InferMode -> Char -> Filename - -> F.ProgramFile Annotation - -> (String, F.ProgramFile Annotation) -synthPF _ marker _ pf = - -- Append filename to any outputs - ("", fmap FA.prevAnnotation pf'') - where - (pf'', _) = stencilInference nameMap Synth marker - . FAB.analyseBBlocks $ pf' - nameMap = FAR.extractNameMap pf' - pf' = FAR.analyseRenames . FA.initAnalysis $ pf + mkMsg f e = "\nEncountered the following errors when checking\ + \ stencil specs for '" ++ f ++ "'\n\n" ++ e + normaliseMsg ("", warn) = warn + normaliseMsg (err, warn) = err ++ warn ++ "\nPlease resolve these errors, and then\ + \ run synthesis again." + + -------------------------------------------------- -- Stencil specification checking -- -------------------------------------------------- -check :: Filename -> F.ProgramFile Annotation -> String -check filename pf = +check :: F.ProgramFile Annotation -> String +check pf = -- Append filename to any outputs if null output then "" else "\n" ++ filename ++ "\n" ++ output where - output = intercalate "\n" results - -- Applying checking mechanism - results = stencilChecking nameMap . FAB.analyseBBlocks $ pf' - nameMap = FAR.extractNameMap pf' - pf' = FAR.analyseRenames . FA.initAnalysis $ pf + filename = F.pfGetFilename pf + output = show . stencilChecking . getBlocks $ pf -- Local variables: -- mode: haskell 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 @@ -17,11 +17,11 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -module Camfort.Specification.Stencils.Annotation where +module Camfort.Specification.Stencils.Annotation () where import Camfort.Analysis.Annotations import Camfort.Analysis.CommentAnnotator -import qualified Camfort.Specification.Stencils.Grammar as Gram +import qualified Camfort.Specification.Stencils.Parser.Types as Gram import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA @@ -31,12 +31,12 @@ -- Instances for embedding parsed specifications into the AST instance ASTEmbeddable (FA.Analysis Annotation) Gram.Specification where annotateWithAST ann ast = - onPrev (\ann -> ann { stencilSpec = Just $ Left ast }) ann + onPrev (giveParseSpec ast) ann instance Linkable (FA.Analysis Annotation) where link ann (b@(F.BlDo {})) = onPrev (\ann -> ann { stencilBlock = Just b }) ann link ann (b@(F.BlStatement _ _ _ (F.StExpressionAssign {}))) = onPrev (\ann -> ann { stencilBlock = Just b }) ann - link ann b = ann - linkPU ann pu = ann + link ann _ = ann + linkPU ann _ = 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 @@ -18,51 +18,71 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ImplicitParams #-} -module Camfort.Specification.Stencils.CheckBackend where +module Camfort.Specification.Stencils.CheckBackend + ( + -- * Classes + SynToAst(..) + -- * Errors + , SynToAstError + , regionNotInScope + ) where +import Data.Function (on) + import Camfort.Specification.Stencils.Syntax import Camfort.Specification.Stencils.Model -import qualified Camfort.Specification.Stencils.Grammar as SYN +import qualified Camfort.Specification.Stencils.Parser.Types as SYN -type ErrorMsg = String +data SynToAstError = RegionNotInScope String + deriving (Eq) --- Class for functions converting from Grammar parse +regionNotInScope :: String -> SynToAstError +regionNotInScope = RegionNotInScope + +instance Show SynToAstError where + show (RegionNotInScope r) = "Error: region " ++ r ++ " is not in scope." + +-- Class for functions converting from Parser parse -- syntax to the AST representation of the Syntax module class SynToAst s t | s -> t where - synToAst :: (?renv :: RegionEnv) => s -> Either ErrorMsg t + synToAst :: (?renv :: RegionEnv) => s -> Either SynToAstError t -- Top-level conversion of declarations -instance SynToAst SYN.Specification (Either RegionEnv SpecDecls) where +instance SynToAst SYN.Specification (Either RegionDecl SpecDecl) where synToAst (SYN.SpecDec spec vars) = do spec' <- synToAst spec - return $ Right [(vars, spec')] + return $ Right (vars, spec') synToAst (SYN.RegionDec rvar region) = do spec' <- synToAst region - return $ Left [(rvar, spec')] + return $ Left (rvar, spec') -- Convert temporal or spatial specifications -instance SynToAst SYN.Spec Specification where - synToAst (SYN.Spatial mods r) = do - (modLinear, approx) <- synToAst mods - r' <- synToAst r - let s' = Spatial r' - return $ Specification $ addLinearity modLinear $ - case approx of - Just SYN.AtMost -> Bound Nothing (Just s') - Just SYN.AtLeast -> Bound (Just s') Nothing - Nothing -> Exact s' - where - addLinearity Linear appr = Once appr - addLinearity NonLinear appr = Mult appr +instance SynToAst SYN.SpecInner Specification where + synToAst (SYN.SpecInner spec isStencil) = do + spec' <- synToAst spec + return $ Specification spec' isStencil +instance SynToAst (Multiplicity (Approximation SYN.Region)) (Multiplicity (Approximation Spatial)) where + synToAst (Once a) = fmap Once . synToAst $ a + synToAst (Mult a) = fmap Mult . synToAst $ a + +instance SynToAst (Approximation SYN.Region) (Approximation Spatial) where + synToAst (Exact s) = fmap (Exact . Spatial) . synToAst $ s + synToAst (Bound s1 s2) = (Bound `on` (fmap Spatial)) <$> synToAst s1 <*> synToAst s2 + +instance SynToAst (Maybe SYN.Region) (Maybe RegionSum) where + synToAst Nothing = pure Nothing + synToAst (Just r) = fmap Just . synToAst $ r + -- Convert region definitions into the DNF-form used internally instance SynToAst SYN.Region RegionSum where synToAst = dnf -- Convert a grammar syntax to Disjunctive Normal Form AST -dnf :: (?renv :: RegionEnv) => SYN.Region -> Either ErrorMsg RegionSum +dnf :: (?renv :: RegionEnv) => SYN.Region -> Either SynToAstError RegionSum +dnf (SYN.RegionConst rconst) = pure . Sum $ [Product [rconst]] -- Distributive law dnf (SYN.And r1 r2) = do r1' <- dnf r1 @@ -76,32 +96,10 @@ r2' <- dnf r2 return $ Sum $ unSum r1' ++ unSum r2' -- Region conversion -dnf (SYN.Forward dep dim reflx) = return $ Sum [Product [Forward dep dim reflx]] -dnf (SYN.Backward dep dim reflx) = return $ Sum [Product [Backward dep dim reflx]] -dnf (SYN.Centered dep dim reflx) = return $ Sum [Product [Centered dep dim reflx]] -dnf (SYN.Var v) = +dnf (SYN.Var v) = case lookup v ?renv of - Nothing -> Left $ "Error: region " ++ v ++ " is not in scope." + Nothing -> Left (RegionNotInScope v) Just rs -> return rs - --- Convert modifier list to modifier info -instance SynToAst [SYN.Mod] - (Linearity, Maybe SYN.Mod) where - synToAst mods = return (linearity, approx) - where - linearity = if SYN.ReadOnce `elem` mods then Linear else NonLinear - - approx = find' isApprox mods - isApprox SYN.AtMost = Just SYN.AtMost - isApprox SYN.AtLeast = Just SYN.AtLeast - isApprox _ = Nothing - -find' :: Eq a => (a -> Maybe b) -> [a] -> Maybe b -find' p [] = Nothing -find' p (x : xs) = - case p x of - Nothing -> find' p xs - Just b -> Just b -- Local variables: -- mode: haskell 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,30 +14,45 @@ limitations under the License. -} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} -module Camfort.Specification.Stencils.CheckFrontend where +module Camfort.Specification.Stencils.CheckFrontend + ( + -- * Stencil checking + stencilChecking + -- ** Validation Results + , CheckResult + , checkFailure + , checkWarnings + -- ** Helpers + , existingStencils + ) where -import Data.Generics.Uniplate.Operations import Control.Arrow +import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT) import Control.Monad.State.Strict import Control.Monad.Writer.Strict hiding (Product) +import Data.Function (on) +import Data.Generics.Uniplate.Operations +import Data.List (intercalate, sort, union) +import Camfort.Analysis.Annotations +import Camfort.Analysis.CommentAnnotator import qualified Camfort.Helpers.Vec as V +import Camfort.Specification.Parser (SpecParseError) 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.Generate +import qualified Camfort.Specification.Stencils.Parser as Parser +import Camfort.Specification.Stencils.Parser.Types (reqRegions) import Camfort.Specification.Stencils.Model -import Camfort.Specification.Stencils.InferenceFrontend hiding (LogLine) import Camfort.Specification.Stencils.Syntax -import Camfort.Analysis.Annotations -import Camfort.Analysis.CommentAnnotator import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA -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 @@ -48,73 +63,295 @@ import Data.Int import qualified Data.Set as S +newtype CheckResult = CheckResult [StencilResult] + +-- | Retrieve a list of 'StencilResult' from a 'CheckResult'. +-- +-- Ensures correct ordering of results. +getCheckResult :: CheckResult -> [StencilResult] +getCheckResult (CheckResult rs) = sort rs + +instance Eq CheckResult where + (==) = (==) `on` getCheckResult + +-- | Represents only the check results for invalid stencils. +newtype CheckError = CheckError { getCheckError :: [StencilCheckError] } + +-- | Represents only the check results that resulted in warnings. +newtype CheckWarning = CheckWarning { getCheckWarning :: [StencilCheckWarning] } + +-- | Retrieve the checks for invalid stencils from a 'CheckResult'. Result is +-- Nothing if there are no invalid checks. +checkFailure :: CheckResult -> Maybe CheckError +checkFailure c = case catMaybes $ fmap toFailure (getCheckResult c) of + [] -> Nothing + xs -> Just $ CheckError xs + where toFailure (SCFail err) = Just err + toFailure _ = Nothing + +checkWarnings :: CheckResult -> Maybe CheckWarning +checkWarnings c = case catMaybes $ fmap toWarning (getCheckResult c) of + [] -> Nothing + xs -> Just $ CheckWarning xs + where toWarning (SCWarn warn) = Just warn + toWarning _ = Nothing + +-- | Result of stencil validation. +data StencilResult + -- | No issues were identified with the stencil at the given position. + = SCOkay { scSpan :: FU.SrcSpan + , scSpec :: Specification + , scVar :: Variable + , scBodySpan :: FU.SrcSpan + } + -- | Validation of stencil failed. See 'StencilCheckError' for information + -- on the types of validation errors that can occur. + | SCFail StencilCheckError + -- | A warning which shouldn't interrupt other procedures. + | SCWarn StencilCheckWarning + deriving (Eq) + +class GetSpan a where + getSpan :: a -> FU.SrcSpan + +instance GetSpan StencilResult where + getSpan SCOkay{scSpan = srcSpan} = srcSpan + getSpan (SCFail err) = getSpan err + getSpan (SCWarn warn) = getSpan warn + +instance GetSpan StencilCheckError where + getSpan (SynToAstError _ srcSpan) = srcSpan + getSpan (NotWellSpecified (srcSpan, _) _) = srcSpan + getSpan (ParseError srcSpan _) = srcSpan + getSpan (RegionExists srcSpan _) = srcSpan + +instance GetSpan StencilCheckWarning where + getSpan (DuplicateSpecification srcSpan) = srcSpan + getSpan (UnusedRegion srcSpan _) = srcSpan + +instance Ord StencilResult where + compare = compare `on` getSpan + +instance Ord StencilCheckError where + compare = compare `on` getSpan + +-- | Represents a way in which validation of a stencil can fail. +data StencilCheckError + -- | Error occurred during conversion from parsed representation to AST. + = SynToAstError SynToAstError FU.SrcSpan + -- | The existing stencil conflicts with an inferred stencil. + | NotWellSpecified (FU.SrcSpan, SpecDecls) (FU.SrcSpan, SpecDecls) + -- | The stencil could not be parsed correctly. + | ParseError FU.SrcSpan (SpecParseError Parser.SpecParseError) + -- | A definition for the region alias already exists. + | RegionExists FU.SrcSpan Variable + deriving (Eq) + +-- | Create a check result informating a user of a 'SynToAstError'. +synToAstError :: SynToAstError -> FU.SrcSpan -> StencilResult +synToAstError err srcSpan = SCFail $ SynToAstError err srcSpan + +-- | Create a check result informating a user of a 'NotWellSpecified' error. +notWellSpecified :: (FU.SrcSpan, SpecDecls) -> (FU.SrcSpan, SpecDecls) -> StencilResult +notWellSpecified got inferred = SCFail $ NotWellSpecified got inferred + +-- | Create a check result informating a user of a parse error. +parseError :: FU.SrcSpan -> (SpecParseError Parser.SpecParseError) -> StencilResult +parseError srcSpan err = SCFail $ ParseError srcSpan err + +-- | Create a check result informating that a region already exists. +regionExistsError :: FU.SrcSpan -> Variable -> StencilResult +regionExistsError srcSpan r = SCFail $ RegionExists srcSpan r + +-- | Represents a non-fatal validation warning. +data StencilCheckWarning + -- | Specification is defined multiple times. + = DuplicateSpecification FU.SrcSpan + -- | Region is defined but not used. + | UnusedRegion FU.SrcSpan Variable + deriving (Eq) + +-- | Create a check result informing a user of a duplicate specification. +duplicateSpecification :: FU.SrcSpan -> StencilResult +duplicateSpecification = SCWarn . DuplicateSpecification + +-- | Create a check result informating an unused region. +unusedRegion :: FU.SrcSpan -> Variable -> StencilResult +unusedRegion srcSpan var = SCWarn $ UnusedRegion srcSpan var + +specOkay :: FU.SrcSpan -> Specification -> Variable -> FU.SrcSpan -> StencilResult +specOkay spanSpec@(FU.SrcSpan (FU.Position o1 _ _) (FU.Position o2 _ _)) spec var spanBody@(FU.SrcSpan (FU.Position o1' _ _) (FU.Position o2' _ _)) = + SCOkay { scSpan = spanSpec + , scSpec = spec + , scBodySpan = spanBody + , scVar = var + } + +-- | Pretty print a message with suitable spacing after the source position. +prettyWithSpan :: FU.SrcSpan -> String -> String +prettyWithSpan srcSpan s = show srcSpan ++ " " ++ s + +instance Show CheckResult where + show = intercalate "\n" . fmap show . getCheckResult + +instance Show CheckError where + show = intercalate "\n" . fmap show . getCheckError + +instance Show CheckWarning where + show = intercalate "\n" . fmap show . getCheckWarning + +instance Show StencilResult where + show SCOkay{ scSpan = span } = prettyWithSpan span "Correct." + show (SCFail err) = show err + show (SCWarn warn) = show warn + +instance Show StencilCheckError where + show (SynToAstError err srcSpan) = prettyWithSpan srcSpan (show err) + show (NotWellSpecified (spanActual, stencilActual) (spanInferred, stencilInferred)) = + let sp = replicate 8 ' ' + in concat [prettyWithSpan spanActual "Not well specified.\n", sp, + "Specification is:\n", sp, sp, pprintSpecDecls stencilActual, "\n", + sp, "but at ", show spanInferred, " the code behaves as\n", sp, sp, + pprintSpecDecls stencilInferred] + show (ParseError srcSpan err) = prettyWithSpan srcSpan (show err) + show (RegionExists srcSpan name) = + prettyWithSpan srcSpan ("Region '" ++ name ++ "' already defined") + +instance Show StencilCheckWarning where + show (DuplicateSpecification srcSpan) = prettyWithSpan srcSpan + "Warning: Duplicate specification." + show (UnusedRegion srcSpan name) = prettyWithSpan srcSpan $ + "Warning: Unused region '" ++ name ++ "'" + -- Entry point -stencilChecking :: FAR.NameMap -> F.ProgramFile (FA.Analysis A) -> [String] -stencilChecking nameMap pf = snd . runWriter $ - do -- Attempt to parse comments to specifications - pf' <- annotateComments Gram.specParser pf +stencilChecking :: F.ProgramFile (FA.Analysis A) -> CheckResult +stencilChecking pf = CheckResult . snd . runWriter $ do + -- Attempt to parse comments to specifications + pf' <- annotateComments Parser.specParser (\srcSpan err -> tell [parseError srcSpan err]) pf + let -- get map of AST-Block-ID ==> corresponding AST-Block + bm = FAD.genBlockMap 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 + -- get map of variable name ==> { defining AST-Block-IDs } + dm = FAD.genDefMap bm + -- perform reaching definitions analysis + rd = FAD.reachingDefinitions dm gr + -- create graph of definition "flows" + flowsGraph = FAD.genFlowsToGraph bm dm gr rd + -- identify every loop by its back-edge + beMap = FAD.genBackEdgeMap (FAD.dominators gr) gr + ivmap = FAD.genInductionVarMapByASTBlock beMap gr + -- results :: Checker (F.ProgramFile (F.ProgramFile (FA.Analysis A))) + results = descendBiM perProgramUnitCheck pf' - -- get map of AST-Block-ID ==> corresponding AST-Block - let bm = FAD.genBlockMap pf' - -- get map of program unit ==> basic block graph - let bbm = FAB.genBBlockMap pf' - -- build the supergraph of global dependency - let sgr = FAB.genSuperBBGr bbm - -- extract the supergraph itself - let gr = FAB.superBBGrGraph sgr - -- get map of variable name ==> { defining AST-Block-IDs } - let dm = FAD.genDefMap bm - let pprint = map (\(span, spec) -> show span ++ " " ++ spec) - -- perform reaching definitions analysis - let rd = FAD.reachingDefinitions dm gr - -- create graph of definition "flows" - let flTo = FAD.genFlowsToGraph bm dm gr rd - -- identify every loop by its back-edge - let beMap = FAD.genBackEdgeMap (FAD.dominators gr) gr - let ivmap = FAD.genInductionVarMapByASTBlock beMap gr - let results = let ?flowsGraph = flTo in - let ?nameMap = nameMap - in descendBiM perProgramUnitCheck pf' - -- Format output - let (_, output) = evalState (runWriterT results) (([], Nothing), ivmap) - tell $ pprint output + let addUnusedRegionsToResult = do + regions' <- fmap regions get + usedRegions' <- fmap usedRegions get + let unused = filter ((`notElem` usedRegions') . snd) regions' + mapM_ (addResult . uncurry unusedRegion) unused + output = checkResult $ execState + (runReaderT + (runChecker (results >> addUnusedRegionsToResult)) + flowsGraph) + (startState ivmap) -type LogLine = (FU.SrcSpan, String) -type Checker a = - WriterT [LogLine] - (State ((RegionEnv, Maybe F.ProgramUnitName), FAD.InductionVarMapByASTBlock)) a + tell output +data CheckState = CheckState + { regionEnv :: RegionEnv + , checkResult :: [StencilResult] + , prog :: Maybe F.ProgramUnitName + , ivMap :: FAD.InductionVarMapByASTBlock + , regions :: [(FU.SrcSpan, Variable)] + , usedRegions :: [Variable] + } + +addResult :: StencilResult -> Checker () +addResult r = modify (\s -> s { checkResult = r : checkResult s }) + +-- | Remove the given regions variables from the tracked unused regions. +informRegionsUsed :: [Variable] -> Checker () +informRegionsUsed regions = modify + (\s -> s { usedRegions = usedRegions s `union` regions }) + +-- | Start tracking a region. +addRegionToTracked :: FU.SrcSpan -> Variable -> Checker () +addRegionToTracked srcSpan@(FU.SrcSpan (FU.Position o1 _ _) (FU.Position o2 _ _)) r = + modify (\s -> s { regions = (srcSpan, r) : regions s }) + +-- | True if the region name is already tracked. +regionExists :: Variable -> Checker Bool +regionExists reg = do + knownNames <- fmap (fmap snd . regions) get + pure $ reg `elem` knownNames + +startState :: FAD.InductionVarMapByASTBlock -> CheckState +startState ivmap = + CheckState { regionEnv = [] + , checkResult = [] + , prog = Nothing + , ivMap = ivmap + , regions = [] + , usedRegions = [] + } + +newtype Checker a = + Checker { runChecker :: ReaderT (FAD.FlowsGraph A) (State CheckState) a } + deriving ( Functor, Applicative, Monad + , MonadReader (FAD.FlowsGraph A) + , MonadState CheckState + ) + -- If the annotation contains an unconverted stencil specification syntax tree -- then convert it and return an updated annotation containing the AST -parseCommentToAST :: FA.Analysis A -> FU.SrcSpan -> Checker (FA.Analysis A) +parseCommentToAST :: FA.Analysis A -> FU.SrcSpan -> Checker (Either SynToAstError (FA.Analysis A)) parseCommentToAST ann span = - case stencilSpec (FA.prevAnnotation ann) of - Just (Left stencilComment) -> do - ((regionEnv, _), _) <- get - let ?renv = regionEnv - in case synToAst stencilComment of - Left err -> error $ show span ++ ": " ++ err - Right ast -> return $ onPrev - (\ann -> ann {stencilSpec = Just (Right ast)}) ann - _ -> return ann + case getParseSpec (FA.prevAnnotation ann) of + Just stencilComment -> do + informRegionsUsed (reqRegions stencilComment) + renv <- fmap regionEnv get + let ?renv = renv + case synToAst stencilComment of + Right ast -> do + pfun <- either (\reg@(var,_) -> do + exists <- regionExists var + if exists + then addResult (regionExistsError span var) + >> pure id + else addRegionToTracked span var + >> pure (giveRegionSpec reg)) + (pure . giveAstSpec . pure) ast + pure . pure $ onPrev pfun ann + Left err -> pure . Left $ err + _ -> pure . pure $ ann + -- If the annotation contains an encapsulated region environment, extract it -- and add it to current region environment in scope updateRegionEnv :: FA.Analysis A -> Checker () updateRegionEnv ann = - case stencilSpec (FA.prevAnnotation ann) of - Just (Right (Left regionEnv)) -> modify $ first (first (regionEnv ++)) - _ -> return () + case getRegionSpec (FA.prevAnnotation ann) of + Just renv -> modify (\s -> s { regionEnv = renv : regionEnv s }) + _ -> pure () checkOffsetsAgainstSpec :: [(Variable, Multiplicity [[Int]])] -> [(Variable, Specification)] -> Bool 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 + variablesConsistent && + all (\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) + specToVecList where + variablesConsistent = + let vs1 = sort . fmap fst $ offsetMaps + vs2 = sort . fmap fst $ specMaps + in vs1 == vs2 toUNF :: [ V.Vec n Int64 ] -> UnionNF n Offsets toUNF = joins1 . map (return . fmap intToSubscript) @@ -147,61 +384,36 @@ -- Go into the program units first and record the module name when -- entering into a module -perProgramUnitCheck :: (?nameMap :: FAR.NameMap, ?flowsGraph :: FAD.FlowsGraph A) - => F.ProgramUnit (FA.Analysis A) -> Checker (F.ProgramUnit (FA.Analysis A)) +perProgramUnitCheck :: + F.ProgramUnit (FA.Analysis A) -> Checker (F.ProgramUnit (FA.Analysis A)) + perProgramUnitCheck p@F.PUModule{} = do - modify $ first (second (const (Just $ FA.puName p))) + modify (\s -> s { prog = Just $ FA.puName p }) descendBiM perBlockCheck p perProgramUnitCheck p = descendBiM perBlockCheck p -perBlockCheck :: (?nameMap :: FAR.NameMap, ?flowsGraph :: FAD.FlowsGraph A) - => F.Block (FA.Analysis A) -> Checker (F.Block (FA.Analysis A)) +perBlockCheck :: F.Block (FA.Analysis A) -> Checker (F.Block (FA.Analysis A)) perBlockCheck b@(F.BlComment ann span _) = do - ann' <- parseCommentToAST ann span - updateRegionEnv ann' - let b' = F.setAnnotation ann' b - case (stencilSpec $ FA.prevAnnotation ann', stencilBlock $ FA.prevAnnotation ann') of - -- Comment contains a specification and an Associated block - (Just (Right (Right specDecls)), Just block) -> - case block of - s@(F.BlStatement _ span' _ (F.StExpressionAssign _ _ lhs _)) -> - case isArraySubscript lhs of - Just subs -> do - -- Create list of relative indices - ivmap <- snd <$> get - -- Do analysis - let realName v = v `fromMaybe` (v `M.lookup` ?nameMap) - let lhsN = fromMaybe [] (neighbourIndex ivmap subs) - let correctNames = map (first realName) - let relOffsets = correctNames . fst . runWriter $ genOffsets ivmap lhsN [s] - let multOffsets = map (\relOffset -> - case relOffset of - (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 - if checkOffsetsAgainstSpec multOffsets expandedDecls - then tell [ (span, "Correct.") ] - else do - let correctNames2 = map (first (map realName)) - let inferred = correctNames2 . fst . fst . runWriter $ genSpecifications ivmap lhsN [s] - let sp = replicate 8 ' ' - tell [ (span, - "Not well specified.\n" - ++ sp ++ "Specification is:\n" - ++ sp ++ sp ++ pprintSpecDecls specDecls ++ "\n" - ++ sp ++ "but at " ++ show span' ++ " the code behaves as\n" - ++ sp ++ sp ++ pprintSpecDecls inferred) ] - - return b' - Nothing -> return b' + ast <- parseCommentToAST ann span + case ast of + Left err -> addResult (synToAstError err span) *> pure b + Right ann' -> do + flowsGraph <- ask + updateRegionEnv ann' + let b' = F.setAnnotation ann' b + case (getAstSpec $ FA.prevAnnotation ann', stencilBlock $ FA.prevAnnotation ann') of + -- Comment contains a specification and an Associated block + (Just specDecls, Just block) -> + case block of + s@(F.BlStatement _ span' _ (F.StExpressionAssign _ _ lhs _)) -> do + checkStencil flowsGraph s specDecls span' (isArraySubscript lhs) span + return b' - -- Stub, maybe collect stencils inside 'do' block - F.BlDo{} -> return b' - _ -> return b' - _ -> return b' + -- Stub, maybe collect stencils inside 'do' block + F.BlDo{} -> return b' + _ -> return b' + _ -> return b' perBlockCheck b@(F.BlDo _ _ _ _ _ _ body _) = do -- descend into the body of the do-statement @@ -214,6 +426,67 @@ -- Go inside child blocks mapM_ (descendBiM perBlockCheck) $ children b return b + +-- | Validate the stencil and log an appropriate result. +checkStencil :: FAD.FlowsGraph A -> F.Block (FA.Analysis A) -> SpecDecls + -> FU.SrcSpan -> Maybe [F.Index (FA.Analysis Annotation)] -> FU.SrcSpan -> Checker () +checkStencil flowsGraph block specDecls spanInferred maybeSubs span = do + -- Work out whether this is a stencil (non empty LHS indices) or not + let (subs, isStencil) = case maybeSubs of + Nothing -> ([], False) + Just subs -> (subs, True) + + -- Get the induction variables relative to the current block + ivmap <- fmap ivMap get + let ivs = extractRelevantIVS ivmap block + + -- Do analysis; create list of relative indices + let lhsN = fromMaybe [] (neighbourIndex ivmap subs) + relOffsets = fst . runWriter $ genOffsets flowsGraph ivs lhsN [block] + multOffsets = map (\relOffset -> + case relOffset of + (var, (True, offsets)) -> (var, Mult offsets) + (var, (False, offsets)) -> (var, Once offsets)) relOffsets + expandedDecls = + concatMap (\(vars,spec) -> map (flip (,) spec) vars) specDecls + + let userDefinedIsStencils = map (\(_, Specification _ b) -> b) specDecls + -- Model and compare the current and specified stencil specs + if all (isStencil ==) userDefinedIsStencils && checkOffsetsAgainstSpec multOffsets expandedDecls + then mapM_ (\spec@(v,s) -> do + specExists <- seenBefore spec + if specExists then addResult (duplicateSpecification span) + else addResult (specOkay span s v spanInferred)) expandedDecls + else do + let inferred = fst . fst . runWriter $ genSpecifications flowsGraph ivs lhsN block + addResult (notWellSpecified (span, specDecls) (spanInferred, inferred)) + where + seenBefore :: (Variable, Specification) -> Checker Bool + seenBefore (v,spec) = do + checkLog <- fmap checkResult get + pure $ any (\x -> case x of + SCOkay{ scSpec=spec' + , scBodySpan=bspan + , scVar = var} + -> spec' == spec && bspan == spanInferred && v == var + _ -> False) checkLog + +genOffsets :: + FAD.FlowsGraph A + -> [Variable] + -> [Neighbour] + -> [F.Block (FA.Analysis A)] + -> Writer EvalLog [(Variable, (Bool, [[Int]]))] +genOffsets flowsGraph ivs lhs blocks = do + let (subscripts, _) = genSubscripts flowsGraph blocks + assocsSequence $ mkOffsets subscripts + where + mkOffsets = M.mapWithKey (\v -> indicesToRelativisedOffsets ivs v lhs) + +existingStencils :: CheckResult -> [(Specification, FU.SrcSpan, Variable)] +existingStencils = mapMaybe getExistingStencil . getCheckResult + where getExistingStencil (SCOkay _ spec var bodySpan) = Just (spec, bodySpan, var) + getExistingStencil _ = Nothing -- Local variables: -- mode: haskell diff --git a/src/Camfort/Specification/Stencils/Consistency.hs b/src/Camfort/Specification/Stencils/Consistency.hs --- a/src/Camfort/Specification/Stencils/Consistency.hs +++ b/src/Camfort/Specification/Stencils/Consistency.hs @@ -20,7 +20,7 @@ Specification -> Multiplicity (UnionNF n Offsets) -> ConsistencyResult -consistent (Specification mult) observedIxs = +consistent (Specification mult _) observedIxs = -- First do the linearity check case (specModel, observedIxs) of (Mult a, Mult b) -> a `consistent'` b @@ -28,7 +28,7 @@ (Once _, Mult _) ->Inconsistent "Specification is readOnce, but there are repeated indices." (Mult _, Once _) -> Inconsistent - "Specification lacks readOnce, but the indices are inuque." + "Specification lacks readOnce, but the indices are unique." where specModel :: Multiplicity (Approximation (UnionNF n (Interval Standard))) specModel = diff --git a/src/Camfort/Specification/Stencils/Generate.hs b/src/Camfort/Specification/Stencils/Generate.hs new file mode 100644 --- /dev/null +++ b/src/Camfort/Specification/Stencils/Generate.hs @@ -0,0 +1,410 @@ +{- | +Module : Camfort.Specification.Stencils.Generate +Description : Generate stencils for inference and synthesis +Copyright : (c) 2017, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish +License : Apache-2.0 + +Maintainer : dom.orchard@gmail.com +Stability : experimental +-} + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module Camfort.Specification.Stencils.Generate + ( + EvalLog + , Neighbour(..) + , extractRelevantIVS + , assocsSequence + , genSpecifications + , genSubscripts + , isArraySubscript + , neighbourIndex + , isVariableExpr + , convIxToNeighbour + , indicesToRelativisedOffsets + , indicesToSpec + , neighbourToOffset + , relativise + ) where + +import Control.Monad (void, when, zipWithM) +import Control.Monad.State.Strict (get, put, runState, State) +import Control.Monad.Writer.Strict (tell, Writer) +import Data.Data (Data) +import Data.Foldable (foldrM) +import Data.Generics.Uniplate.Operations (transformBi, universeBi) +import Data.Graph.Inductive.Graph (lab, pre) +import qualified Data.IntMap as IM +import qualified Data.Map as M +import Data.Maybe (fromJust, fromMaybe, isJust, mapMaybe) +import Data.Monoid ((<>)) +import qualified Data.Set as S + +import qualified Language.Fortran.Analysis as FA +import qualified Language.Fortran.Analysis.DataFlow as FAD +import qualified Language.Fortran.AST as F +import qualified Language.Fortran.Util.Position as FU + +import Camfort.Analysis.Annotations (A, Annotation) +import Camfort.Helpers (collect) +import qualified Camfort.Helpers.Vec as V +import Camfort.Specification.Stencils.Model + (Approximation(..), Multiplicity(..)) +import Camfort.Specification.Stencils.Annotation () +import Camfort.Specification.Stencils.Syntax + ( absoluteRep + , fromBool + , groupKeyBy + , hasDuplicates + , isEmpty + , isUnit + , setLinearity + , Specification(..) + , Variable) + +import Camfort.Specification.Stencils.CheckBackend +import Camfort.Specification.Stencils.InferenceBackend +type EvalLog = [(String, Variable)] + +{-| Representation for indices as either: + * neighbour indices + * constant + * non neighbour index -} +data Neighbour = Neighbour Variable Int + | Constant (F.Value ()) + | NonNeighbour deriving (Eq, Show) + + +{-| 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 e') = + isArraySubscript e <> isArraySubscript e' +isArraySubscript _ = Nothing + +{-| Given an induction-variable-map, convert a list of indices to + Maybe a list of constant or neighbourhood indices. + If any are non neighbourhood then return Nothing -} +neighbourIndex :: FAD.InductionVarMapByASTBlock -> [F.Index (FA.Analysis A)] -> Maybe [Neighbour] +neighbourIndex ivs ixs = + if NonNeighbour `notElem` neighbours + then Just neighbours + else Nothing + where + neighbours = map (\ix -> convIxToNeighbour (extractRelevantIVS ivs ix) ix) ixs + +genSpecifications :: + FAD.FlowsGraph A + -> [Variable] + -> [Neighbour] + -> F.Block (FA.Analysis A) + -> Writer EvalLog ([([Variable], Specification)], [Int]) +genSpecifications flowsGraph ivs lhs block = do + let (subscripts, visitedNodes) = genSubscripts flowsGraph [block] + varToSpecs <- assocsSequence $ mkSpecs subscripts + case varToSpecs of + [] -> do + tell [("EVALMODE: Empty specification (tag: emptySpec)", "")] + return ([], visitedNodes) + _ -> do + let varsToSpecs = groupKeyBy varToSpecs + return (splitUpperAndLower varsToSpecs, visitedNodes) + where + mkSpecs = M.mapWithKey (\v -> indicesToSpec ivs v lhs) + + splitUpperAndLower = concatMap splitUpperAndLower' + splitUpperAndLower' (vs, Specification (Mult (Bound (Just l) (Just u))) isStencil) + | isUnit l = + [(vs, Specification (Mult (Bound Nothing (Just u))) isStencil)] + | otherwise = + [(vs, Specification (Mult (Bound (Just l) Nothing)) isStencil), + (vs, Specification (Mult (Bound Nothing (Just u))) isStencil)] + splitUpperAndLower' (vs, Specification (Once (Bound (Just l) (Just u))) isStencil) + | isUnit l = + [(vs, Specification (Mult (Bound Nothing (Just u))) isStencil)] + | otherwise = + [(vs, Specification (Once (Bound (Just l) Nothing)) isStencil), + (vs, Specification (Once (Bound Nothing (Just u))) isStencil)] + splitUpperAndLower' x = [x] + +{-| genSubscripts + Takes * a flows graph + * 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 -} +genSubscripts :: + FAD.FlowsGraph A + -> [F.Block (FA.Analysis A)] + -> (M.Map Variable [[F.Index (FA.Analysis A)]], [Int]) +genSubscripts flowsGraph blocks = + (subscripts, visitedNodes) + where + (maps, visitedNodes) = runState (mapM (genSubscripts' True flowsGraph) blocks) [] + subscripts = M.unionsWith (++) maps + + -- 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 + genSubscripts' :: + Bool + -> FAD.FlowsGraph A + -> F.Block (FA.Analysis A) + -> State [Int] (M.Map Variable [[F.Index (FA.Analysis A)]]) + + genSubscripts' False _ (F.BlStatement _ _ _ (F.StExpressionAssign _ _ e _)) + | isJust $ isArraySubscript e + -- Don't pull dependencies through arrays + = return M.empty + + genSubscripts' _ flowsGraph block = do + visited <- get + case FA.insLabel $ F.getAnnotation block of + + Just node + | node `elem` visited -> + -- This dependency has already been visited during this traversal + pure M.empty + | otherwise -> do + -- Fresh dependency + put $ node : visited + let blocksFlowingIn = mapMaybe (lab flowsGraph) $ pre flowsGraph node + -- Try to get the block from the flowsGraph before analysis its rhses + let blockG = case (lab flowsGraph node) of + Nothing -> block + Just b -> b + dependencies <- mapM (genSubscripts' False flowsGraph) blocksFlowingIn + return $ M.unionsWith (++) (genRHSsubscripts blockG : dependencies) + + Nothing -> error $ "Missing a label for: " ++ show block + +-- | Given an induction variable map, and a piece of syntax +-- return a list of induction variables in scope for this index +extractRelevantIVS :: (FU.Spanned (ast (FA.Analysis A)), F.Annotated ast) => + FAD.InductionVarMapByASTBlock + -> ast (FA.Analysis A) + -> [Variable] +extractRelevantIVS ivmap f = ivsList + where + ivsList = S.toList $ fromMaybe S.empty $ IM.lookup label ivmap + + label = case (FA.insLabel . F.getAnnotation $ f) of + Just label -> label + Nothing -> error errorMsg + -- For debugging purposes + errorMsg = show (FU.getSpan f) + ++ " get IVs associated to labelled index " + +{-| Given a list of induction variables and an index, compute + its Neighbour representation + e.g., for the expression a(i+1,j-1) then this function gets + passed expr = i + 1 (returning +1) and expr = j - 1 (returning -1) -} +convIxToNeighbour :: [Variable] -> F.Index (FA.Analysis Annotation) -> Neighbour +convIxToNeighbour _ (F.IxRange _ _ Nothing Nothing Nothing) = Neighbour "" 0 +convIxToNeighbour _ (F.IxRange _ _ Nothing Nothing + (Just (F.ExpValue _ _ (F.ValInteger "1")))) = Neighbour "" 0 + +convIxToNeighbour ivs (F.IxSingle _ _ _ exp) = expToNeighbour ivs exp +convIxToNeighbour _ _ = NonNeighbour -- indexing expression is a range + +-- Combinator 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 <- mapM strength . M.toList $ maps + return . mapMaybe strength $ assocs + where + strength :: Monad m => (a, m b) -> m (a, b) + strength (a, mb) = mb >>= (\b -> return (a, b)) + +-- Convert list of indexing expressions to a spec +indicesToSpec :: [Variable] + -> Variable + -> [Neighbour] + -> [[F.Index (FA.Analysis Annotation)]] + -> Writer EvalLog (Maybe Specification) +indicesToSpec ivs a lhs ixs = do + mMultOffsets <- indicesToRelativisedOffsets ivs a lhs ixs + return $ do + (mult, offsets) <- mMultOffsets + spec <- relativeIxsToSpec offsets + let spec' = setLinearity (fromBool mult) spec + return $ setType lhs spec' + +-- Get all RHS subscript which are translated induction variables +-- return as a map from (source name) variables to a list of relative indices +genRHSsubscripts :: + F.Block (FA.Analysis A) + -> M.Map Variable [[F.Index (FA.Analysis A)]] +genRHSsubscripts b = genRHSsubscripts' (transformBi replaceModulo b) + 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 (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 + , Just (F.Argument _ _ _ e':_) <- fmap F.aStrip subs = e' + replaceModulo e = e + + genRHSsubscripts' b = + collect [ (FA.srcName exp, e) + | F.ExpSubscript _ _ exp subs <- FA.rhsExprs b + , isVariableExpr exp + , let e = F.aStrip subs + , not (null e)] + +-- Given a list of induction variables and an expression, compute its +-- Neighbour representation +expToNeighbour :: forall a. Data a + => [Variable] -> F.Expression (FA.Analysis a) -> Neighbour + +expToNeighbour ivs e@(F.ExpValue _ _ v@(F.ValVariable _)) + | FA.varName e `elem` ivs = Neighbour (FA.varName e) 0 + | otherwise = Constant (void v) + +expToNeighbour _ (F.ExpValue _ _ val) = Constant (void val) + +expToNeighbour ivs (F.ExpBinary _ _ F.Addition + e@(F.ExpValue _ _ (F.ValVariable _)) + (F.ExpValue _ _ (F.ValInteger offs))) + | FA.varName e `elem` ivs = Neighbour (FA.varName e) (read offs) + +expToNeighbour ivs (F.ExpBinary _ _ F.Addition + (F.ExpValue _ _ (F.ValInteger offs)) + e@(F.ExpValue _ _ (F.ValVariable _))) + | FA.varName e `elem` ivs = Neighbour (FA.varName e) (read offs) + +expToNeighbour ivs (F.ExpBinary _ _ F.Subtraction + e@(F.ExpValue _ _ (F.ValVariable _)) + (F.ExpValue _ _ (F.ValInteger offs))) + | FA.varName e `elem` ivs = + Neighbour (FA.varName e) (if x < 0 then abs x else (- x)) + where x = read offs + +expToNeighbour ivs e = + -- Record when there is some kind of relative index on an inducion variable + -- but that is not a neighbourhood index by our definitions + if null ivs' then Constant (F.ValInteger "0") else NonNeighbour + where + -- set of all induction variables involved in this expression + ivs' = [i | e@(F.ExpValue _ _ F.ValVariable{}) + <- universeBi e :: [F.Expression (FA.Analysis a)] + , let i = FA.varName e + , i `elem` ivs] + +indicesToRelativisedOffsets :: [Variable] + -> Variable + -> [Neighbour] + -> [[F.Index (FA.Analysis Annotation)]] + -> Writer EvalLog (Maybe (Bool, [[Int]])) +indicesToRelativisedOffsets ivs a lhs ixs = do + -- Convert indices to neighbourhood representation + let rhses = map (map (\ix -> convIxToNeighbour ivs ix) ) ixs + + -- As an optimisation, do duplicate check in front-end first + -- so that duplicate indices don't get passed into the main engine + let (rhses', mult) = hasDuplicates rhses + + -- Check that induction variables are used consistently on lhs and rhses + if not (consistentIVSuse lhs rhses') + then do tell [("EVALMODE: Inconsistent IV use (tag: inconsistentIV)", "")] + return Nothing + else + -- For the EvalMode, if there are any non-neighbourhood relative + -- subscripts detected then add this to the eval log + if hasNonNeighbourhoodRelatives rhses' + then do tell [("EVALMODE: Non-neighbour relative subscripts\ + \ (tag: nonNeighbour)","")] + return Nothing + else do + -- Relativize the offsets based on the lhs + let rhses'' = relativise lhs rhses' + when (rhses' /= rhses'') $ + tell [("EVALMODE: Relativized spec (tag: relativized)", "")] + + let offsets = padZeros $ map (fromJust . mapM neighbourToOffset) rhses'' + tell [("EVALMODE: dimensionality=" ++ + show (if null offsets then 0 else length . head $ offsets), a)] + return (Just (mult, offsets)) + where hasNonNeighbourhoodRelatives = any (elem NonNeighbour) + +-- 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 . V.fromLists $ ixs + +{-| Set the type of Specification (stencil or access) based on the lhs + set of neighbourhood indices; empty implies this is an access + specification -} +setType :: [Neighbour] -> Specification -> Specification +setType [] (Specification spec _) = Specification spec False +setType _ (Specification spec _) = Specification spec True + +-- Given a list of the neighbourhood representation for the LHS, of size n +-- and a list of size-n lists of offsets, relativise the offsets +relativise :: [Neighbour] -> [[Neighbour]] -> [[Neighbour]] +relativise lhs rhses = foldr relativiseRHS rhses lhs + where + relativiseRHS (Neighbour lhsIV i) rhses = + map (map (relativiseBy lhsIV i)) rhses + relativiseRHS _ rhses = rhses + + relativiseBy v i (Neighbour u j) | v == u = Neighbour u (j - i) + relativiseBy _ _ x = x + +-- Helper predicates +isVariableExpr :: F.Expression a -> Bool +isVariableExpr (F.ExpValue _ _ (F.ValVariable _)) = True +isVariableExpr _ = False + +-- Check that induction variables are used consistently +consistentIVSuse :: [Neighbour] -> [[Neighbour]] -> Bool +consistentIVSuse [] _ = True +consistentIVSuse _ [] = True +consistentIVSuse lhs rhses = + isJust rhsBasis -- 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 + -- Cases for constants or non neighbour indices + cmp n@Neighbour{} (Constant _) = Just n + cmp (Constant _) n@Neighbour{} = Just n + cmp NonNeighbour{} Neighbour{} = Nothing + cmp Neighbour{} NonNeighbour{} = Nothing + cmp _ _ = Just $ Constant (F.ValInteger "") + rhsBasis = foldrM (zipWithM cmp) (head rhses) (tail rhses) + -- If there is an induction variable on the RHS, then it also occurs on + -- the LHS + 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 == "" = True + matchesIV _ (Neighbour v' _) | v' == "" = True + matchesIV _ _ = False + +-- padZeros makes this rectilinear +padZeros :: [[Int]] -> [[Int]] +padZeros ixss = let m = maximum (map length ixss) + in map (\ixs -> ixs ++ replicate (m - length ixs) 0) ixss + +neighbourToOffset :: Neighbour -> Maybe Int +neighbourToOffset (Neighbour _ o) = Just o +neighbourToOffset (Constant _) = Just absoluteRep +neighbourToOffset _ = Nothing diff --git a/src/Camfort/Specification/Stencils/Grammar.y b/src/Camfort/Specification/Stencils/Grammar.y deleted file mode 100644 --- a/src/Camfort/Specification/Stencils/Grammar.y +++ /dev/null @@ -1,252 +0,0 @@ -{ -- -*- 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) - -} - -%monad { Either AnnotationParseError } { >>= } { return } -%name parseSpec SPEC -%tokentype { Token } -%token - stencil { TId "stencil" } - region { TId "region" } - readOnce { TId "readonce" } - pointed { TId "pointed" } - nonpointed { TId "nonpointed" } - atMost { TId "atmost" } - atLeast { TId "atleast" } - dim { TId "dim" } - depth { TId "depth" } - forward { TId "forward" } - backward { TId "backward" } - centered { TId "centered" } - id { TId $$ } - num { TNum $$ } - '+' { TPlus } - '*' { TStar } - '::' { TDoubleColon } - '=' { TEqual } - '(' { TLParen } - ')' { TRParen } - -%left '+' -%left '*' - -%% - -SPEC :: { Specification } -: REGIONDEC { RegionDec (fst $1) (snd $1) } -| stencil SPECDEC '::' VARS { SpecDec $2 $4 } - -REGIONDEC :: { (String, Region) } -: region '::' id '=' REGION { ($3, $5) } - -REGION :: { Region } -: forward '(' REGION_ATTRS ')' { applyAttr Forward $3 } -| backward '(' REGION_ATTRS ')' { applyAttr Backward $3 } -| centered '(' REGION_ATTRS ')' { applyAttr Centered $3 } -| pointed '(' dim '=' num ')' { Centered 0 (read $5) True } -| REGION '+' REGION { Or $1 $3 } -| REGION '*' REGION { And $1 $3 } -| '(' REGION ')' { $2 } -| id { Var $1 } - -REGION_ATTRS :: { (Depth Int, Dim Int, Bool) } - : DEPTH DIM_REFL { ($1, fst $2, snd $2) } - | DIM DEPTH_REFL { (fst $2, $1, snd $2) } - | REFL DEPTH DIM { ($2, $3, $1) } - | REFL DIM DEPTH { ($3, $2, $1) } - -DIM_REFL :: { (Dim Int, Bool) } -DIM_REFL - : REFL DIM { ($2, $1) } - | DIM REFL { ($1, $2) } - | DIM { ($1, True) } - -DEPTH_REFL :: { (Depth Int, Bool) } -DEPTH_REFL - : DEPTH REFL { ($1, $2) } - | REFL DEPTH { ($2, $1) } - | DEPTH { ($1, True) } - -DEPTH :: { Depth Int } -DEPTH : depth '=' num { Depth $ read $3 } - -DIM :: { Dim Int } -DIM : dim '=' num { Dim $ read $3 } - -REFL :: { Bool } - : nonpointed { False } - -SPECDEC :: { Spec } -: APPROXMODS MOD REGION { Spatial ($1 ++ [$2]) $3 } -| MOD REGION { Spatial [$1] $2 } -| APPROXMOD REGION { Spatial [$1] $2 } -| REGION { Spatial [] $1 } - -MOD :: { Mod } -: readOnce { ReadOnce } - --- Even though multiple approx mods is not allowed --- allow them to be parsed so that the validator can --- report a nice error if the user supplies more than one -APPROXMODS :: { [Mod] } -: APPROXMOD APPROXMODS { $1 : $2 } -| APPROXMOD { [$1] } - -APPROXMOD :: { Mod } -: atMost { AtMost } -| atLeast { AtLeast } - -VARS :: { [String] } -: id VARS { $1 : $2 } -| id { [$1] } - -{ -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 - -} 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 @@ -18,7 +18,14 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} -module Camfort.Specification.Stencils.InferenceBackend where +module Camfort.Specification.Stencils.InferenceBackend + ( coalesce + , containedWithin + , inferFromIndicesWithoutLinearity + , inferMinimalVectorRegions + , spansToApproxSpatial + , Span + ) where import Data.List import Data.Maybe @@ -26,7 +33,6 @@ import Camfort.Specification.Stencils.Model import Camfort.Specification.Stencils.DenotationalSemantics -import Camfort.Helpers import qualified Camfort.Helpers.Vec as V import Camfort.Specification.Stencils.Syntax @@ -76,21 +82,14 @@ where (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 - --- 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. +{-| From a list of vectors of integers, representing relative offsets, + generate a specification (but does not do any linearity checking) + (defaults to Mult). Instead let the front-end does + the linearity check first as an optimimsation. + Also defaults to the specification being for a stencil -} inferFromIndicesWithoutLinearity :: V.VecList Int -> Specification inferFromIndicesWithoutLinearity (V.VL ixs) = - Specification . Mult . inferCore $ ixs + Specification (Mult . inferCore $ ixs) True inferCore :: [V.Vec n Int] -> Approximation Spatial inferCore subs = @@ -128,6 +127,7 @@ sequenceMaybes xs | all (== Nothing) xs = Nothing | otherwise = Just (catMaybes xs) +{-| Coalesce two intervals of vectors into one, if they are contiguous -} 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 @@ -142,7 +142,9 @@ = 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 +-- Fall through (also catches cases where the initial size pre-condition +-- has been violated in a use of `Helpers.Vec.fromLists` +coalesce _ _ = Nothing {-| Collapses the regions into a small set by looking for potential overlaps @@ -164,6 +166,8 @@ = True 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) +containedWithin _ _ + = False -- 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 @@ -14,27 +14,35 @@ limitations under the License. -} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ConstraintKinds #-} -module Camfort.Specification.Stencils.InferenceFrontend where +module Camfort.Specification.Stencils.InferenceFrontend + ( + -- * Datatypes and Aliases + InferMode(..) + -- * Functions + , stencilInference + ) where import Control.Monad.State.Strict import Control.Monad.Reader import Control.Monad.Writer.Strict hiding (Product) import Camfort.Analysis.CommentAnnotator - +import Camfort.Specification.Stencils.CheckBackend (synToAst) +import Camfort.Specification.Stencils.CheckFrontend + (CheckResult, existingStencils, stencilChecking) +import Camfort.Specification.Stencils.Generate import Camfort.Specification.Stencils.InferenceBackend import Camfort.Specification.Stencils.Model import Camfort.Specification.Stencils.Syntax -import Camfort.Specification.Stencils.Annotation () -import qualified Camfort.Specification.Stencils.Grammar as Gram +import qualified Camfort.Specification.Stencils.Parser as Parser +import Camfort.Specification.Stencils.Parser.Types (SpecInner) import qualified Camfort.Specification.Stencils.Synthesis as Synth import Camfort.Analysis.Annotations import Camfort.Helpers (collect, descendReverseM, descendBiReverseM) @@ -43,7 +51,6 @@ import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA -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 @@ -53,14 +60,13 @@ import Data.Generics.Uniplate.Operations import Data.Graph.Inductive.Graph hiding (isEmpty) import qualified Data.Map as M -import qualified Data.IntMap as IM import qualified Data.Set as S import Data.Maybe -import Debug.Trace +import Data.Monoid ((<>)) -- Define modes of interaction with the inference data InferMode = - DoMode | AssignMode | CombinedMode | EvalMode | Synth + AssignMode | EvalMode | Synth deriving (Eq, Show, Data, Read) instance Default InferMode where @@ -68,35 +74,61 @@ data InferState = IS { ivMap :: FAD.InductionVarMapByASTBlock - , hasSpec :: [(FU.SrcSpan, Variable)] , visitedNodes :: [Int]} +data InferEnv = IE + { + -- | Known (existing) specifications. + ieExistingSpecs :: [(Specification, FU.SrcSpan, Variable)] + , ieFlowsGraph :: FAD.FlowsGraph A + , ieInferMode :: InferMode + , ieMarker :: Char + , ieMetaInfo :: F.MetaInfo + } + -- The inferer returns information as a LogLine -type EvalLog = [(String, Variable)] type LogLine = (FU.SrcSpan, Either [([Variable], Specification)] (String,Variable)) -- The core of the inferer works within this monad type Inferer = WriterT [LogLine] - (ReaderT (FAD.FlowsGraph A) + (ReaderT InferEnv (State InferState)) -type Params = (?flowsGraph :: FAD.FlowsGraph A, ?nameMap :: FAR.NameMap) - -runInferer :: FAD.InductionVarMapByASTBlock +runInferer :: CheckResult + -> InferMode + -> Char + -> F.MetaInfo + -> FAD.InductionVarMapByASTBlock -> FAD.FlowsGraph A -> Inferer a -> (a, [LogLine]) -runInferer ivmap flTo = - flip evalState (IS ivmap [] []) - . flip runReaderT flTo +runInferer cr mode marker mi ivmap flTo = + flip evalState (IS ivmap []) + . flip runReaderT env . runWriterT + where env = IE + { ieExistingSpecs = existingStencils cr + , ieFlowsGraph = flTo + , ieInferMode = mode + , ieMarker = marker + , ieMetaInfo = mi + } -stencilInference :: FAR.NameMap - -> InferMode +-- | Attempt to convert a 'Parser.Specification' into a 'Specification'. +-- +-- Only performs conversions for spatial specifications. +specToSynSpec :: SpecInner -> Maybe Specification +specToSynSpec spec = let ?renv = [] in + case synToAst spec of + Left err -> Nothing + Right x -> Just x + +-- | Main stencil inference code +stencilInference :: InferMode -> Char -> F.ProgramFile (FA.Analysis A) -> (F.ProgramFile (FA.Analysis A), [LogLine]) -stencilInference nameMap mode marker pf = +stencilInference mode marker pf = (F.ProgramFile mi pus', log1) where -- Parse specification annotations and include them into the syntax tree @@ -104,550 +136,158 @@ -- decide whether to synthesise or not -- TODO: might want to output log0 somehow (though it doesn't fit LogLine) - (pf'@(F.ProgramFile mi pus), log0) = + (pf'@(F.ProgramFile mi pus), _log0) = if mode == Synth - then runWriter (annotateComments Gram.specParser pf) + then runWriter (annotateComments Parser.specParser (const . const . pure $ ()) pf) else (pf, []) (pus', log1) = runWriter (transformBiM perPU pus) + checkRes = stencilChecking pf - -- Run inference per program unit, placing the flowsmap in scope + -- Run inference per program unit perPU :: F.ProgramUnit (FA.Analysis A) -> Writer [LogLine] (F.ProgramUnit (FA.Analysis A)) - perPU pu | Just _ <- FA.bBlocks $ F.getAnnotation pu = - let ?flowsGraph = flTo - ?nameMap = nameMap - in do - let pum = descendBiM (perBlockInfer mode marker) pu - let (pu', log) = runInferer ivMap flTo pum - tell log - return pu' - perPU pu = return pu + perPU pu | Just _ <- FA.bBlocks $ F.getAnnotation pu = do + let -- Analysis/infer on blocks of just this program unit + blocksM = mapM perBlockInfer (F.programUnitBody pu) + -- Update the program unit body with these blocks + pum = (F.updateProgramUnitBody pu) <$> blocksM - -- induction variable map - ivMap = FAD.genInductionVarMapByASTBlock beMap gr - -- perform reaching definitions analysis - rd = FAD.reachingDefinitions dm gr - -- create graph of definition "flows" - flTo = FAD.genFlowsToGraph bm dm gr rd + -- perform reaching definitions analysis + rd = FAD.reachingDefinitions dm gr - -- identify every loop by its back-edge - beMap = FAD.genBackEdgeMap (FAD.dominators gr) gr + Just gr = M.lookup (FA.puName pu) bbm + -- create graph of definition "flows" + flTo = FAD.genFlowsToGraph bm dm gr rd + -- induction variable map + beMap = FAD.genBackEdgeMap (FAD.dominators gr) gr + + -- identify every loop by its back-edge + ivMap = FAD.genInductionVarMapByASTBlock beMap gr + + (pu', log) = runInferer checkRes mode marker mi ivMap flTo pum + tell log + return pu' + + perPU pu = return pu + -- get map of AST-Block-ID ==> corresponding AST-Block bm = FAD.genBlockMap 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 - -- get map of variable name ==> { defining AST-Block-IDs } dm = FAD.genDefMap bm {- *** 1 . Core inference over blocks -} -genSpecsAndReport :: Params - => InferMode -> FU.SrcSpan -> [Neighbour] - -> [F.Block (FA.Analysis A)] +genSpecsAndReport :: + FU.SrcSpan -> [Neighbour] + -> F.Block (FA.Analysis A) -> Inferer [([Variable], Specification)] -genSpecsAndReport mode span lhs blocks = do - (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 - tell [ (span, Right ("EVALMODE: assign to relative array subscript\ - \ (tag: tickAssign)","")) ] - mapM_ (\evalInfo -> tell [ (span, Right evalInfo) ]) evalInfos - mapM_ (\spec -> if show spec == "" - then tell [ (span, Right ("EVALMODE: Cannot make spec\ - \ (tag: emptySpec)","")) ] - else return ()) specs - return specs - else return specs - +genSpecsAndReport span lhsIxs block = do + -- Get the induction variables relative to the current block + (IS ivmap _) <- get + let ivs = extractRelevantIVS ivmap block --- 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 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 + mode <- fmap ieInferMode ask + flowsGraph <- fmap ieFlowsGraph ask + -- Generate specification for the + let ((specs, visited), evalInfos) = runWriter $ genSpecifications flowsGraph ivs lhsIxs block + -- Remember which nodes were visited during this traversal + modify (\state -> state { visitedNodes = visitedNodes state ++ visited }) + -- Report the specifications + tell [ (span, Left specs) ] -fromJustMsg _ (Just x) = x -fromJustMsg msg Nothing = error msg + -- Evaluation mode information reporting: + when (mode == EvalMode) $ do + tell [ (span, Right ("EVALMODE: assign to relative array subscript\ + \ (tag: tickAssign)","")) ] + forM_ evalInfos $ \evalInfo -> + tell [ (span, Right evalInfo) ] + forM_ specs $ \spec -> + when (show spec == "") $ + tell [ (span, Right ("EVALMODE: Cannot make spec\ + \ (tag: emptySpec)","")) ] + return specs -- Traverse Blocks in the AST and infer stencil specifications -perBlockInfer :: Params - => InferMode -> Char -> F.Block (FA.Analysis A) - -> Inferer (F.Block (FA.Analysis A)) - -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 - ann' <- return $ FA.prevAnnotation ann - -- Check if we have a spec - case (stencilSpec ann', stencilBlock ann') of - -- Comment contains an (uncoverted) specification and an associated block - (Just (Left (Gram.SpecDec _ vars)), Just block) -> - -- Is the block an assignment - case block of - 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 _) _ stmnt) - | mode == AssignMode || mode == CombinedMode || mode == EvalMode || mode == Synth = do - - (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)]] - 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 - noSpecAlready (vars, spec) = - if null vars' - then Nothing - else Just (vars', spec) - where vars' = filter (\v -> not ((span, realName v) `elem` hasSpec)) vars - realName v = v `fromMaybe` (v `M.lookup` ?nameMap) - tabs = take (FU.posColumn lp - 1) (repeat ' ') - (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' (F.Comment specComment) - else return b - -perBlockInfer mode marker b@(F.BlDo ann span lab cname lab' mDoSpec body tlab) = do - if (mode == DoMode || mode == CombinedMode) && isStencilDo b - then genSpecsAndReport mode span [] body - else return [] - - -- 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' <- 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)], [Int]) -genSpecifications ivs lhs blocks = do - let (subscripts, visitedNodes) = subscriptsOnRhs ?nameMap blocks - varToSpecs <- assocsSequence $ mkSpecs subscripts - case varToSpecs of - [] -> do - tell [("EVALMODE: Empty specification (tag: emptySpec)", "")] - return ([], visitedNodes) - _ -> do - let varsToSpecs = groupKeyBy varToSpecs - return (splitUpperAndLower varsToSpecs, visitedNodes) - where - mkSpecs = M.mapWithKey (\v -> indicesToSpec ivs v lhs) - - splitUpperAndLower = concatMap splitUpperAndLower' - 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, _) = subscriptsOnRhs ?nameMap blocks - assocsSequence $ mkOffsets subscripts - where - mkOffsets = M.mapWithKey (\v -> indicesToRelativisedOffsets ivs v lhs) - - --- 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 -genSubscripts :: Params - => Bool - -> F.Block (FA.Analysis A) - -> State [Int] (M.Map Variable [[F.Index (FA.Analysis A)]]) -genSubscripts False (F.BlStatement _ _ _ (F.StExpressionAssign _ _ e _)) - | isArraySubscript e /= Nothing - -- Don't pull dependencies through arrays - = return M.empty - -genSubscripts _ block = do - visited <- get - case (FA.insLabel $ F.getAnnotation block) of - - Just node - | node `elem` visited -> - -- This dependency has already been visited during this traversal - return $ M.empty - | otherwise -> do - -- Fresh dependency - put $ node : visited - let blocksFlowingIn = mapMaybe (lab ?flowsGraph) $ pre ?flowsGraph node - dependencies <- mapM (genSubscripts False) blocksFlowingIn - return $ M.unionsWith (++) (genRHSsubscripts block : dependencies) - - Nothing -> error $ "Missing a label for: " ++ show block - --- Get all RHS subscript which are translated induction variables --- return as a map from (program) variables to a list of relative indices and --- a flag marking whether there are any duplicate indices -genRHSsubscripts :: - F.Block (FA.Analysis A) - -> M.Map Variable [[F.Index (FA.Analysis A)]] -genRHSsubscripts b = genRHSsubscripts' (transformBi replaceModulo b) - 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.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 - , Just (F.Argument _ _ _ e':_) <- fmap F.aStrip subs = e' - replaceModulo e = e - - genRHSsubscripts' b = - collect [ (FA.varName exp, e) - | F.ExpSubscript _ _ exp subs <- FA.rhsExprs b - , isVariableExpr exp - , let e = F.aStrip subs - , not (null e)] - -getInductionVar :: Maybe (F.DoSpecification (FA.Analysis A)) -> [Variable] -getInductionVar (Just (F.DoSpecification _ _ (F.StExpressionAssign _ _ e _) _ _)) - | isVariableExpr e = [FA.varName e] -getInductionVar _ = [] - -isStencilDo :: F.Block (FA.Analysis A) -> Bool -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 - [] -> False - [ivar] -> length exprs > 0 && - and [ all (\sub -> sub `isNeighbour` [ivar]) subs' | - F.ExpSubscript _ _ _ subs <- exprs - , let subs' = F.aStrip subs - , not (null subs') ] - where exprs = universeBi upToNextDo :: [F.Expression (FA.Analysis A)] - upToNextDo = takeWhile (not . isDo) body - isDo (F.BlDo {}) = True - isDo _ = False -isStencilDo _ = False - -{- *** 2 .Conversion from indexing expressions -} - --- padZeros makes this rectilinear -padZeros :: [[Int]] -> [[Int]] -padZeros ixss = let m = maximum (map length ixss) - in map (\ixs -> ixs ++ replicate (m - length ixs) 0) ixss - --- Convert list of indexing expressions to a spec -indicesToSpec :: FAD.InductionVarMapByASTBlock - -> Variable - -> [Neighbour] - -> [[F.Index (FA.Analysis Annotation)]] - -> Writer EvalLog (Maybe Specification) -indicesToSpec ivs a lhs ixs = do - mMultOffsets <- indicesToRelativisedOffsets ivs a lhs ixs - return $ do - (mult, offsets) <- mMultOffsets - let spec = relativeIxsToSpec offsets - fmap (setLinearity (fromBool mult)) spec - -indicesToRelativisedOffsets :: FAD.InductionVarMapByASTBlock - -> Variable - -> [Neighbour] - -> [[F.Index (FA.Analysis Annotation)]] - -> Writer EvalLog (Maybe (Bool, [[Int]])) -indicesToRelativisedOffsets ivs a lhs ixs = do - -- Convert indices to neighbourhood representation - let rhses = map (map (ixToNeighbour ivs)) ixs - - -- As an optimisation, do duplicate check in front-end first - -- so that duplicate indices don't get passed into the main engine - let (rhses', mult) = hasDuplicates rhses - - -- Check that induction variables are used consistently on lhs and rhses - if not (consistentIVSuse lhs rhses') - then do tell [("EVALMODE: Inconsistent IV use (tag: inconsistentIV)", "")] - return Nothing - else - -- For the EvalMode, if there are any non-neighbourhood relative - -- subscripts detected then add this to the eval log - if hasNonNeighbourhoodRelatives rhses' - then do tell [("EVALMODE: Non-neighbour relative subscripts\ - \ (tag: nonNeighbour)","")] - return Nothing - else do - -- Relativize the offsets based on the lhs - let rhses'' = relativise lhs rhses' - if rhses' /= rhses'' - then tell [("EVALMODE: Relativized spec (tag: relativized)", "")] - else return () - - let offsets = padZeros $ map (fromJust . mapM neighbourToOffset) rhses'' - tell [("EVALMODE: dimensionality=" ++ - show (if null offsets then 0 else length . head $ offsets), a)] - return (Just $ (mult, offsets)) - where hasNonNeighbourhoodRelatives xs = or (map (any ((==) NonNeighbour)) xs) - - --- Given a list of the neighbourhood representation for the LHS, of size n --- and a list of size-n lists of offsets, relativise the offsets -relativise :: [Neighbour] -> [[Neighbour]] -> [[Neighbour]] -relativise lhs rhses = foldr relativiseRHS rhses lhs - where - relativiseRHS (Neighbour lhsIV i) rhses = - map (map (relativiseBy lhsIV i)) rhses - relativiseRHS _ rhses = rhses - - relativiseBy v i (Neighbour u j) | v == u = Neighbour u (j - i) - relativiseBy _ _ x = x - --- Check that induction variables are used consistently -consistentIVSuse :: [Neighbour] -> [[Neighbour]] -> Bool -consistentIVSuse [] _ = True -consistentIVSuse _ [] = True -consistentIVSuse lhs rhses = - 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 - -- Cases for constants or non neighbour indices - cmp n@(Neighbour {}) (Constant _) = Just n - cmp (Constant _) n@(Neighbour {}) = Just n - cmp (NonNeighbour {}) (Neighbour {}) = Nothing - cmp (Neighbour {}) (NonNeighbour{}) = Nothing - cmp _ _ = Just $ Constant (F.ValInteger "") - 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 - 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 == "" = 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 . V.fromLists $ ixs - -isNeighbour :: Data a => F.Index (FA.Analysis a) -> [Variable] -> Bool -isNeighbour exp vs = - case (ixToNeighbour' vs exp) of - Neighbour _ _ -> True - _ -> False - --- Given a list of induction variables and a list of indices --- map them to a list of constant or neighbourhood indices --- if any are non neighbourhood then return Nothi ng -neighbourIndex :: FAD.InductionVarMapByASTBlock - -> [F.Index (FA.Analysis Annotation)] -> Maybe [Neighbour] -neighbourIndex ivs ixs = - if all ((/=) NonNeighbour) neighbours - then Just neighbours - else Nothing - where neighbours = map (ixToNeighbour ivs) ixs +perBlockInfer :: F.Block (FA.Analysis A) + -> Inferer (F.Block (FA.Analysis A)) +perBlockInfer = perBlockInfer' False +-- The primed version, perBlockInfer' has a flag indicating whether +-- the following code is inside a do-loop since we only target +-- array computations inside loops. --- Representation for indices as either: --- * neighbour indices --- * constant --- * non neighbour index -data Neighbour = Neighbour Variable Int - | Constant (F.Value ()) - | NonNeighbour deriving (Eq, Show) +perBlockInfer' _ b@F.BlComment{} = pure b -neighbourToOffset :: Neighbour -> Maybe Int -neighbourToOffset (Neighbour _ o) = Just o -neighbourToOffset (Constant _) = Just absoluteRep -neighbourToOffset _ = Nothing +perBlockInfer' inDo b@(F.BlStatement ann span@(FU.SrcSpan lp _) _ stmnt) = do + (IS ivmap visitedStmts) <- get + mode <- fmap ieInferMode ask + 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.... + userSpecs <- fmap ieExistingSpecs ask + let lhses = [lhs | (F.StExpressionAssign _ _ lhs _) + <- universe stmnt :: [F.Statement (FA.Analysis A)]] + specs <- mapM (genSpecsFor ivmap mode) lhses + marker <- fmap ieMarker ask + mi <- fmap ieMetaInfo ask + if mode == Synth && not (null specs) && specs /= [[]] + then + let specComment = Synth.formatSpec mi tabs marker (span, Left specs') + specs' = concatMap (mapMaybe noSpecAlready) specs --- Given a list of induction variables and an index, compute --- its Neighbour representation --- e.g., for the expression a(i+1,j-1) then this function gets --- passed expr = i + 1 (returning +1) and expr = j - 1 (returning -1) + noSpecAlready (vars, spec) = + if null vars' + then Nothing + else Just (vars', spec) + where vars' = filter (\v -> (spec, span, v) `notElem` userSpecs) vars -ixToNeighbour :: FAD.InductionVarMapByASTBlock - -> F.Index (FA.Analysis Annotation) -> Neighbour --- Range with stride = 1 and no explicit bounds count as reflexive indexing -ixToNeighbour ivmap f = ixToNeighbour' ivsList f + -- Indentation for the specification to match the code + tabs = FU.posColumn lp - 1 + (FU.SrcSpan loc _) = span + span' = FU.SrcSpan (lp {FU.posColumn = 1}) (lp {FU.posColumn = 1}) + ann' = ann { FA.prevAnnotation = (FA.prevAnnotation ann) { refactored = Just loc } } + in pure (F.BlComment ann' span' (F.Comment specComment)) + else return b where - insl = FA.insLabel . F.getAnnotation $ f - errorMsg = show (ixsspan f) - ++ " get IVs associated to labelled index " - ++ show insl - insl' = fromJustMsg errorMsg insl - ivsList = S.toList $ fromMaybe S.empty $ IM.lookup insl' ivmap - -- For debugging purposes - ixsspan :: F.Index (FA.Analysis A) -> FU.SrcSpan - ixsspan (F.IxRange _ sp _ _ _) = sp - ixsspan (F.IxSingle _ sp _ _ ) = sp - -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 -ixToNeighbour' _ _ = NonNeighbour -- indexing expression is a range - --- Given a list of induction variables and an expression, compute its --- Neighbour representation -expToNeighbour :: forall a. Data a - => [Variable] -> F.Expression (FA.Analysis a) -> Neighbour - -expToNeighbour ivs e@(F.ExpValue _ _ v@(F.ValVariable _)) - | FA.varName e `elem` ivs = Neighbour (FA.varName e) 0 - | otherwise = Constant (fmap (const ()) v) - -expToNeighbour _ (F.ExpValue _ _ val) = Constant (fmap (const ()) val) - -expToNeighbour ivs (F.ExpBinary _ _ F.Addition - e@(F.ExpValue _ _ (F.ValVariable _)) - (F.ExpValue _ _ (F.ValInteger offs))) - | FA.varName e `elem` ivs = Neighbour (FA.varName e) (read offs) - -expToNeighbour ivs (F.ExpBinary _ _ F.Addition - (F.ExpValue _ _ (F.ValInteger offs)) - e@(F.ExpValue _ _ (F.ValVariable _))) - | FA.varName e `elem` ivs = Neighbour (FA.varName e) (read offs) + -- Assignment to a variable + genSpecsFor _ _ (F.ExpValue _ _ (F.ValVariable _)) | inDo = genSpecsAndReport span [] b + -- Assignment to something else... + genSpecsFor ivmap mode lhs = + 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 span lhs b + Nothing -> if mode == EvalMode + then do + tell [(span , Right ("EVALMODE: LHS is an array\ + \ subscript we can't handle \ + \(tag: LHSnotHandled)",""))] + pure [] + else pure [] + -- Not an assign we are interested in + _ -> pure [] -expToNeighbour ivs (F.ExpBinary _ _ F.Subtraction - e@(F.ExpValue _ _ (F.ValVariable _)) - (F.ExpValue _ _ (F.ValInteger offs))) - | FA.varName e `elem` ivs = - Neighbour (FA.varName e) (if x < 0 then abs x else (- x)) - where x = read offs +perBlockInfer' _ b@(F.BlDo ann span lab cname lab' mDoSpec body tlab) = do + -- descend into the body of the do-statement (in reverse order) + body' <- mapM (descendBiReverseM (perBlockInfer' True)) (reverse body) + return $ F.BlDo ann span lab cname lab' mDoSpec (reverse body') tlab -expToNeighbour ivs e = - -- Record when there is some kind of relative index on an inducion variable - -- but that is not a neighbourhood index by our definitions - if null ivs' then Constant (F.ValInteger "0") else NonNeighbour - where - -- set of all induction variables involved in this expression - ivs' = [i | e@(F.ExpValue _ _ (F.ValVariable {})) - <- universeBi e :: [F.Expression (FA.Analysis a)] - , let i = FA.varName e - , i `elem` ivs] +perBlockInfer' inDo b = + -- Go inside child blocks + descendReverseM (descendBiReverseM (perBlockInfer' inDo)) b -------------------------------------------------- --- Helper predicates -isUnaryOrBinaryExpr :: F.Expression a -> Bool -isUnaryOrBinaryExpr (F.ExpUnary {}) = True -isUnaryOrBinaryExpr (F.ExpBinary {}) = True -isUnaryOrBinaryExpr _ = False - -isVariableExpr :: F.Expression a -> Bool -isVariableExpr (F.ExpValue _ _ (F.ValVariable _)) = True -isVariableExpr _ = False - +-- Cute <3 -- Penelope's first code, 20/03/2016. -- iii././//////////////////////. mvnmmmmmmmmmu 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 @@ -65,7 +65,6 @@ import qualified Camfort.Helpers.Vec as V import System.IO.Unsafe -import Debug.Trace -- Utility container class Container a where @@ -279,11 +278,11 @@ Nothing -> fail "Impossible: Counter example size doesn't \ \match the original vector size." - else "EQ branch" `trace` return EQ + else return EQ where counterExample :: ThmResult -> IO [ Int64 ] counterExample thmRes = - case getModel thmRes of + case getModelAssignment thmRes of Right (False, ce) -> return ce Right (True, _) -> fail "Returned probable model." Left str -> fail str diff --git a/src/Camfort/Specification/Stencils/Parser.y b/src/Camfort/Specification/Stencils/Parser.y new file mode 100644 --- /dev/null +++ b/src/Camfort/Specification/Stencils/Parser.y @@ -0,0 +1,222 @@ +{ + +module Camfort.Specification.Stencils.Parser + ( specParser + , SpecParseError + ) where + +import Control.Monad.Except (throwError) +import Data.Char (isLetter, isNumber, isAlphaNum, toLower, isAlpha, isSpace) +import Data.List (intercalate, isInfixOf) + +import Camfort.Specification.Parser + (SpecParser, mkParser) +import Camfort.Specification.Stencils.Model + (Approximation(..), Multiplicity(..)) +import Camfort.Specification.Stencils.Parser.Types +import qualified Camfort.Specification.Stencils.Syntax as Syn + +} + +%monad { StencilSpecParser } { >>= } { return } +%name parseSpecification SPEC +%tokentype { Token } +%token + stencil { TId _ "stencil" } + access { TId _ "access" } + region { TId _ "region" } + readOnce { TId _ "readonce" } + pointed { TId _ "pointed" } + nonpointed { TId _ "nonpointed" } + atMost { TId _ "atmost" } + atLeast { TId _ "atleast" } + dim { TId _ "dim" } + depth { TId _ "depth" } + forward { TId _ "forward" } + backward { TId _ "backward" } + centered { TId _ "centered" } + id { TId _ $$ } + num { TNum $$ } + '+' { TPlus } + '*' { TStar } + '::' { TDoubleColon } + '=' { TEqual } + '(' { TLParen } + ')' { TRParen } + +%left '+' +%left '*' + +%% + +SPEC :: { Specification } +: REGIONDEC { RegionDec (fst $1) (snd $1) } +| stencil SPECDEC '::' VARS { SpecDec ($2 True) $4 } +| access SPECDEC '::' VARS { SpecDec ($2 False) $4 } + +REGIONDEC :: { (String, Region) } +: region '::' id '=' REGION { ($3, $5) } + +REGION :: { Region } +: REGIONCONST { RegionConst $1 } +| REGION '+' REGION { Or $1 $3 } +| REGION '*' REGION { And $1 $3 } +| '(' REGION ')' { $2 } +| id { Var $1 } + +REGIONCONST :: { Syn.Region } +: forward '(' REGION_ATTRS ')' { applyAttr Syn.Forward $3 } +| backward '(' REGION_ATTRS ')' { applyAttr Syn.Backward $3 } +| centered '(' REGION_ATTRS ')' { applyAttr Syn.Centered $3 } +| pointed '(' dim '=' num ')' { Syn.Centered 0 (read $5) True } + +REGION_ATTRS :: { (Depth Int, Dim Int, Bool) } + : DEPTH DIM_REFL { ($1, fst $2, snd $2) } + | DIM DEPTH_REFL { (fst $2, $1, snd $2) } + | REFL DEPTH DIM { ($2, $3, $1) } + | REFL DIM DEPTH { ($3, $2, $1) } + +DIM_REFL :: { (Dim Int, Bool) } +DIM_REFL + : REFL DIM { ($2, $1) } + | DIM REFL { ($1, $2) } + | DIM { ($1, True) } + +DEPTH_REFL :: { (Depth Int, Bool) } +DEPTH_REFL + : DEPTH REFL { ($1, $2) } + | REFL DEPTH { ($2, $1) } + | DEPTH { ($1, True) } + +DEPTH :: { Depth Int } +DEPTH : depth '=' num { Depth $ read $3 } + +DIM :: { Dim Int } +DIM : dim '=' num { Dim $ read $3 } + +REFL :: { Bool } + : nonpointed { False } + +SPECDEC :: { Syn.IsStencil -> SpecInner } +: MULTIPLICITY { SpecInner $1 } + +MULTIPLICITY :: { Multiplicity (Approximation Region) } +: readOnce APPROXIMATION { Once $2 } +| APPROXIMATION { Mult $1 } + +APPROXIMATION :: { Approximation Region } +: atLeast REGION { Bound (Just $2) Nothing } +| atMost REGION { Bound Nothing (Just $2) } +| REGION { Exact $1 } + +VARS :: { [String] } +: id VARS { $1 : $2 } +| id { [$1] } + +{ + +-- ** Errors + +data SpecParseError + -- | Not a valid identifier character. + = NotAnIdentifier Char + -- | Tokens do not represent a syntactically valid specification. + | CouldNotParseSpecification [Token] + deriving (Eq) + +instance Show SpecParseError where + show (CouldNotParseSpecification ts) = + "Could not parse specification at: \"" ++ prettyTokens ts ++ "\"\n" + show (NotAnIdentifier c) = "Invalid character in identifier: " ++ show c + +notAnIdentifier :: Char -> SpecParseError +notAnIdentifier = NotAnIdentifier + +couldNotParseSpecification :: [Token] -> SpecParseError +couldNotParseSpecification = CouldNotParseSpecification + +type StencilSpecParser a = Either SpecParseError a + +newtype Depth a = Depth a +newtype Dim a = Dim a + +applyAttr :: (Int -> Int -> Bool -> Syn.Region) + -> (Depth Int, Dim Int, Bool) + -> Syn.Region +applyAttr constr (Depth d, Dim dim, irrefl) = constr d dim irrefl + +data Token + = TDoubleColon + | TStar + | TPlus + | TEqual + | TComma + | TLParen + | TRParen + | TId String String -- first string contains the original text + -- second is normalised (e.g., for keywords) + | TNum String + deriving (Show, Eq) + +addToTokens :: Token -> String -> StencilSpecParser [ Token ] +addToTokens tok rest = do + tokens <- lexer rest + return $ tok : tokens + +lexer :: String -> StencilSpecParser [ 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 (\x -> TId x $ fmap toLower x) $ \ c -> isAlphaNum c || c == '_' + | isPositiveNumber x = aux TNum isNumber + | otherwise + = throwError $ notAnIdentifier x + where + isPositiveNumber x = isNumber x && x /= '0' + aux f p = (f target :) <$> lexer rest + where (target, rest) = span p (x:xs) + +specParser :: SpecParser SpecParseError Specification +specParser = mkParser (\src -> do + tokens <- lexer src + parseSpecification tokens) + ["stencil", "region", "access"] + +happyError :: [ Token ] -> StencilSpecParser a +happyError = throwError . couldNotParseSpecification + +-- | Pretty-print the tokens, showing the smallest unique prefix of tokens +prettyTokens :: [ Token ] -> String +prettyTokens = + (++ "... ") . intercalate " " . map prettyToken . takeUniquePrefix 1 + where + takeUniquePrefix _ [] = [] + takeUniquePrefix n ts = + if ((take n ts) `isInfixOf` (drop n ts)) + then takeUniquePrefix (n+1) ts + else take n ts + +prettyToken TDoubleColon = "::" +prettyToken TStar = "*" +prettyToken TPlus = "+" +prettyToken TEqual = "=" +prettyToken TComma = "," +prettyToken TLParen = "(" +prettyToken TRParen = ")" +prettyToken (TId s _) = s +prettyToken (TNum n) = n + +} diff --git a/src/Camfort/Specification/Stencils/Parser/Types.hs b/src/Camfort/Specification/Stencils/Parser/Types.hs new file mode 100644 --- /dev/null +++ b/src/Camfort/Specification/Stencils/Parser/Types.hs @@ -0,0 +1,62 @@ +{- | +Module : Camfort.Specification.Stencils.Parser.Types +Description : Defines the representation of stencil specifications resulting from parsing. +Copyright : (c) 2017, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish +License : Apache-2.0 + +Maintainer : dom.orchard@gmail.com +Stability : experimental +-} + +{-# LANGUAGE DeriveDataTypeable #-} + +module Camfort.Specification.Stencils.Parser.Types + ( Specification(..) + , Region(..) + , SpecInner(..) + , reqRegions + ) where + +import Data.Data (Data, Typeable) +import Data.List (nub, sort) + +import Camfort.Specification.Stencils.Model + (Approximation(..), Multiplicity(..)) +import qualified Camfort.Specification.Stencils.Syntax as Syn + +data Specification + = RegionDec String Region + | SpecDec SpecInner [String] + deriving (Show, Eq, Typeable, Data) + +-- | Regions that are referenced in a specification. +reqRegions :: Specification -> [Syn.Variable] +reqRegions spec = nub . sort $ + case spec of + RegionDec _ r -> reqRegions' r + SpecDec (SpecInner x _) _ -> + case x of + Once a -> reqRegionsApprox a + Mult a -> reqRegionsApprox a + where + reqRegionsApprox (Exact r) = reqRegions' r + reqRegionsApprox (Bound l u) = + let maybeReqRegions = maybe [] reqRegions' + in maybeReqRegions l ++ maybeReqRegions u + reqRegions' :: Region -> [Syn.Variable] + reqRegions' RegionConst{} = [] + reqRegions' (Or r1 r2) = reqRegions' r1 ++ reqRegions' r2 + reqRegions' (And r1 r2) = reqRegions' r1 ++ reqRegions' r2 + reqRegions' (Var v) = [v] + +data Region + = RegionConst Syn.Region + | Or Region Region + | And Region Region + | Var String + deriving (Show, Eq, Ord, Typeable, Data) + +data SpecInner = SpecInner + (Multiplicity (Approximation Region)) -- main specification content + Syn.IsStencil -- a bool: stencil or access + deriving (Show, Eq, Typeable, Data) 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 @@ -20,24 +20,41 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -module Camfort.Specification.Stencils.Syntax where +module Camfort.Specification.Stencils.Syntax + ( + -- * Datatypes and Aliases + Linearity(..) + , Region(..) + , RegionDecl + , RegionEnv + , RegionProd(..) + , RegionSum(..) + , Spatial(..) + , SpecDecl + , SpecDecls + , Specification(..) + , IsStencil + , Variable + -- * Functions + , absoluteRep + , fromBool + , groupKeyBy + , hasDuplicates + , isEmpty + , isUnit + , pprintSpecDecls + , setLinearity + ) where -import Camfort.Helpers import Camfort.Specification.Stencils.Model ( Multiplicity(..) , peel , Approximation(..) - , lowerBound, upperBound - , fromExact ) import Prelude hiding (sum) import Data.Data -import Data.Generics.Uniplate.Data import Data.List hiding (sum) -import Data.Function -import Data.Maybe -import Debug.Trace import Control.Applicative type Variable = String @@ -56,33 +73,34 @@ {- *** 1 . Specification syntax -} +type RegionDecl = (Variable, RegionSum) +type SpecDecl = ([Variable], Specification) + -- List of region sums associated to region variables -type RegionEnv = [(String, RegionSum)] +type RegionEnv = [(Variable, RegionSum)] -- List of specifications associated to variables -- This is not a map so there might be multiple entries for each variable -- use `lookupAggregate` to access it -type SpecDecls = [([String], Specification)] +type SpecDecls = [SpecDecl] pprintSpecDecls :: SpecDecls -> String pprintSpecDecls = concatMap (\(names, spec) -> show spec ++ " :: " ++ intercalate "," names ++ "\n") -lookupAggregate :: Eq a => [([a], b)] -> a -> [b] -lookupAggregate [] _ = [] -lookupAggregate ((names, spec) : ss) name = - if name `elem` names - then spec : lookupAggregate ss name - else lookupAggregate ss name - -- Top-level of specifications: may be either spatial or temporal + +-- | `isStencil` is used to mark whether a specification is associated +-- | with a stencil computation, or a general array computation +type IsStencil = Bool + data Specification = - Specification (Multiplicity (Approximation Spatial)) + Specification (Multiplicity (Approximation Spatial)) IsStencil deriving (Eq, Data, Typeable) isEmpty :: Specification -> Bool -isEmpty (Specification mult) = isUnit . peel $ mult +isEmpty (Specification mult _) = isUnit . peel $ mult -- ********************** -- Spatial specifications: @@ -106,9 +124,9 @@ hasDuplicates xs = (nub xs, nub xs /= xs) setLinearity :: Linearity -> Specification -> Specification -setLinearity l (Specification mult) - | l == Linear = Specification $ Once $ peel mult - | l == NonLinear = Specification $ Mult $ peel mult +setLinearity l (Specification mult isStencil) + | l == Linear = Specification (Once $ peel mult) isStencil + | l == NonLinear = Specification (Mult $ peel mult) isStencil data Linearity = Linear | NonLinear deriving (Eq, Data, Typeable) @@ -123,11 +141,6 @@ Centered :: Depth -> Dimension -> IsRefl -> Region deriving (Eq, Data, Typeable) -getDimension :: Region -> Dimension -getDimension (Forward _ dim _) = dim -getDimension (Backward _ dim _) = dim -getDimension (Centered _ dim _) = dim - -- An (arbitrary) ordering on regions for the sake of normalisation instance Ord Region where (Forward dep dim _) <= (Forward dep' dim' _) @@ -161,14 +174,6 @@ -- Operations on specifications -regionPlus :: Region -> Region -> Maybe Region -regionPlus (Forward dep dim reflx) (Backward dep' dim' reflx') - | dep == dep' && dim == dim' = Just $ Centered dep dim (reflx || reflx') -regionPlus (Backward dep dim reflx) (Forward dep' dim' reflx') - | dep == dep' && dim == dim' = Just $ Centered dep dim (reflx || reflx') -regionPlus x y | x == y = Just x -regionPlus x y = 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] @@ -233,18 +238,10 @@ one = Sum [Product []] isUnit s@(Sum ss) = s == zero || s == one || all (== Product []) ss --- Show a list with ',' separator -showL :: Show a => [a] -> String -showL = intercalate "," . map show - --- Show lists with '*' or '+' separator (used to represent product of regions) -showProdSpecs, showSumSpecs :: Show a => [a] -> String -showProdSpecs = intercalate "*" . map show -showSumSpecs = intercalate "+" . map show - -- Pretty print top-level specifications instance Show Specification where - show (Specification sp) = "stencil " ++ show sp + show (Specification sp True) = "stencil " ++ show sp + show (Specification sp False) = "access " ++ show sp instance {-# OVERLAPS #-} Show (Multiplicity (Approximation Spatial)) where show mult @@ -255,12 +252,13 @@ case appr of Exact s -> linearity ++ optionalSeparator sep (show s) Bound Nothing Nothing -> "empty" - Bound Nothing (Just s) -> "atMost, " ++ linearity ++ optionalSeparator sep (show s) - Bound (Just s) Nothing -> "atLeast, " ++ linearity ++ optionalSeparator sep (show s) + Bound Nothing (Just s) -> linearity ++ optionalSeparator sep "atMost, " ++ show s + Bound (Just s) Nothing -> linearity ++ optionalSeparator sep "atLeast, " ++ show s Bound (Just sL) (Just sU) -> - "atLeast, " ++ linearity ++ optionalSeparator sep (show sL) ++ - "; atMost, " ++ linearity ++ optionalSeparator sep (show sU) - optionalSeparator sep "" = "" + concat [ linearity, optionalSeparator sep (show sL), ";" + , if linearity == empty then "" else " " ++ linearity ++ ", " + , "atMost, ", show sU ] + optionalSeparator _ "" = "" optionalSeparator sep s = sep ++ s instance {-# OVERLAPS #-} Show (Approximation Spatial) where @@ -281,19 +279,23 @@ -- Pretty print region sums instance Show RegionSum where - -- Tweedle-dum - show (Sum []) = "empty" - -- Tweedle-dee - show (Sum [Product []]) = "empty" + showsPrec _ (Sum []) = showString "empty" - show (Sum specs) = - intercalate " + " ppspecs - where ppspecs = filter (/= "") $ map show specs + showsPrec p (Sum specs) = + showParen (p > 6) $ inter specs + where + inter [ ] = id + inter [ x ] = showsPrec 6 x + inter (x:xs) = showsPrec 6 x . (" + " ++) . inter xs instance Show RegionProd where - show (Product []) = "" - show (Product ss) = - intercalate "*" . map (\s -> "(" ++ show s ++ ")") $ ss + showsPrec _ (Product []) = showString "empty" + showsPrec p (Product ss) = + showParen (p > 7) $ inter ss + where + inter [ ] = id + inter [ x ] = showsPrec 7 x + inter (x:xs) = showsPrec 7 x . ('*' :) . inter xs instance Show Region where show (Forward dep dim reflx) = showRegion "forward" dep dim reflx 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 @@ -16,13 +16,14 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TupleSections #-} -module Camfort.Specification.Stencils.Synthesis where +module Camfort.Specification.Stencils.Synthesis + ( formatSpec + , formatSpecNoComment + , offsetToIx + ) where import Data.List -import Data.Maybe -import qualified Data.Map as M import Camfort.Specification.Stencils.Syntax @@ -30,39 +31,46 @@ import qualified Language.Fortran.AST as F 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.Util.Position -- Format inferred specifications -formatSpec :: - Maybe String - -> FAR.NameMap +formatSpec :: F.MetaInfo -> Int -> Char -> (FU.SrcSpan, Either [([Variable], Specification)] (String,Variable)) -> String -formatSpec prefix nm (span, Right (evalInfo,name)) = - prefix' - ++ evalInfo - ++ (if name /= "" then " :: " ++ realName name else "") ++ "\n" - where - realName v = v `fromMaybe` (v `M.lookup` nm) - prefix' = case prefix of - Nothing -> show span ++ " " - Just pr -> pr +formatSpec mi indent marker (span, Right (evalInfo, name)) = + buildCommentText mi indent $ + marker : " " + ++ evalInfo + ++ (if name /= "" then " :: " ++ name else "") ++ "\n" -formatSpec _ _ (_, Left []) = "" -formatSpec prefix nm (span, Left specs) = - (intercalate "\n" $ map (\s -> prefix' ++ doSpec s) specs) +formatSpec _ _ _ (_, Left []) = "" +formatSpec mi indent marker (span, Left specs) = + intercalate "\n" $ map commentText specs where - prefix' = case prefix of - Nothing -> show span ++ " " - Just pr -> pr + commentText s = buildCommentText mi indent (marker : " " ++ doSpec s) commaSep = intercalate ", " doSpec (arrayVar, spec) = - show (fixSpec spec) ++ " :: " ++ commaSep (map realName arrayVar) - realName v = v `fromMaybe` (v `M.lookup` nm) + show (fixSpec spec) ++ " :: " ++ commaSep arrayVar fixSpec s = s + + +-- | Format inferred specifications, but do not format as a comment. +formatSpecNoComment :: + (FU.SrcSpan, Either [([Variable], Specification)] (String,Variable)) + -> String +formatSpecNoComment (span, Right (evalInfo, name)) = + show span ++ " " ++ evalInfo ++ (if name /= "" then " :: " ++ name else "") ++ "\n" +formatSpecNoComment (_, Left []) = "" +formatSpecNoComment (span, Left specs) = + intercalate "\n" . map (\s -> show span ++ " " ++ doSpec s) $ specs + where + commaSep = intercalate ", " + doSpec (arrayVar, spec) = + show (fixSpec spec) ++ " :: " ++ commaSep arrayVar + fixSpec s = s + ------------------------ a = (head $ FA.initAnalysis [unitAnnotation]) { FA.insLabel = Just 0 } 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 @@ -31,26 +31,22 @@ import qualified Data.Map.Strict as M import Data.Data -import Data.Char (isNumber) import Data.List (intercalate, find, sort, group, nub, inits) -import Data.Maybe (fromMaybe, maybeToList, listToMaybe, mapMaybe, isJust, maybe) +import Data.Maybe (fromMaybe, maybeToList, mapMaybe, 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 -import Camfort.Output +import Camfort.Helpers import Camfort.Analysis.Annotations import Camfort.Input +import Camfort.Reprint (subtext) -- Provides the types and data accessors used in this module import Camfort.Specification.Units.Environment import Camfort.Specification.Units.Monad -import Camfort.Specification.Units.InferenceBackend import Camfort.Specification.Units.InferenceFrontend import Camfort.Specification.Units.Synthesis (runSynthesis) @@ -61,22 +57,33 @@ import qualified Language.Fortran.Util.Position as FU import Language.Fortran.Util.ModFile --- For debugging and development purposes -import qualified Debug.Trace as D +-- | Run a unit inference. +runInference :: UnitOpts + -> F.ProgramFile UA + -> UnitSolver a + -> (Either UnitException a, UnitState, UnitLogs) +runInference uOpts pf runner = runUnitSolver uOpts pf $ do + let compiledUnits = combinedCompiledUnits . M.elems . uoModFiles $ uOpts + modifyTemplateMap . const . cuTemplateMap $ compiledUnits + modifyNameParamMap . const . cuNameParamMap $ compiledUnits + initInference + runner -- ************************************* -- Unit inference (top - level) -- -- ************************************* -inferCriticalVariables - :: UnitOpts -> (Filename, F.ProgramFile Annotation) -> (Report, Int) - {-| Infer one possible set of critical variables for a program -} -inferCriticalVariables uo (fname, pf) +inferCriticalVariables + :: UnitOpts + -> F.ProgramFile Annotation + -> (Report, Int) +inferCriticalVariables uOpts pf | Right vars <- eVars = okReport vars | Left exc <- eVars = (errReport exc, -1) where + fname = F.pfGetFilename pf -- Format report okReport [] = (logs ++ "\n" ++ fname ++ ":No additional annotations are necessary.\n", 0) @@ -99,21 +106,15 @@ errReport exc = logs ++ "\n" ++ fname ++ ":\n" ++ show exc - -- run inference - 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 + (eVars, state, logs) = runInference uOpts pfRenamed runCriticalVariables 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)) + mmap = combinedModuleMap (M.elems (uoModFiles uOpts)) pfRenamed = FAR.analyseRenamesWithModuleMap mmap . FA.initAnalysis . fmap mkUnitAnnotation $ pf -- Map of all declarations - dmap = extractDeclMap pfRenamed `M.union` combinedDeclMap (M.elems (uoModFiles uo)) + dmap = extractDeclMap pfRenamed `M.union` combinedDeclMap (M.elems (uoModFiles uOpts)) mmap' = extractModuleMap pfRenamed `M.union` mmap -- post-parsing -- unique name -> src name across modules @@ -122,27 +123,38 @@ 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 + fromWhereMap = genUniqNameToFilenameMap . M.elems $ uoModFiles uOpts -checkUnits, inferUnits - :: UnitOpts -> (Filename, F.ProgramFile Annotation) -> Report +checkUnits, inferUnits :: UnitOpts -> F.ProgramFile Annotation -> Report {-| Check units-of-measure for a program -} -checkUnits uo (fname, pf) +checkUnits uOpts pf | Right mCons <- eCons = okReport mCons | Left exc <- eCons = errReport exc where + fname = F.pfGetFilename pf -- Format report 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) + unlines (map showSrcConstraint constraints) + showSrcConstraint :: (Constraint, FU.SrcSpan) -> String + showSrcConstraint (con, srcSpan) = show srcSpan ++ ": " ++ show con reportErrors cons = unlines [ maybe "" showSS ss ++ str | (ss, str) <- reports ] where - reports = map head . group . sort $ map reportError cons + reports = map head . group . sort . map reportError . filter relevantConstraints $ cons showSS = (++ ": ") . (" - at "++) . showSrcSpan - reportError con = (findCon con, pprintConstr (orient (unrename nameMap con)) ++ additionalInfo con) + relevantConstraints c = not (isPolymorphic0 c) && not (isReflexive c) + + isPolymorphic0 (ConEq (UnitParamLitAbs {}) _) = True + isPolymorphic0 (ConEq _ (UnitParamLitAbs {})) = True + isPolymorphic0 _ = False + + isReflexive (ConEq u1 u2) = u1 == u2 + + reportError con = (span, pprintConstr (orient (unrename con)) ++ additionalInfo con) where + span = findCon con -- Create additional info for errors additionalInfo con = if null (errorInfo con) @@ -150,7 +162,7 @@ else "\n instead" ++ intercalate "\n" (mapNotFirst (pad 10) (errorInfo con)) -- Create additional info about inconsistencies involving variables errorInfo con = - [" '" ++ sName ++ "' is '" ++ pprintUnitInfo (unrename nameMap u) ++ "'" + [" '" ++ sName ++ "' is '" ++ pprintUnitInfo (unrename u) ++ "'" | UnitVar (vName, sName) <- universeBi con , u <- findUnitConstrFor con vName ] -- Find unit information for variable constraints @@ -172,7 +184,7 @@ pad o = (++) (replicate o ' ') srcSpan con | Just ss <- findCon con = showSrcSpan ss ++ " " - | otherwise = "" + | otherwise = "" -- Find a given constraint within the annotated AST. FIXME: optimise @@ -180,14 +192,39 @@ 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) ] + constraints = [ (c, srcSpan) + | x <- universeBi pfUA :: [F.Expression UA] + , let srcSpan = FU.getSpan x + , c <- maybeToList (getConstraint x) + ] ++ + + [ (c, srcSpan) + | x <- universeBi pfUA :: [F.Statement UA] + , let srcSpan = FU.getSpan x + , c <- maybeToList (getConstraint x) + ] ++ + + [ (c, srcSpan) + | x <- universeBi pfUA :: [F.Argument UA] + , let srcSpan = FU.getSpan x + , c <- maybeToList (getConstraint x) + ] ++ + + [ (c, srcSpan) + | x <- universeBi pfUA :: [F.Declarator UA] + , let srcSpan = FU.getSpan x + , c <- maybeToList (getConstraint x) + ] ++ + + -- Why reverse? So that PUFunction and PUSubroutine appear + -- first in the list, before PUModule. + reverse [ (c, srcSpan) + | x <- universeBi pfUA :: [F.ProgramUnit UA] + , let srcSpan = FU.getSpan x + , c <- maybeToList (getConstraint x) + ] + varReport = intercalate ", " . map showVar showVar (UnitVar (_, s)) = s @@ -196,13 +233,7 @@ errReport exc = logs ++ "\n" ++ fname ++ ": " ++ show exc - -- run inference - uOpts = uo { uoNameMap = nameMap } - (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 + (eCons, state, logs) = runInference uOpts pfRenamed runInconsistentConstraints templateMap = usTemplateMap state pfUA :: F.ProgramFile UA pfUA = usProgramFile state -- the program file after units analysis is done @@ -214,13 +245,13 @@ _ -> False -- Use the module map derived from all of the included Camfort Mod files. - mmap = combinedModuleMap (M.elems (uoModFiles uo)) + mmap = combinedModuleMap (M.elems (uoModFiles uOpts)) 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)] @@ -243,11 +274,12 @@ {-| 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) - | Right [] <- eVars = checkUnits uo (fname, pf) +inferUnits uOpts pf + | Right [] <- eVars = checkUnits uOpts pf | Right vars <- eVars = okReport vars | Left exc <- eVars = errReport exc where + fname = F.pfGetFilename pf -- Format report okReport vars = logs ++ "\n" ++ fname ++ ":\n" ++ unlines [ expReport ei | ei <- expInfo ] ++ show vars where @@ -258,22 +290,14 @@ errReport exc = logs ++ "\n" ++ fname ++ ": " ++ show exc - -- run inference - uOpts = uo { uoNameMap = nameMap } - (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 + (eVars, state, logs) = runInference uOpts pfRenamed (chooseImplicitNames <$> runInferVariables) 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)) + mmap = combinedModuleMap (M.elems (uoModFiles uOpts)) 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 } @@ -298,18 +322,19 @@ f _ = Just . LB.toStrict $ encode cu compileUnits :: UnitOpts -> [FileProgram] -> (String, [(Filename, B.ByteString)]) -compileUnits uo fileprogs = (concat reports, concat bins) +compileUnits uOpts fileprogs = (concat reports, concat bins) where (reports, bins) = unzip [ (report, bin) | fileprog <- fileprogs - , let (report, bin) = compileUnits' uo fileprog ] + , let (report, bin) = compileUnits' uOpts fileprog ] compileUnits' :: UnitOpts -> FileProgram -> (String, [(Filename, B.ByteString)]) -compileUnits' uo (fname, pf) +compileUnits' uOpts pf | Right cu <- eCUnits = okReport cu | Left exc <- eCUnits = errReport exc where + fname = F.pfGetFilename pf -- Format report - okReport cu = ( logs ++ "\n" ++ fname ++ ":\n" ++ if uoDebug uo then debugInfo else [] + okReport cu = ( logs ++ "\n" ++ fname ++ ":\n" ++ if uoDebug uOpts then debugInfo else [] -- FIXME, filename manipulation (needs to go in -I dir?) , [(fname ++ modFileSuffix, encodeModFile (genUnitsModFile pfTyped cu))] ) where @@ -319,34 +344,26 @@ 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 - + (eCUnits, state, logs) = runInference uOpts pfTyped 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)) + mmap = combinedModuleMap (M.elems (uoModFiles uOpts)) + tenv = combinedTypeEnv (M.elems (uoModFiles uOpts)) 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) - -> (Report, (Filename, F.ProgramFile Annotation)) + -> F.ProgramFile Annotation + -> (Report, F.ProgramFile Annotation) {-| Synthesis unspecified units for a program (after checking) -} -synthesiseUnits uo marker (fname, pf) - | Right [] <- eVars = (checkUnits uo (fname, pf), (fname, pf)) - | Right vars <- eVars = (okReport vars, (fname, pfFinal)) - | Left exc <- eVars = (errReport exc, (fname, pfFinal)) +synthesiseUnits uOpts marker pf + | Right [] <- eVars = (checkUnits uOpts pf, pf) + | Right vars <- eVars = (okReport vars, pfFinal) + | Left exc <- eVars = (errReport exc, pfFinal) where + fname = F.pfGetFilename pf -- Format report okReport vars = logs ++ "\n" ++ fname ++ ":\n" ++ unlines [ expReport ei | ei <- expInfo ] where @@ -357,25 +374,27 @@ errReport exc = logs ++ "\n" ++ fname ++ ": " ++ show exc - -- run inference - uOpts = uo { uoNameMap = nameMap } - (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) + (eVars, state, logs) = runInference uOpts pfRenamed (runInferVariables >>= (runSynthesis marker . chooseImplicitNames)) pfUA = usProgramFile state -- the program file after units analysis is done pfFinal = fmap prevAnnotation . fmap FA.prevAnnotation $ pfUA -- strip annotations -- Use the module map derived from all of the included Camfort Mod files. - mmap = combinedModuleMap (M.elems (uoModFiles uo)) + mmap = combinedModuleMap (M.elems (uoModFiles uOpts)) pfRenamed = FAR.analyseRenamesWithModuleMap mmap . FA.initAnalysis . fmap mkUnitAnnotation $ pf - nameMap = FAR.extractNameMap pfRenamed -------------------------------------------------- -unrename nameMap = transformBi $ \ x -> x `fromMaybe` M.lookup x nameMap +-- clear out the unique names in the UnitInfos. +unrename :: Data a => a -> a +unrename = transformBi $ \ x -> case x of + UnitVar (u, s) -> UnitVar (s, s) + UnitParamVarAbs ((_, f), (_, s)) -> UnitParamVarAbs ((f, f), (s, s)) + UnitParamVarUse ((_, f), (_, s), i) -> UnitParamVarUse ((f, f), (s, s), i) + UnitParamEAPAbs (_, s) -> UnitParamEAPAbs (s, s) + UnitParamEAPUse ((_, s), i) -> UnitParamEAPUse ((s, s), i) + u -> u + showSrcSpan :: FU.SrcSpan -> String showSrcSpan (FU.SrcSpan l u) = show l 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 @@ -18,38 +18,58 @@ {- Provides various data types and type class instances for the Units extension -} -module Camfort.Specification.Units.Environment where - -import Control.Monad.State.Strict hiding (gets) +module Camfort.Specification.Units.Environment + ( + -- * Datatypes and Aliases + Constraint(..) + , Constraints + , UnitAnnotation(..) + , UnitInfo(..) + , VV, PP + -- * Helpers + , conParamEq + , doubleToRationalSubset + , mkUnitAnnotation + , pprintConstr + , pprintUnitInfo + , toUnitInfo + -- * Modules (instances) + , module Data.Data + ) where import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA -import qualified Language.Fortran.Util.Position as FU -import qualified Camfort.Specification.Units.Parser as P +import qualified Camfort.Specification.Units.Parser.Types as P import Data.Char import Data.Data import Data.List -import Data.Matrix import Data.Ratio import Data.Binary import GHC.Generics (Generic) -import qualified Debug.Trace as D +import Camfort.Helpers (SourceText) +import qualified Data.ByteString.Char8 as B + import Text.Printf -- | A (unique name, source name) variable type VV = (F.Name, F.Name) +-- | A (unique name, source name) program unit name +type PP = (F.Name, F.Name) + +type UniqueId = Int + -- | Description of the unit of an expression. 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, 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 + = UnitParamPosAbs (PP, Int) -- an abstract parameter identified by PU name and argument position + | UnitParamPosUse (PP, Int, Int) -- identify particular instantiation of parameters + | UnitParamVarAbs (PP, VV) -- an abstract parameter identified by PU name and variable name + | UnitParamVarUse (PP, VV, Int) -- a particular instantiation of above + | UnitParamLitAbs UniqueId -- a literal with abstract, polymorphic units, uniquely identified + | UnitParamLitUse (UniqueId, 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 @@ -67,27 +87,27 @@ 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 - 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) ++ ")" + 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 "unit_of(%s)" 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 -> -- printf "%s**%f" (maybeParen u) k + | k < 0 -> maybeParen u1 ++ " / " ++ maybeParen (UnitPow u2 (-k)) + UnitMul u1 u2 -> maybeParenS u1 ++ " " ++ maybeParenS u2 + UnitPow u 1 -> show u + UnitPow _ 0 -> "1" + UnitPow u k -> -- printf "%s**%f" (maybeParen u) k case doubleToRationalSubset k of Just r | e <- showRational r @@ -148,10 +168,6 @@ 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 @@ -167,29 +183,41 @@ isResolvedUnit = not . isUnresolvedUnit +isConcreteUnit :: UnitInfo -> Bool +isConcreteUnit (UnitPow u _) = isConcreteUnit u +isConcreteUnit (UnitMul u v) = isConcreteUnit u && isConcreteUnit v +isConcreteUnit (UnitAlias _) = True +isConcreteUnit UnitlessLit = True +isConcreteUnit (UnitName _) = True +isConcreteUnit _ = False + pprintConstr :: Constraint -> String pprintConstr (ConEq u1 u2) + | isResolvedUnit u1 && isConcreteUnit u1 && + isResolvedUnit u2 && isConcreteUnit u2 = + "Units '" ++ pprintUnitInfo u1 ++ "' and '" ++ pprintUnitInfo u2 ++ + "' should be equal" | 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) +pprintConstr (ConConj cs) = intercalate "\n\t and " (fmap pprintConstr cs) pprintUnitInfo :: UnitInfo -> String -pprintUnitInfo (UnitVar (_, sName)) = printf "%s" sName +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 +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" +pprintUnitInfo ui = show ui -------------------------------------------------- -- | 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 @@ -220,21 +248,6 @@ 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 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 Nothing 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 @@ -30,29 +30,26 @@ import Data.Tuple (swap) import Data.Maybe (maybeToList) -import Data.List ((\\), findIndex, partition, sortBy, group, intercalate, tails, sort) -import Data.Generics.Uniplate.Operations (rewrite, universeBi) +import Data.List ((\\), findIndex, partition, sortBy, group, tails) +import Data.Generics.Uniplate.Operations (rewrite) import Control.Monad -import Control.Monad.State.Strict import Control.Monad.ST import Control.Arrow (first, second) import qualified Data.Map.Strict as M import qualified Data.Array as A -import Camfort.Analysis.Annotations import Camfort.Specification.Units.Environment import Numeric.LinearAlgebra ( - atIndex, (<>), (><), rank, (?), toLists, toList, fromLists, fromList, rows, cols, - takeRows, takeColumns, dropRows, dropColumns, subMatrix, diag, build, fromBlocks, - ident, flatten, lu, dispf + atIndex, (<>), rank, (?), rows, cols, + takeColumns, dropRows, subMatrix, diag, fromBlocks, + ident, ) import qualified Numeric.LinearAlgebra as H import Numeric.LinearAlgebra.Devel ( newMatrix, readMatrix, writeMatrix, runSTMatrix, freezeMatrix, STMatrix ) -import qualified Debug.Trace as D -------------------------------------------------- @@ -74,7 +71,7 @@ criticalVariables [] = [] criticalVariables cons = filter (not . isUnitRHS) $ map (colA A.!) criticalIndices where - (unsolvedM, inconsists, colA) = constraintsToMatrix cons + (unsolvedM, _, colA) = constraintsToMatrix cons solvedM = rref unsolvedM uncriticalIndices = concatMap (maybeToList . findIndex (/= 0)) $ H.toLists solvedM criticalIndices = A.indices colA \\ uncriticalIndices @@ -124,8 +121,6 @@ -------------------------------------------------- -simplifyConstraints = map (\ (ConEq u1 u2) -> (flattenUnits u1, flattenUnits u2)) - simplifyUnits :: UnitInfo -> UnitInfo simplifyUnits = rewrite rw where @@ -136,7 +131,7 @@ rw (UnitPow _ p) | p `approxEq` 0 = Just UnitlessLit rw (UnitMul UnitlessLit u) = Just u rw (UnitMul u UnitlessLit) = Just u - rw u = Nothing + rw _ = Nothing flattenUnits :: UnitInfo -> [UnitInfo] flattenUnits = map (uncurry UnitPow) . M.toList @@ -183,7 +178,6 @@ 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 @@ -250,16 +244,6 @@ rref :: H.Matrix Double -> H.Matrix Double rref a = snd $ rrefMatrices' a 0 0 [] --- | List of matrices that when multiplied transform input into --- Reduced Row Echelon Form -rrefMatrices :: H.Matrix Double -> [H.Matrix Double] -rrefMatrices a = fst $ rrefMatrices' a 0 0 [] - --- | Single matrix that transforms input into Reduced Row Echelon form --- when multiplied to the original. -rrefMatrix :: H.Matrix Double -> H.Matrix Double -rrefMatrix a = foldr (<>) (ident (rows a)) . fst $ rrefMatrices' a 0 0 [] - -- worker function -- invariant: the matrix a is in rref except within the submatrix (j-k,j) to (n,n) rrefMatrices' a j k mats @@ -297,7 +281,7 @@ -- 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 + findAdds _ m ms | isWritten = (new <> m, new:ms) | otherwise = (m, ms) where @@ -322,13 +306,6 @@ elemRowMult :: Int -> Int -> Double -> H.Matrix Double elemRowMult n i k = diag (H.fromList (replicate i 1.0 ++ [k] ++ replicate (n - i - 1) 1.0)) -elemRowAdd :: Int -> Int -> Int -> Double -> H.Matrix Double -elemRowAdd n i j k = runSTMatrix $ do - m <- newMatrix 0 n n - sequence [ writeMatrix m i' i' 1 | i' <- [0 .. (n - 1)] ] - writeMatrix m i j k - return m - elemRowSwap :: Int -> Int -> Int -> H.Matrix Double elemRowSwap n i j | i == j = ident n @@ -340,12 +317,6 @@ -- Worker functions: -toDouble :: Rational -> Double -toDouble = fromRational - -fromDouble :: Double -> Rational -fromDouble = toRational - findInconsistentRows :: H.Matrix Double -> H.Matrix Double -> [Int] findInconsistentRows coA augA = [0..(rows augA - 1)] \\ consistent where @@ -359,12 +330,5 @@ coA' = extractRows ns coA augA' = extractRows ns augA - pset = filterM (const [True, False]) - 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 @@ -31,12 +31,11 @@ import qualified Data.Map.Strict as M import qualified Data.IntMap.Strict as IM import qualified Data.Set as S -import Data.Maybe (isJust, fromMaybe, catMaybes) +import Data.Maybe (isJust, fromMaybe) import Data.Generics.Uniplate.Operations import Control.Monad import Control.Monad.State.Strict import Control.Monad.Writer.Strict -import Control.Monad.Trans.Except import Control.Monad.RWS.Strict import qualified Language.Fortran.AST as F @@ -51,7 +50,8 @@ import Camfort.Specification.Units.Environment import Camfort.Specification.Units.Monad import Camfort.Specification.Units.InferenceBackend -import qualified Camfort.Specification.Units.Parser as P +import Camfort.Specification.Units.Parser (unitParser) +import qualified Camfort.Specification.Units.Parser.Types as P import qualified Debug.Trace as D import qualified Numeric.LinearAlgebra as H -- for debugging @@ -65,12 +65,11 @@ -- Parse unit annotations found in comments and link to their -- corresponding statements in the AST. - let (linkedPF, parserReport) = runWriter $ annotateComments P.unitParser pf + let (linkedPF, parserReport) = + runWriter $ annotateComments unitParser + (\srcSpan err -> tell $ "Error " ++ show srcSpan ++ ": " ++ show err) pf modifyProgramFile $ const linkedPF - -- Send the output of the parser to the logger. - mapM_ tell parserReport - -- The following insert* functions examine the AST and insert -- mappings into the tables stored in the UnitState. @@ -194,7 +193,7 @@ -- Insert a parametric unit if the variable does not already have a unit. modifyVarUnitMap $ M.insertWith (curry snd) param (UnitParamPosAbs (fname, i)) where - fname = puName pu + fname = (puName pu, puSrcName pu) -- | Return the list of parameters paired with its positional index. indexedParams :: F.ProgramUnit UA -> [(Int, VV)] @@ -236,9 +235,9 @@ 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) + Just (DCFunction (F.Named fvname, F.Named fsname)) -> UnitParamVarAbs ((fvname, fsname), (vname, sname)) + Just (DCSubroutine (F.Named fvname, F.Named fsname)) -> UnitParamVarAbs ((fvname, fsname), (vname, sname)) + _ -> UnitVar (vname, sname) -------------------------------------------------- @@ -258,7 +257,7 @@ where -- Look through each Program Unit for the comments checkPU :: F.ProgramUnit UA -> UnitSolver () - checkPU pu@(F.PUComment a _ _) + checkPU (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 @@ -316,55 +315,6 @@ 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 @@ -426,12 +376,6 @@ 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 @@ -445,7 +389,7 @@ 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 ] + 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 @@ -503,7 +447,7 @@ modify $ \ s -> s { usCallIdRemap = IM.empty } -- If any new instances are discovered, also process them, unless recursive. - let instances = nub [ (name, i) | UnitParamPosUse (name, _, i) <- universeBi template ] + let instances = nub [ (name, i) | UnitParamPosUse ((name, _), _, i) <- universeBi template ] template' <- if name `elem` callStack then -- Detected recursion: we do not support polymorphic-unit recursion, -- ergo all subsequent recursive calls are assumed to have the same @@ -545,10 +489,10 @@ -- | Generate constraints from a NameParamMap entry. nameParamConstraints :: F.Name -> UnitSolver Constraints nameParamConstraints fname = do - let filterForName (NPKParam n _) _ = n == fname - filterForName _ _ = False + 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 ] + return [ ConEq (UnitParamPosAbs (n, pos)) (foldUnits units) | (NPKParam n 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 @@ -616,22 +560,6 @@ getBlocks (F.PUModule _ _ _ bs _) = bs getBlocks _ = [] --- | Does the constraint contain any Parametric elements? -isParametric :: Constraint -> Bool -isParametric info = not . null $ [ () | UnitParamPosAbs _ <- universeBi info ] ++ - [ () | 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. @@ -662,11 +590,11 @@ setF2C f u1 u2 = return . maybeSetUnitInfo u1 $ maybeSetUnitConstraintF2 f u1 u2 e propagateFunctionCall :: F.Expression UA -> UnitSolver (F.Expression UA) -propagateFunctionCall e@(F.ExpFunctionCall a s f Nothing) = do +propagateFunctionCall (F.ExpFunctionCall a s f Nothing) = do (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 +propagateFunctionCall (F.ExpFunctionCall a s f (Just (F.AList a' s' args))) = do (info, args') <- callHelper f args let cons = intrinsicHelper info f args' return . setConstraint (ConConj cons) . setUnitInfo info $ F.ExpFunctionCall a s f (Just (F.AList a' s' args')) @@ -701,7 +629,9 @@ propagatePU :: F.ProgramUnit UA -> UnitSolver (F.ProgramUnit UA) propagatePU pu = do - let name = puName pu + let name = puName pu + let sname = puSrcName pu + let nn = (name, sname) let bodyCons = [ con | con@(ConEq {}) <- universeBi pu ] -- Constraints within the PU. varMap <- gets usVarUnitMap @@ -713,9 +643,9 @@ -- the explicit unit annotation as well. givenCons <- forM (indexedParams pu) $ \ (i, param) -> do case M.lookup param varMap of - 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) + Just (UnitParamPosAbs {}) -> return . ConEq (UnitParamVarAbs (nn, param)) $ UnitParamPosAbs (nn, i) + Just u -> return . ConEq u $ UnitParamPosAbs (nn, i) + _ -> return . ConEq (UnitParamVarAbs (nn, param)) $ UnitParamPosAbs (nn, i) let cons = givenCons ++ bodyCons case pu of F.PUFunction {} -> modifyTemplateMap (M.insert name cons) @@ -725,22 +655,17 @@ -- 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 + (F.PUFunction {}, (0, res):_) -> setUnitInfo (UnitParamPosAbs (nn, 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. -containsParametric :: Data from => String -> from -> Bool -containsParametric name x = not . null $ [ () | UnitParamPosAbs (name', _) <- universeBi x, name == name' ] ++ - [ () | UnitParamVarAbs (name', _) <- universeBi x, name == name' ] - -- | Coalesce various function and subroutine call common code. callHelper :: F.Expression UA -> [F.Argument UA] -> UnitSolver (UnitInfo, [F.Argument UA]) callHelper nexp args = do - let name = varName nexp + let name = (varName nexp, srcName nexp) callId <- genCallId -- every call-site gets its own unique identifier let eachArg i arg@(F.Argument _ _ _ e) -- add site-specific parametric constraints to each argument @@ -758,7 +683,7 @@ numArgs = length args sname = srcName f vname = varName f - eachArg i u = ConEq (UnitParamPosUse (vname, i, callId)) (instantiate callId u) + eachArg i u = ConEq (UnitParamPosUse ((vname, sname), i, callId)) (instantiate callId u) intrinsicHelper _ _ _ = [] -- | Generate a unique identifier for a call-site. @@ -811,12 +736,12 @@ -- | Set the UnitInfo field on a piece of AST. setUnitInfo :: F.Annotated f => UnitInfo -> f UA -> f UA -setUnitInfo info = modifyAnnotation (onPrev (\ ua -> ua { unitInfo = Just info })) +setUnitInfo info = F.modifyAnnotation (onPrev (\ ua -> ua { unitInfo = Just info })) -- | Set the Constraint field on a piece of AST. setConstraint :: F.Annotated f => Constraint -> f UA -> f UA setConstraint (ConConj []) = id -setConstraint c = modifyAnnotation (onPrev (\ ua -> ua { unitConstraint = Just c })) +setConstraint c = F.modifyAnnotation (onPrev (\ ua -> ua { unitConstraint = Just c })) -------------------------------------------------- @@ -833,11 +758,6 @@ maybeSetUnitConstraintF2 f (Just u1) (Just u2) e = setConstraint (f u1 u2) e maybeSetUnitConstraintF2 _ _ _ e = e -fmapUnitInfo :: F.Annotated f => (UnitInfo -> UnitInfo) -> f UA -> f UA -fmapUnitInfo f x - | Just u <- getUnitInfo x = setUnitInfo (f u) x - | otherwise = x - -- Operate only on the blocks of a program unit, not the contained sub-programunits. modifyPUBlocksM :: Monad m => ([F.Block a] -> m [F.Block a]) -> F.ProgramUnit a -> m (F.ProgramUnit a) modifyPUBlocksM f pu = case pu of @@ -1063,6 +983,8 @@ , ("cosh", (UnitlessVar, [UnitlessVar])) , ("dcosh", (UnitlessVar, [UnitlessVar])) , ("tanh", (UnitlessVar, [UnitlessVar])) - , ("dtanh", (UnitlessVar, [UnitlessVar])) ] + , ("dtanh", (UnitlessVar, [UnitlessVar])) + , ("iand", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'a", "'a")])) + ] -- 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 @@ -39,13 +39,11 @@ 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 +import Camfort.Specification.Units.Environment (UnitInfo, Constraints(..), VV, PP) +import Camfort.Analysis.Annotations (UA) -- | Some options about how to handle literals. @@ -69,20 +67,19 @@ data UnitOpts = UnitOpts { 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, Data, Eq, Ord) unitOpts0 :: UnitOpts -unitOpts0 = UnitOpts False LitMixed M.empty M.empty +unitOpts0 = UnitOpts False LitMixed 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 + = NPKParam PP Int -- ^ Function/subroutine name, position of parameter | NPKVariable VV -- ^ variable deriving (Ord, Eq, Show, Data, Typeable, Generic) 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 @@ -1,20 +1,19 @@ { -- -*- Mode: Haskell -*- -{-# LANGUAGE DeriveDataTypeable #-} -module Camfort.Specification.Units.Parser ( unitParser - , UnitStatement(..) - , UnitOfMeasure(..) - , UnitPower(..) - ) where +module Camfort.Specification.Units.Parser + ( unitParser + , UnitParseError + ) where -import Camfort.Analysis.CommentAnnotator -import Data.Data -import Data.List +import Control.Monad.Except (throwError) import Data.Char (isLetter, isNumber, isAlphaNum, toLower) -import qualified Data.Text as T + +import Camfort.Specification.Parser (mkParser, SpecParser) +import Camfort.Specification.Units.Parser.Types + } -%monad { Either AnnotationParseError } { >>= } { return } +%monad { UnitSpecParser } { >>= } { return } %name parseUnit UNIT %tokentype { Token } @@ -26,6 +25,7 @@ num { TNum $$ } ',' { TComma } '-' { TMinus } + '*' { TMult } '**' { TExponentiation } '/' { TDivision } '::' { TDoubleColon } @@ -33,6 +33,7 @@ '(' { TLeftPar } ')' { TRightPar } +%left '*' %left '/' %left '**' %% @@ -65,6 +66,7 @@ UEXP_LEVEL1 :: { UnitOfMeasure } : UEXP_LEVEL1 UEXP_LEVEL2 { UnitProduct $1 $2 } +| UEXP_LEVEL1 '*' UEXP_LEVEL2 { UnitProduct $1 $3 } | UEXP '/' UEXP_LEVEL2 { UnitQuotient $1 $3 } | UEXP_LEVEL2 { $1 } @@ -88,41 +90,25 @@ { -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 UnitParseError + -- | Not a valid identifier character. + = NotAnIdentifier Char + -- | Tokens do not represent a syntactically valid specification. + | CouldNotParseSpecification [Token] + deriving (Eq) -data UnitOfMeasure = - Unitless - | UnitBasic String - | UnitProduct UnitOfMeasure UnitOfMeasure - | UnitQuotient UnitOfMeasure UnitOfMeasure - | UnitExponentiation UnitOfMeasure UnitPower - | UnitRecord [(String, UnitOfMeasure)] - deriving Data +instance Show UnitParseError where + show (CouldNotParseSpecification ts) = + "Could not parse specification at: \"" ++ show ts ++ "\"\n" + show (NotAnIdentifier c) = "Invalid character in identifier: " ++ show c -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 ++ ")" - show (UnitRecord recs) = "record (" ++ intercalate ", " (map (\ (n, u) -> n ++ " :: " ++ show u) recs) ++ ")" +notAnIdentifier :: Char -> UnitParseError +notAnIdentifier = NotAnIdentifier -data UnitPower = - UnitPowerInteger Integer - | UnitPowerRational Integer Integer - deriving Data +couldNotParseSpecification :: [Token] -> UnitParseError +couldNotParseSpecification = CouldNotParseSpecification -instance Show UnitPower where - show (UnitPowerInteger i) = show i - show (UnitPowerRational i1 i2) = show i1 ++ "/" ++ show i2 +type UnitSpecParser a = Either UnitParseError a data Token = TUnit @@ -131,60 +117,53 @@ | TExponentiation | TDivision | TMinus + | TMult | TEqual | TLeftPar | TRightPar | TRecord | 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 + deriving (Show, Eq) -addToTokens :: Token -> String -> Either AnnotationParseError [ Token ] +addToTokens :: Token -> String -> UnitSpecParser [ Token ] addToTokens tok rest = do - tokens <- lexer' rest + 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) +lexer :: String -> UnitSpecParser [ 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 TMult xs +lexer ('=':xs) = addToTokens TEqual xs +lexer ('(':xs) = addToTokens TLeftPar xs +lexer (')':xs) = addToTokens TRightPar xs +lexer (x:xs) | 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" + | otherwise + = throwError $ notAnIdentifier x where aux p cons = let (target, rest) = span p xs - in lexer' rest >>= (\tokens -> return $ cons (x:target) : tokens) + in lexer rest >>= (\tokens -> return $ cons (x:target) : tokens) -unitParser :: String -> Either AnnotationParseError UnitStatement -unitParser src = do - tokens <- lexer $ map toLower src - parseUnit tokens +unitParser :: SpecParser UnitParseError UnitStatement +unitParser = mkParser (\src -> do + tokens <- lexer $ map toLower src + parseUnit tokens) ["unit"] -happyError :: [ Token ] -> Either AnnotationParseError a -happyError t = failWith $ "Could not parse unit specification at: " ++ show t ++ "\n" +happyError :: [ Token ] -> UnitSpecParser a +happyError = throwError . couldNotParseSpecification } diff --git a/src/Camfort/Specification/Units/Parser/Types.hs b/src/Camfort/Specification/Units/Parser/Types.hs new file mode 100644 --- /dev/null +++ b/src/Camfort/Specification/Units/Parser/Types.hs @@ -0,0 +1,64 @@ +{- | +Module : Camfort.Specification.Units.Parser.Types +Description : Defines the representation of unit specifications resulting from parsing. +Copyright : (c) 2017, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish +License : Apache-2.0 + +Maintainer : dom.orchard@gmail.com +Stability : experimental +-} + +{-# LANGUAGE DeriveDataTypeable #-} + +module Camfort.Specification.Units.Parser.Types + ( UnitStatement(..) + , UnitOfMeasure(..) + , UnitPower(..) + ) where + +import Data.Data (Data) +import Data.List (intercalate) + +data UnitStatement = + UnitAssignment (Maybe [String]) UnitOfMeasure + | UnitAlias String UnitOfMeasure + deriving (Eq, 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 + | UnitRecord [(String, UnitOfMeasure)] + deriving (Data, Eq) + +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 expt) + = show uom ++ "** (" ++ show expt ++ ")" + show (UnitRecord recs) + = "record (" ++ intercalate ", " + (map (\ (n, u) -> n ++ " :: " ++ show u) recs) ++ ")" + +data UnitPower = + UnitPowerInteger Integer + | UnitPowerRational Integer Integer + deriving (Data, Eq) + +instance Show UnitPower where + show (UnitPowerInteger i) = show i + show (UnitPowerRational i1 i2) = show i1 ++ "/" ++ show i2 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,38 +14,25 @@ limitations under the License. -} -{-# LANGUAGE PatternGuards, ScopedTypeVariables, ImplicitParams, DoAndIfThenElse, ConstraintKinds, TupleSections #-} +{-# LANGUAGE PatternGuards, DoAndIfThenElse, ConstraintKinds, ScopedTypeVariables #-} module Camfort.Specification.Units.Synthesis (runSynthesis) where -import Data.Function -import Data.List -import Data.Matrix import Data.Maybe -import Data.Ratio (numerator, denominator) -import qualified Data.Map.Strict as M import qualified Data.Set as S import Data.Generics.Uniplate.Operations import Control.Monad.State.Strict hiding (gets) -import Control.Monad.Reader -import Control.Monad.Writer.Strict -import Control.Monad import qualified Language.Fortran.AST as F 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)] @@ -64,7 +51,7 @@ -- particular, in order to possibly insert a unit annotation before -- them. synthBlock :: Char -> [(VV, UnitInfo)] -> [F.Block UA] -> F.Block UA -> UnitSolver [F.Block UA] -synthBlock marker vars bs b@(F.BlStatement a ss@(FU.SrcSpan lp up) _ (F.StDeclaration _ _ _ _ decls)) = do +synthBlock marker vars bs b@(F.BlStatement a (FU.SrcSpan lp _) _ (F.StDeclaration _ _ _ _ decls)) = do pf <- usProgramFile `fmap` get gvSet <- usGivenVarSet `fmap` get newBs <- fmap catMaybes . forM (universeBi decls) $ \ e -> case e of @@ -75,17 +62,18 @@ 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 (FA.srcName e, u) - let space = FU.posColumn lp - 1 - let newB = F.BlComment newA newSS . F.Comment . insertSpacing pf space $ commentText pf txt + -- Create a zero-length span for the new comment node. + newSS = FU.SrcSpan (lp {FU.posColumn = 0}) (lp {FU.posColumn = 0}) + -- Build the text of the comment with the unit annotation. + txt = marker:" " ++ showUnitDecl (FA.srcName e, u) + space = FU.posColumn lp - 1 + (F.ProgramFile mi _) = pf + newB = F.BlComment newA newSS . F.Comment $ buildCommentText mi space txt return $ Just newB where vname = FA.varName e sname = FA.srcName e - (e :: F.Expression UA) -> return Nothing + (_ :: F.Expression UA) -> return Nothing return (b:reverse newBs ++ bs) synthBlock _ _ bs b = return (b:bs) @@ -99,7 +87,7 @@ -- 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 +synthProgramUnit marker vars pus pu@(F.PUFunction a (FU.SrcSpan lp _) _ _ _ _ mret _ _) = do pf <- usProgramFile `fmap` get gvSet <- usGivenVarSet `fmap` get let (vname, sname) = case mret of Just e -> (FA.varName e, FA.srcName e) @@ -113,9 +101,10 @@ -- 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 + txt = marker:" " ++ showUnitDecl (sname, u) + space = FU.posColumn lp - 1 + (F.ProgramFile mi _) = pf + newPU = F.PUComment newA newSS . F.Comment $ buildCommentText mi space txt -- recursively descend to find program units inside of current one fmap (:newPU:pus) $ descendBiM (synthProgramUnits marker vars) pu @@ -125,17 +114,5 @@ _ -> 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. -commentText :: F.ProgramFile UA -> String -> String -commentText pf text | isModernFortran pf = "!" ++ text - | otherwise = "c" ++ text - --- Insert a given amount of spacing before the string. -insertSpacing :: F.ProgramFile UA -> Int -> String -> String -insertSpacing pf n | isModernFortran pf = (replicate n ' ' ++) - | otherwise = id - -- Pretty print a unit declaration. 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 @@ -15,17 +15,20 @@ -} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module Camfort.Transformation.CommonBlockElim where +module Camfort.Transformation.CommonBlockElim + ( commonElimToModules + ) where import Control.Monad import Control.Monad.State.Lazy +import Control.Monad.Writer.Strict (execWriter, tell) -import Debug.Trace import Data.Data +import Data.Function (on) import Data.List -import Data.Ord import qualified Data.Map as M import Data.Generics.Uniplate.Operations @@ -57,11 +60,14 @@ type A1 = FA.Analysis Annotation type CommonState = State (Report, [TLCommon A]) +-- | Type for type-level annotations giving documentation +type (:?) a (b :: k) = a + -- Top-level functions for eliminating common blocks in a set of files commonElimToModules :: Directory - -> [(Filename, F.ProgramFile A)] - -> (Report, [(Filename, F.ProgramFile A)], [(Filename, F.ProgramFile A)]) + -> [F.ProgramFile A] + -> (Report, [F.ProgramFile A], [F.ProgramFile A]) -- Eliminates common blocks in a program directory (and convert to modules) commonElimToModules d pfs = @@ -72,17 +78,16 @@ (r', pfM) = introduceModules meta d cg pfs'' = updateUseDecls pfs' cg -analyseAndRmCommons :: [(Filename, F.ProgramFile A)] - -> CommonState [(Filename, F.ProgramFile A)] +analyseAndRmCommons :: [F.ProgramFile A] + -> CommonState [F.ProgramFile A] analyseAndRmCommons = mapM analysePerPF -analysePerPF :: - (Filename, F.ProgramFile A) -> CommonState (Filename, F.ProgramFile A) -analysePerPF (fname, pf) = do +analysePerPF :: F.ProgramFile A -> CommonState (F.ProgramFile A) +analysePerPF pf = do let pf' = FA.initAnalysis pf let (pf'', tenv) = FAT.analyseTypes pf' - pf''' <- transformBiM (analysePerPU tenv fname) pf'' - return (fname, fmap FA.prevAnnotation pf''') + pf''' <- transformBiM (analysePerPU tenv (F.pfGetFilename pf)) pf'' + return (fmap FA.prevAnnotation pf''') analysePerPU :: FAT.TypeEnv -> Filename -> F.ProgramUnit A1 -> CommonState (F.ProgramUnit A1) @@ -94,7 +99,7 @@ collectAndRmCommons tenv fname pname = transformBiM commons where commons :: F.Statement A1 -> CommonState (F.Statement A1) - commons f@(F.StCommon a s@(FU.SrcSpan p1 _) cgrps) = do + commons (F.StCommon a s@(FU.SrcSpan p1 _) cgrps) = do mapM_ commonGroups (F.aStrip cgrps) let a' = onPrev (\ap -> ap {refactored = Just p1, deleteNode = True}) a return $ F.StCommon a' (deleteLine s) (F.AList a s []) @@ -105,7 +110,7 @@ -- Process a common group, adding blocks to the common state commonGroups :: F.CommonGroup A1 -> CommonState () - commonGroups (F.CommonGroup a (FU.SrcSpan p1 _) cname exprs) = do + commonGroups (F.CommonGroup _ (FU.SrcSpan p1 _) cname exprs) = do let r' = show p1 ++ ": removed common declaration\n" let tcommon = map typeCommonExprs (F.aStrip exprs) let info = (fname, (punitName pname, (commonNameFromAST cname, tcommon))) @@ -180,6 +185,7 @@ gcs = groupBy (\x y -> cmpEq $ cmpTLConBNames x y) commons -- Group within by the different common block variable-type fields gccs = map (sortBy (\y x -> length x `compare` length y) . group . sortBy cmpVarName) gcs + cmpEq = (== EQ) mkTLCommonRenamers :: [TLCommon A] -> [(TLCommon A, RenamerCoercer)] mkTLCommonRenamers commons = @@ -196,8 +202,8 @@ map (\c -> (c, mkRenamerCoercerTLC c com)) (concat $ tail grp)) gccs -- Now re-sort based on the file and program unit commons' = sortBy (cmpFst cmpTLConFName) (sortBy (cmpFst cmpTLConPName) (concat gcrcs)) + cmpFst = (`on` fst) -type NameMap = M.Map F.Name F.Name -- Nothing represents an overall identity renamer/coercer for efficiency -- a Nothing for a variable represent a variable-level (renamer) identity @@ -205,15 +211,6 @@ type RenamerCoercer = Maybe (M.Map F.Name (Maybe F.Name, Maybe (F.BaseType, F.BaseType))) -applyRenaming :: (Typeable (t A), Data (t A)) => NameMap -> t A -> t A -applyRenaming r = transformBi rename - where - rename :: F.Value A -> F.Value A - rename vn@(F.ValVariable v) = - case M.lookup v r of - Nothing -> vn - Just v' -> F.ValVariable v' - class Renaming r where hasRenaming :: F.Name -> r -> Bool @@ -226,11 +223,12 @@ hasRenaming v = any (hasRenaming v) updateUseDecls :: - [(Filename, F.ProgramFile A)] -> [TLCommon A] -> [(Filename, F.ProgramFile A)] + [F.ProgramFile A] -> [TLCommon A] -> [F.ProgramFile A] updateUseDecls fps tcs = map perPF fps where - perPF (f, p@(F.ProgramFile (F.MetaInfo v _) _)) = - (f, transformBi (importIncludeCommons v) $ transformBi (matchPUnit v f) p) + perPF p@(F.ProgramFile (F.MetaInfo v _) _) = + transformBi (importIncludeCommons v) + $ transformBi (matchPUnit v (F.pfGetFilename p)) p tcrs = mkTLCommonRenamers tcs inames :: F.Statement A -> Maybe String @@ -241,6 +239,14 @@ importIncludeCommons v p = foldl (flip (matchPUnit v)) p (reduceCollect inames p) + -- Data-type generic reduce traversal + reduceCollect :: (Data s, Data t, Uniplate t, Biplate t s) => (s -> Maybe a) -> t -> [a] + reduceCollect k x = execWriter (transformBiM (\y -> do case k y of + Just x -> tell [x] + Nothing -> return () + return y) x) + + insertUses :: [F.Block A] -> F.ProgramUnit A -> F.ProgramUnit A insertUses uses = descendBi insertUses' where insertUses' :: [F.Block A] -> [F.Block A] @@ -254,11 +260,17 @@ F.Named pname -> pname -- If no subname is available, use the filename _ -> fname - tcrs' = lookups' pname (lookups' fname tcrs) + tcrs' = lookups pname (lookups fname tcrs) pos = getUnitStartPosition p uses = mkUseStatementBlocks pos tcrs' p' = insertUses uses p + -- Lookup functions over relation s + lookups :: Eq a => a -> [((a, b), c)] -> [(b, c)] + lookups x = map (\((_,b),c) -> (b, c)) + . filter ((==x) . fst . fst) + + -- Given the list of renamed/coercerd variables form common blocks, -- remove any declaration sites removeDecls :: PM.FortranVersion -> [RenamerCoercer] -> F.ProgramUnit A -> F.ProgramUnit A @@ -271,7 +283,7 @@ -- statements) removeDecl :: [RenamerCoercer] -> F.Statement A -> State [F.Statement A] (F.Statement A) - removeDecl rcs d@(F.StDeclaration a s@(FU.SrcSpan p1 _) typ attr decls) = do + removeDecl rcs (F.StDeclaration a s@(FU.SrcSpan p1 _) typ attr decls) = do modify (++ assgns) return $ F.StDeclaration a' (deleteLine s) typ attr decls' where @@ -288,8 +300,8 @@ matchVar :: ([F.Statement A], [F.Declarator A]) -> F.Declarator A -> ([F.Statement A], [F.Declarator A]) matchVar (assgns, decls) - dec@(F.DeclVariable a s - lvar@(F.ExpValue _ _ (F.ValVariable v)) len init) = + dec@(F.DeclVariable _ s + lvar@(F.ExpValue _ _ (F.ValVariable v)) _ init) = if hasRenaming v rcs then case init of -- Renaming exists and no default, then remove @@ -339,7 +351,7 @@ renamerToUse :: RenamerCoercer -> [(F.Name, F.Name)] renamerToUse Nothing = [] -renamerToUse (Just m) = let entryToPair v (Nothing, _) = [] +renamerToUse (Just m) = let entryToPair _ (Nothing, _) = [] entryToPair v (Just v', _) = [(v, v')] in M.foldlWithKey (\xs v e -> entryToPair v e ++ xs) [] m @@ -350,7 +362,7 @@ a = unitAnnotation { refactored = Just pos, newNode = True } (FU.SrcSpan pos pos') = s s' = FU.SrcSpan (toCol0 pos) pos' - mkUseStmnt x@((name, _), r) = F.BlStatement a s' Nothing $ + mkUseStmnt x@((name, _), _) = F.BlStatement a s' Nothing $ F.StUse a s' useName F.Permissive useListA where useName = F.ExpValue a s' (F.ValVariable (caml (commonName name))) useListA = case useList of [] -> Nothing @@ -358,13 +370,13 @@ useList = mkUses pos x mkUses :: FU.Position -> (TCommon A, RenamerCoercer) -> [F.Use A] - mkUses s ((name, _), r) = map useRenamer (renamerToUse r) + mkUses _ ((_, _), r) = map useRenamer (renamerToUse r) useRenamer (v, vR) = F.UseRename a s' (F.ExpValue a s' (F.ValVariable v)) (F.ExpValue a s' (F.ValVariable vR)) mkRenamerCoercerTLC :: TLCommon A :? source -> TLCommon A :? target -> RenamerCoercer -mkRenamerCoercerTLC x@(fname, (pname, common1)) (_, (_, common2)) = +mkRenamerCoercerTLC (_, (_, common1)) (_, (_, common2)) = mkRenamerCoercer common1 common2 mkRenamerCoercer :: TCommon A :? source -> TCommon A :? target -> RenamerCoercer @@ -387,9 +399,15 @@ allCoherentCommons commons = foldM (\p (c1, c2) -> coherentCommons c1 c2 >>= \p' -> return $ p && p') True (pairs commons) + where + -- Computes all pairwise combinations + pairs :: [a] -> [(a, a)] + pairs [] = [] + pairs (x:xs) = zip (repeat x) xs ++ pairs xs + coherentCommons :: TLCommon A -> TLCommon A -> (Report, Bool) -coherentCommons (f1, (p1, (n1, vtys1))) (f2, (p2, (n2, vtys2))) = +coherentCommons (_, (_, (n1, vtys1))) (_, (_, (n2, vtys2))) = if n1 == n2 then coherentCommons' vtys1 vtys2 else error $ "Trying to compare differently named common blocks: " @@ -411,16 +429,17 @@ -- TODO - give more information in the error coherentCommons' _ _ = ("Common blocks of different field lengths", False) -introduceModules :: - F.MetaInfo -> Directory -> [TLCommon A] - -> (Report, [(Filename, F.ProgramFile A)]) +introduceModules :: F.MetaInfo + -> Directory + -> [TLCommon A] + -> (Report, [F.ProgramFile A]) introduceModules meta dir cenv = mapM (mkModuleFile meta dir . head . head) (groupSortCommonBlock cenv) mkModuleFile :: - F.MetaInfo -> Directory -> TLCommon A -> (Report, (Filename, F.ProgramFile A)) + F.MetaInfo -> Directory -> TLCommon A -> (Report, F.ProgramFile A) mkModuleFile meta dir (_, (_, (name, varTys))) = - (r, (path, F.pfSetFilename path $ F.ProgramFile meta [mod])) + (r, 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 deleted file mode 100644 --- a/src/Camfort/Transformation/DataTypeIntroduction.hs +++ /dev/null @@ -1,104 +0,0 @@ -{- - 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/Camfort/Transformation/DeadCode.hs b/src/Camfort/Transformation/DeadCode.hs --- a/src/Camfort/Transformation/DeadCode.hs +++ b/src/Camfort/Transformation/DeadCode.hs @@ -16,7 +16,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} -module Camfort.Transformation.DeadCode where +module Camfort.Transformation.DeadCode + ( deadCode + ) where import Camfort.Analysis.Annotations import qualified Language.Fortran.Analysis.DataFlow as FAD @@ -32,20 +34,17 @@ import qualified Data.Set as S import Data.Generics.Uniplate.Operations import Data.Maybe -import GHC.Generics -import Debug.Trace -- Eliminate dead code from a program, based on the fortran-src -- live-variable analysis -- Currently only strips out dead code through simple variable assignments -- but not through array-subscript assignmernts -deadCode :: Bool -> (Filename, F.ProgramFile A) - -> (Report, (Filename, F.ProgramFile A)) -deadCode flag (fname, pf) = (report, (fname, fmap FA.prevAnnotation pf')) +deadCode :: Bool -> F.ProgramFile A -> (Report, F.ProgramFile A) +deadCode flag pf = (report, fmap FA.prevAnnotation pf') where - (report, pf'') = deadCode' flag lva pf' + (report, _) = deadCode' flag lva pf' -- initialise analysis pf' = FAB.analyseBBlocks . FAR.analyseRenames . FA.initAnalysis $ pf -- get map of program unit ==> basic block graph @@ -71,7 +70,7 @@ perStmt :: Bool -> FAD.InOutMap (S.Set F.Name) -> F.Statement (FA.Analysis A) -> (Report, F.Statement (FA.Analysis A)) -perStmt flag lva x@(F.StExpressionAssign a sp@(FU.SrcSpan s1 s2) e1 e2) +perStmt flag lva x@(F.StExpressionAssign a sp@(FU.SrcSpan s1 _) e1 e2) | pRefactored (FA.prevAnnotation a) == flag = fromMaybe ("", x) $ do label <- FA.insLabel a diff --git a/src/Camfort/Transformation/EquivalenceElim.hs b/src/Camfort/Transformation/EquivalenceElim.hs --- a/src/Camfort/Transformation/EquivalenceElim.hs +++ b/src/Camfort/Transformation/EquivalenceElim.hs @@ -16,9 +16,10 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} -module Camfort.Transformation.EquivalenceElim where +module Camfort.Transformation.EquivalenceElim + ( refactorEquivalences + ) where -import Data.Data import Data.List import qualified Data.Map as M import Data.Generics.Uniplate.Operations @@ -30,20 +31,17 @@ import qualified Language.Fortran.Analysis.Renaming as FAR import qualified Language.Fortran.Analysis as FA -import Camfort.Output import Camfort.Helpers import Camfort.Helpers.Syntax import Camfort.Analysis.Annotations import Camfort.Transformation.DeadCode -import Debug.Trace type A1 = FA.Analysis Annotation type RmEqState = ([[F.Expression A1]], Int, Report) -refactorEquivalences :: - (Filename, F.ProgramFile A) -> (Report, (Filename, F.ProgramFile A)) -refactorEquivalences (fname, pf) = do +refactorEquivalences :: F.ProgramFile A -> (Report, F.ProgramFile A) +refactorEquivalences pf = do -- initialise analysis let pf' = FAR.analyseRenames . FA.initAnalysis $ pf -- calculate types @@ -53,7 +51,7 @@ -- Lastly deadcode eliminate any redundant copy statements -- generated by the refactoring (but don't dead code elim -- existing code) - deadCode True (fname, fmap FA.prevAnnotation pf''') + deadCode True (fmap FA.prevAnnotation pf''') where refactoring :: FAT.TypeEnv -> F.ProgramFile A1 -> (Report, F.ProgramFile A1) refactoring tenv pf = (report, pf') @@ -69,8 +67,8 @@ return $ concat blockss addCopysPerBlock :: FAT.TypeEnv -> F.Block A1 -> State RmEqState [F.Block A1] -addCopysPerBlock tenv x@(F.BlStatement a0 s0 lab - (F.StExpressionAssign a sp@(FU.SrcSpan s1 s2) dstE srcE)) +addCopysPerBlock tenv x@(F.BlStatement _ _ _ + (F.StExpressionAssign a sp@(FU.SrcSpan s1 _) dstE _)) | not (pRefactored $ FA.prevAnnotation a) = do -- Find all variables/cells that are equivalent to the target -- of this assignment @@ -132,7 +130,7 @@ argst = Just (F.AList a sp args) args = map (F.Argument a sp Nothing) [srcE', dstE'] -- Types are equal, simple a assignment - Just t -> F.StExpressionAssign a sp dstE' srcE' + Just _ -> F.StExpressionAssign a sp dstE' srcE' where -- Set position to be at col = 0 sp = FU.SrcSpan (toCol0 pos) (toCol0 pos) @@ -146,7 +144,7 @@ perBlockRmEquiv = transformBiM perStatementRmEquiv perStatementRmEquiv :: F.Statement A1 -> State RmEqState (F.Statement A1) -perStatementRmEquiv f@(F.StEquivalence a sp@(FU.SrcSpan spL spU) equivs) = do +perStatementRmEquiv (F.StEquivalence a sp@(FU.SrcSpan spL _) equivs) = do (ess, n, r) <- get let report = r ++ show spL ++ ": removed equivalence \n" put (((map F.aStrip) . F.aStrip $ equivs) ++ ess, n - 1, r ++ report) @@ -161,7 +159,7 @@ (equivs, _, _) <- get return (inGroup x equivs) where - inGroup x [] = [] + inGroup _ [] = [] inGroup x (xs:xss) = if AnnotationFree x `elem` map AnnotationFree xs then xs diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -15,139 +15,367 @@ {-# LANGUAGE DoAndIfThenElse #-} -module Main where - -import System.Console.GetOpt -import System.Environment +module Main (main) where -import Camfort.Helpers +import Camfort.Input (defaultValue) import Camfort.Functionality +import Camfort.Specification.Stencils.InferenceFrontend (InferMode(..)) +import Camfort.Specification.Units.Monad (LiteralsOpt(LitMixed)) -import Data.Text (pack, unpack, split) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) -{-| The entry point to CamFort. Displays user information, and - handlers which functionality is being requested -} -main = do - args <- getArgs - putStrLn "" - if length args >= 2 then +import Options.Applicative - let (func : (inp : _)) = args - in case lookup func functionality of - Just (fun, _) -> do - (opts, _) <- compilerOpts args - (numReqArgs, outp) <- - 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." +-- | Commands supported by CamFort. +data Command = CmdCount ReadOptions + | CmdAST ReadOptions + | CmdStencilsCheck ReadOptions + | CmdStencilsInfer StencilsOptions + | CmdStencilsSynth StencilsSynthOptions + | CmdUnitsSuggest UnitsOptions + | CmdUnitsCheck UnitsOptions + | CmdUnitsInfer UnitsOptions + | CmdUnitsSynth UnitsSynthOptions + | CmdUnitsCompile UnitsWriteOptions + | CmdRefactCommon RefactOptions + | CmdRefactDead RefactOptions + | CmdRefactEquivalence RefactOptions + | CmdTopVersion - let excluded_files = map unpack . split (==',') . pack . getExcludes - fun inp (excluded_files opts) outp opts - Nothing -> putStrLn fullUsageInfo - else do - putStrLn introMsg - if length args == 1 - then putStrLn $ usage ++ "Please specify an input file/directory" - else putStrLn fullUsageInfo +-- | Options for reading files. +data ReadOptions = ReadOptions + { inputSource :: String + , exclude :: Maybe [String] + } --- * Options for CamFort and information on the different modes -fullUsageInfo = usageInfo (usage ++ menu ++ "\nOptions:") options +-- | Options for writing to files. +-- +-- User can choose to either specify which file to write, or have +-- the input files be written over. +data WriteOptions = WriteFile { _outputFile :: String } + | WriteInplace -options :: [OptDescr Flag] -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") - "units-of-measure literals mode. ID = Unitless, Poly, or Mixed" - , 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) - "synthesise annotations compatible with Doxygen" - , Option [] ["ford"] (NoArg Ford) - "synthesise annotations compatible with Ford" - ] -compilerOpts :: [String] -> IO ([Flag], [String]) -compilerOpts argv = - case getOpt Permute options argv of - (o,n,[] ) -> return (o,n) - (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) - where header = introMsg ++ usage ++ menu ++ "\nOptions:" +-- | Options used by stencil commands. +data StencilsOptions = StencilsOptions + { soReadOptions :: ReadOptions + , soInferMode :: InferMode + } --- * Which modes do not require an output -outputNotRequired = ["count", "ast" - , "stencils-infer", "stencils-check" - , "units-infer", "units-check", "units-suggest"] -functionality = analyses ++ refactorings +-- | Options used by all unit commands. +data UnitsOptions = UnitsOptions + { uoReadOptions :: ReadOptions + , literals :: LiteralsOpt + , debug :: Bool + , includeDir :: Maybe String + } -{-| List of refactorings provided in CamFort -} -refactorings :: [(String - , (FileOrDir -> [Filename] -> FileOrDir -> Options -> IO () - , String))] -refactorings = - [("common", (common, "common block elimination")), - ("equivalence", (equivalences, "equivalence elimination")), - ("dead", (dead, "dead-code elimination")), - ("datatype", (datatypes, "derived data type introduction"))] -{-| List of analses provided by CamFort -} -analyses :: [(String - , (FileOrDir -> [Filename] -> FileOrDir -> Options -> IO () - , String))] -analyses = - [ - ("count", (countVarDecls, "count variable declarations")), - ("ast", (ast, "print the raw AST -- for development purposes")), - ("stencils-check", (stencilsCheck, "stencil spec checking")), - ("stencils-infer", (stencilsInfer, "stencil spec inference")), - ("stencils-synth", (stencilsSynth, "stencil spec synthesis")), - ("units-suggest", (unitsCriticals, - "suggest variables to annotate with\ - \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-compile", (unitsCompile, "units-of-measure compile module information.")) ] +data UnitsWriteOptions = UnitsWriteOptions + { uwoUnitsOptions :: UnitsOptions + , uwoWriteOptions :: WriteOptions + } --- * Usage and about information -version = "0.902" -introMsg = "CamFort " ++ version ++ " - Cambridge Fortran Infrastructure." -usage = "Usage: camfort [OUTPUT] [OPTIONS...]\n" -menu = - "Refactor functions:\n" - ++ concatMap (\(k, (_, info)) -> space ++ k ++ replicate (15 - length k) ' ' - ++ " [" ++ info ++ "] \n") refactorings - ++ "\nAnalysis functions:\n" - ++ concatMap (\(k, (_, info)) -> space ++ k ++ replicate (15 - length k) ' ' - ++ " [" ++ info ++ "] \n") analyses - where space = replicate 5 ' ' + +newtype AnnotationOptions = + AnnotationOptions { annotationType :: AnnotationType } + + +data UnitsSynthOptions = UnitsSynthOptions + { usoUnitsWriteOptions :: UnitsWriteOptions + , usoAnnotationOptions :: AnnotationOptions + } + + +data StencilsSynthOptions = StencilsSynthOptions + { ssoStencilsOptions :: StencilsOptions + , ssoWriteOptions :: WriteOptions + , ssoAnnotationOptions :: AnnotationOptions + } + + +-- | Options used by refactoring commands. +data RefactOptions = RefactOptions + { rfoReadOptions :: ReadOptions + , rfoWriteOptions :: WriteOptions + } + + +-- | Parser for an argument representing an individual file or directory. +fileArgument :: Mod ArgumentFields String -> Parser String +fileArgument m = strArgument (metavar "FILENAME" <> action "file" <> m) + + +-- | Parser for file options with multiple files specified +-- | as a comma-separated list. +multiFileOption :: Mod OptionFields [String] -> Parser [String] +multiFileOption m = option (list str) + (metavar "FILE..." <> action "file" <> m) + where list :: ReadM String -> ReadM [String] + list = fmap (splitBy ',') + splitBy _ [] = [] + splitBy c xs = case break (==c) xs of + (xs', []) -> [xs'] + (xs', _:cs) -> xs' : splitBy c cs + + +excludeOption :: Parser (Maybe [String]) +excludeOption = optional $ multiFileOption $ + long "exclude" + <> short 'e' + <> help "files to exclude (comma separated list, no spaces)" + + +-- | Parse options for 'ReadOptions'. +readOptions :: Parser ReadOptions +readOptions = fmap ReadOptions + (fileArgument $ help "input file") + <*> excludeOption + + +-- | User must specify either an ouput file, or say that the file +-- | should be rewritten in place. +writeOptions :: Parser WriteOptions +writeOptions = (fmap WriteFile . fileArgument $ + help "file to write output to") + <|> (pure WriteInplace <* flag' () + ( long "inplace" + <> help "write in place (replaces input files)")) + + +stencilsOptions :: Parser StencilsOptions +stencilsOptions = fmap StencilsOptions + readOptions <*> evalOption + where + evalOption = flag AssignMode EvalMode + ( long "eval" + <> help "provide additional evaluation reporting" + <> internal) + + +stencilsSynthOptions :: Parser StencilsSynthOptions +stencilsSynthOptions = fmap StencilsSynthOptions + stencilsOptions <*> writeOptions <*> annotationOptions + + +unitsOptions :: Parser UnitsOptions +unitsOptions = fmap UnitsOptions + readOptions + <*> literalsOption + <*> debugOption + <*> optional includeDirOption + where + literalsOption = option parseLiterals $ + long "units-literals" + <> short 'l' + <> metavar "ID" + <> completeWith ["Unitless", "Poly", "Mixed"] + <> value LitMixed + <> help "units-of-measure literals mode. ID = Unitless, Poly, or Mixed" + parseLiterals = fmap read str + debugOption = switch (long "debug" <> help "enable debug mode") + dirOption m = strOption (metavar "DIR" <> action "directory" <> m) + includeDirOption = dirOption + ( long "include-dir" + <> short 'I' + <> help "directory to search for precompiled files") + + +unitsWriteOptions :: Parser UnitsWriteOptions +unitsWriteOptions = fmap UnitsWriteOptions + unitsOptions <*> writeOptions + + +annotationOptions :: Parser AnnotationOptions +annotationOptions = fmap AnnotationOptions $ + flag ATDefault Doxygen + (long "doxygen" <> help "synthesise annotations compatible with Doxygen") + <|> flag ATDefault Ford + (long "ford" <> help "synthesise annotations compatible with Ford") + + +unitsSynthOptions :: Parser UnitsSynthOptions +unitsSynthOptions = fmap UnitsSynthOptions + unitsWriteOptions <*> annotationOptions + + +refactOptions :: Parser RefactOptions +refactOptions = fmap RefactOptions + readOptions <*> writeOptions + + +cmdCount, cmdAST :: Parser Command +cmdCount = fmap CmdCount readOptions +cmdAST = fmap CmdAST readOptions + + +cmdStencilsCheck, cmdStencilsInfer, cmdStencilsSynth :: Parser Command +cmdStencilsCheck = fmap CmdStencilsCheck readOptions +cmdStencilsInfer = fmap CmdStencilsInfer stencilsOptions +cmdStencilsSynth = fmap CmdStencilsSynth stencilsSynthOptions + + +cmdUnitsSuggest, cmdUnitsCheck, cmdUnitsInfer + , cmdUnitsSynth, cmdUnitsCompile :: Parser Command +cmdUnitsSuggest = fmap CmdUnitsSuggest unitsOptions +cmdUnitsCheck = fmap CmdUnitsCheck unitsOptions +cmdUnitsInfer = fmap CmdUnitsInfer unitsOptions +cmdUnitsSynth = fmap CmdUnitsSynth unitsSynthOptions +cmdUnitsCompile = fmap CmdUnitsCompile unitsWriteOptions + + +cmdRefactCommon, cmdRefactDead, cmdRefactEquivalence :: Parser Command +cmdRefactCommon = fmap CmdRefactCommon refactOptions +cmdRefactDead = fmap CmdRefactDead refactOptions +cmdRefactEquivalence = fmap CmdRefactEquivalence refactOptions + +-- | Helper for building a command alias. +-- +-- Command aliases will not show up in the help text, nor be subject to completion. +commandAlias :: String -> Parser Command -> Mod CommandFields Command +commandAlias alias cmdParser = command alias . info cmdParser $ mempty + +-- | Helper for building a parser for a group of commands. +commandsParser :: String -> [(String, [String], Parser Command, String)] -> Parser Command +commandsParser groupName commands = + hsubparser (mconcat (fmap + (\(name, _, cmdParser, description) -> + (command name . info cmdParser . progDesc $ description)) + commands) + <> commandGroup groupName) + <|> aliasSubParser + where aliasSubParser = subparser $ + mconcat (fmap + (\(_, aliases, cmdParser, _) -> + mconcat $ fmap (`commandAlias` cmdParser) aliases) + commands) + <> internal + +analysesParser :: Parser Command +analysesParser = commandsParser "Analysis Commands" analysesCommands + where + analysesCommands = + [ ("count", + [], + cmdCount, "count variable declarations") + , ("ast", + [], + cmdAST, "print the raw AST -- for development purposes") + , ("stencils-check", + ["stencil-check", "check-stencils", "check-stencil"], + cmdStencilsCheck, "stencil spec checking") + , ("stencils-infer", + ["stencil-infer", "infer-stencils", "infer-stencil"], + cmdStencilsInfer, "stencil spec inference") + , ("stencils-synth", + ["stencil-synth", "synth-stencils", "synth-stencil"], + cmdStencilsSynth, "stencil spec synthesis") + , ("units-suggest", + ["unit-suggest", "suggest-units", "suggest-unit"], + cmdUnitsSuggest, "suggest variables to annotate with units-of-measure for maximum coverage") + , ("units-check", + ["unit-check", "check-units", "check-unit"], + cmdUnitsCheck, "unit-of-measure checking") + , ("units-infer", + ["unit-infer", "infer-units", "infer-unit"], + cmdUnitsInfer, "unit-of-measure inference") + , ("units-synth", + ["unit-synth", "synth-units", "synth-unit"], + cmdUnitsSynth, "unit-of-measure synthesise specs") + , ("units-compile", + ["unit-compile", "compile-units", "compile-unit"], + cmdUnitsCompile, "units-of-measure compile module information") ] + + +refactoringsParser :: Parser Command +refactoringsParser = commandsParser "Refactoring Commands" refactoringsCommands + where + refactoringsCommands = + [ ("common", [], cmdRefactCommon, "common block elimination") + , ("equivalence", [], cmdRefactEquivalence, "equivalence elimination") + , ("dead", [], cmdRefactDead, "dead-code elimination") ] + + +topLevelCommands :: Parser Command +topLevelCommands = versionOption + where versionOption = pure CmdTopVersion <* switch + ( long "version" + <> short 'v' + <> short '?' + <> help "show version number") + + +-- | Collective parser for all CamFort commands. +commandParser :: Parser Command +commandParser = + helper <*> (analysesParser <|> refactoringsParser <|> topLevelCommands) + + +main :: IO () +main = do + cmd <- execParser (info commandParser idm) + runCommand cmd + where + getExcludes = fromMaybe [] . exclude + getOutputFile _ (WriteFile f) = f + getOutputFile inp WriteInplace = inp + runRO ro f = f (inputSource ro) (getExcludes ro) + runSO so f = + runRO (soReadOptions so) f (soInferMode so) + runSSO sso f = + let ao = ssoAnnotationOptions sso + wo = ssoWriteOptions sso + so = ssoStencilsOptions sso + ro = soReadOptions so + inFile = inputSource ro + in runSO so f (annotationType ao) (getOutputFile inFile wo) + runUO uo f = + let ro = uoReadOptions uo + in runRO ro f (literals uo) (debug uo) (includeDir uo) + runUWO uwo f = + let uo = uwoUnitsOptions uwo + ro = uoReadOptions uo + wo = uwoWriteOptions uwo + inFile = inputSource ro + in runUO uo f (getOutputFile inFile wo) + runUSO uso f = + let uwo = usoUnitsWriteOptions uso + ao = usoAnnotationOptions uso + in runUWO uwo f (annotationType ao) + runRFO rfo f = + let ro = rfoReadOptions rfo + wo = rfoWriteOptions rfo + inFile = inputSource ro + in runRO ro f (getOutputFile inFile wo) + runCommand (CmdAST ro) = runRO ro ast + runCommand (CmdCount ro) = runRO ro countVarDecls + runCommand (CmdStencilsCheck ro) = runRO ro stencilsCheck + runCommand (CmdStencilsInfer so) = runSO so stencilsInfer + runCommand (CmdStencilsSynth sso) = runSSO sso stencilsSynth + runCommand (CmdUnitsSuggest uo) = runUO uo unitsCriticals + runCommand (CmdUnitsCheck uo) = runUO uo unitsCheck + runCommand (CmdUnitsInfer uo) = runUO uo unitsInfer + runCommand (CmdUnitsSynth uso) = runUSO uso unitsSynth + runCommand (CmdUnitsCompile uwo) = runUWO uwo unitsCompile + runCommand (CmdRefactCommon rfo) = runRFO rfo common + runCommand (CmdRefactDead rfo) = runRFO rfo dead + runCommand (CmdRefactEquivalence rfo) = runRFO rfo equivalences + runCommand CmdTopVersion = displayVersion + + +-- | Current CamFort version. +version = "0.903" + + +-- | Full CamFort version string. +versionMessage = "CamFort " ++ version ++ " - Cambridge Fortran Infrastructure." + + +-- | Print the full version string. +displayVersion :: IO () +displayVersion = putStrLn versionMessage 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 @@ -8,7 +8,7 @@ import Test.Hspec import Data.Data -import Data.Generics.Uniplate.Data +import Control.Monad.Identity (runIdentity) import Control.Monad.Writer.Strict import Language.Fortran.AST @@ -16,29 +16,35 @@ import Language.Fortran.Util.Position import Camfort.Analysis.CommentAnnotator +import Camfort.Specification.Parser (mkParser, parseError, SpecParser) p = SrcSpan (Position 0 1 1) (Position 0 1 1) +annotateWith :: (String -> String) -> ProgramFile A -> ProgramFile A +annotateWith s = runIdentity . annotateComments trivialParser ignore + where trivialParser = mkParser (Right . s) [] + ignore = const . const . pure $ () + spec = describe "Comment annotator" $ do it "annotates with no comment blocks" $ - runWriter (annotateComments (\_ -> Right "") pf) `shouldBe` (pf, []) + annotateWith (const "") pf `shouldBe` pf it "links & annotates single comment block" $ - runWriter (annotateComments (\_ -> Right "hello") pf2) `shouldBe` (pf2e, []) + annotateWith (const "hello") pf2 `shouldBe` pf2e it "link multiple comments to single statement" $ - runWriter (annotateComments (\s -> Right $ "!!!" ++ s) pf3) `shouldBe` (pf3e, []) + annotateWith ("!!!"++) pf3 `shouldBe` pf3e it "link comments to separate targets" $ - runWriter (annotateComments (\s -> Right $ "!!!" ++ s) pf4) `shouldBe` (pf4e, []) + annotateWith ("!!!"++) pf4 `shouldBe` pf4e - it "generates warnings when there is a partial match" $ do - let parser _ = Left $ ProbablyAnnotation "This is a warning." - :: Either AnnotationParseError String - shouldBe (runWriter (annotateComments parser pf5)) - (pf5e, [ "Error (1:1)-(1:1): This is a warning." - , "Error (1:1)-(1:1): This is a warning." ]) + it "allows handling of parse errors" $ do + let parser :: SpecParser String String + parser = mkParser (const $ Left "This is a warning.") [] + shouldBe (runWriter (annotateComments parser (\srcSpan err -> tell [(srcSpan, err)]) pf5)) + (pf5e, [ (initSrcSpan, parseError "This is a warning.") + , (initSrcSpan, parseError "This is a warning.")]) data A = A { annLink :: Maybe (Block A) @@ -60,6 +66,9 @@ -- Test cases +mkComment :: String -> Comment a +mkComment = Comment . ("= "++) + ea = A Nothing Nothing pf = wrapBlocks bs @@ -67,56 +76,56 @@ pf2 = wrapBlocks bs2 bs2 = - [ BlComment ea p (Comment "something") + [ BlComment ea p (mkComment "something") , BlStatement ea p Nothing (StPause ea p Nothing) ] pf2e = wrapBlocks bs2e bs2e = - [ BlComment (A (Just (bs2e !! 1)) (Just "hello")) p (Comment "something") + [ BlComment (A (Just (bs2e !! 1)) (Just "hello")) p (mkComment "something") , BlStatement ea p Nothing (StPause ea p Nothing) ] pf3 = wrapBlocks bs3 bs3 = - [ BlComment ea p (Comment "mistral") - , BlComment ea p (Comment "orhan") - , BlComment ea p (Comment "jean-pierre") - , BlComment ea p (Comment "contrastin") + [ BlComment ea p (mkComment "mistral") + , BlComment ea p (mkComment "orhan") + , BlComment ea p (mkComment "jean-pierre") + , BlComment ea p (mkComment "contrastin") , BlStatement ea p Nothing (StPause ea p Nothing) ] pf3e = wrapBlocks bs3e bs3e = - [ 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") + [ BlComment (A (Just (last bs3e)) (Just "!!!mistral")) p (mkComment "mistral") + , BlComment (A (Just (last bs3e)) (Just "!!!orhan")) p (mkComment "orhan") + , BlComment (A (Just (last bs3e)) (Just "!!!jean-pierre")) p (mkComment "jean-pierre") + , BlComment (A (Just (last bs3e)) (Just "!!!contrastin")) p (mkComment "contrastin") , BlStatement ea p Nothing (StPause ea p Nothing) ] pf4 = wrapBlocks bs4 bs4 = - [ BlComment ea p (Comment "mistral") - , BlComment ea p (Comment "contrastin") + [ BlComment ea p (mkComment "mistral") + , BlComment ea p (mkComment "contrastin") , BlStatement ea p Nothing (StPause ea p Nothing) - , BlComment ea p (Comment "dominic") - , BlComment ea p (Comment "orchard") + , BlComment ea p (mkComment "dominic") + , BlComment ea p (mkComment "orchard") , BlStatement ea p Nothing (StExpressionAssign ea p (varGen "x") (intGen 42)) ] pf4e = wrapBlocks bs4e bs4e = - [ BlComment (A (Just (bs4e !! 2)) (Just "!!!mistral")) p (Comment "mistral") - , BlComment (A (Just (bs4e !! 2)) (Just "!!!contrastin")) p (Comment "contrastin") + [ BlComment (A (Just (bs4e !! 2)) (Just "!!!mistral")) p (mkComment "mistral") + , BlComment (A (Just (bs4e !! 2)) (Just "!!!contrastin")) p (mkComment "contrastin") , BlStatement ea p Nothing (StPause ea p Nothing) - , BlComment (A (Just (last bs4e)) (Just "!!!dominic")) p (Comment "dominic") - , BlComment (A (Just (last bs4e)) (Just "!!!orchard")) p (Comment "orchard") + , BlComment (A (Just (last bs4e)) (Just "!!!dominic")) p (mkComment "dominic") + , BlComment (A (Just (last bs4e)) (Just "!!!orchard")) p (mkComment "orchard") , BlStatement ea p Nothing (StExpressionAssign ea p (varGen "x") (intGen 42)) ] pf5 = wrapBlocks bs5 bs5 = - [ BlComment ea p (Comment "comment 1") - , BlComment ea p (Comment "comment 2") + [ BlComment ea p (mkComment "comment 1") + , BlComment ea p (mkComment "comment 2") , BlStatement ea p Nothing (StPause ea p Nothing) ] pf5e = wrapBlocks bs5e bs5e = - [ BlComment (A (Just (last bs5e)) Nothing) p (Comment "comment 1") - , BlComment (A (Just (last bs5e)) Nothing) p (Comment "comment 2") + [ BlComment (A (Just (last bs5e)) Nothing) p (mkComment "comment 1") + , BlComment (A (Just (last bs5e)) Nothing) p (mkComment "comment 2") , BlStatement ea p Nothing (StPause ea p Nothing) ] diff --git a/tests/Camfort/Specification/ParserSpec.hs b/tests/Camfort/Specification/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Camfort/Specification/ParserSpec.hs @@ -0,0 +1,40 @@ +module Camfort.Specification.ParserSpec (spec) where + +import Data.Either (isLeft) + +import Test.Hspec hiding (Spec) +import qualified Test.Hspec as Test + +import Camfort.Specification.Parser (looksLikeASpec, mkParser, runParser, SpecParser) + +trivialParser :: SpecParser String String +trivialParser = mkParser Right ["test"] + +canParseTo :: SpecParser String String -> String -> String -> Expectation +canParseTo p s e = runParser p s `shouldBe` Right e + +parsesTriviallyTo :: String -> String -> Expectation +parsesTriviallyTo = canParseTo trivialParser + +doesNotParse :: String -> Expectation +doesNotParse s = runParser trivialParser s `shouldSatisfy` isLeft + +spec :: Test.Spec +spec = do + describe "specification characters" $ do + let expectedSupportedChars = "!=<>" + mapM_ + (\c -> it ("supports " ++ show c) ((c:" test") `parsesTriviallyTo` "test")) + expectedSupportedChars + it "allows whitespace before specification character" $ + " = test" `parsesTriviallyTo` "test" + it "requires a specification character" $ + doesNotParse "" + it "does not accept specifications starting with invalid characters" $ + doesNotParse "c test" + describe "specification keywords" $ do + let testParser = mkParser Right [] + it "does not require any to be present (parsing)" $ + canParseTo testParser "= test" "test" + it "does not require any to be present (checking)" $ + looksLikeASpec testParser "= test" `shouldBe` True 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 @@ -2,23 +2,31 @@ module Camfort.Specification.Stencils.CheckSpec (spec) where -import Camfort.Analysis.CommentAnnotator +import qualified Data.ByteString.Internal as BS + +import Camfort.Analysis.Annotations (unitAnnotation) +import Camfort.Specification.Parser (runParser) import Camfort.Specification.Stencils.CheckBackend import Camfort.Specification.Stencils.CheckFrontend -import qualified Camfort.Specification.Stencils.Grammar as SYN + (CheckResult, stencilChecking) +import Camfort.Specification.Stencils.Parser (specParser) import Camfort.Specification.Stencils.Model import Camfort.Specification.Stencils.Syntax -import Test.Hspec +import qualified Language.Fortran.Analysis as FA +import qualified Language.Fortran.Analysis.BBlocks as FAB +import qualified Language.Fortran.Analysis.Renaming as FAR +import Language.Fortran.Parser.Any (fortranParser) +import qualified Language.Fortran.Util.Position as FU -promoteErrors :: Either String x -> Either AnnotationParseError x -promoteErrors (Left x) = Left (ProbablyAnnotation x) -promoteErrors (Right x) = Right x +import Test.Hspec +parseAndConvert :: String -> Either SynToAstError (Either RegionDecl SpecDecl) parseAndConvert x = let ?renv = [] - in SYN.specParser x >>= (promoteErrors . synToAst) -extract (Right (Right [(_, s)])) = s + in case runParser specParser x of + Left _ -> error "received stencil with invalid syntax in test" + Right v -> synToAst v spec :: Spec spec = @@ -27,39 +35,160 @@ it "parse and convert simple exact stencil (1)" $ parseAndConvert "= stencil forward(depth=1, dim=1) :: x" `shouldBe` - (Right $ Right [(["x"], Specification $ - Mult $ Exact (Spatial (Sum [Product [Forward 1 1 True]])))]) + (Right $ Right (["x"], Specification + (Mult $ Exact (Spatial (Sum [Product [Forward 1 1 True]]))) 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 $ - Mult $ Exact (Spatial (Sum [Product [Forward 1 1 True]])))]) + (Right $ Right (["x","y","z"], Specification + (Mult $ Exact (Spatial (Sum [Product [Forward 1 1 True]]))) True)) + it "parse and convert simple exact access spec (2)" $ + parseAndConvert "= access forward(depth=1, dim=1) :: x, y, z" + `shouldBe` + (Right $ Right (["x","y","z"], Specification + (Mult $ Exact (Spatial (Sum [Product [Forward 1 1 True]]))) False)) + 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 $ - Mult $ Exact (Spatial (Sum [Product [Centered 1 2 False]])))]) + (Right $ Right (["x","y","z"], Specification + (Mult $ Exact (Spatial (Sum [Product [Centered 1 2 False]]))) True)) it "parse and convert simple upper bounded stencil (3)" $ parseAndConvert "= stencil atmost, forward(depth=1, dim=1) :: x" `shouldBe` - (Right $ Right [(["x"], Specification $ - Mult $ Bound Nothing (Just $ Spatial - (Sum [Product [Forward 1 1 True]])))]) + (Right $ Right (["x"], Specification + (Mult $ Bound Nothing (Just $ Spatial + (Sum [Product [Forward 1 1 True]]))) True)) + it "parse and convert simple upper bounded access spec (3)" $ + parseAndConvert "= access atmost, forward(depth=1, dim=1) :: x" + `shouldBe` + (Right $ Right (["x"], Specification + (Mult $ Bound Nothing (Just $ Spatial + (Sum [Product [Forward 1 1 True]]))) False)) + it "parse and convert simple lower bounded stencil (4)" $ parseAndConvert "= stencil atleast, backward(depth=2, dim=1) :: x" `shouldBe` - (Right $ Right [(["x"], Specification $ - Mult $ Bound (Just $ Spatial - (Sum [Product [Backward 2 1 True]])) Nothing)]) + (Right $ Right (["x"], Specification + (Mult $ Bound (Just $ Spatial + (Sum [Product [Backward 2 1 True]])) Nothing) True)) 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" + parseAndConvert "= stencil readonce, atleast, forward(depth=1, dim=1) * (centered(depth=1, dim=2) + backward(depth=3, dim=4)) :: frob" `shouldBe` - (Right $ Right [(["frob"], Specification $ - Once $ Bound (Just $ Spatial + (Right $ Right (["frob"], Specification + (Once $ Bound (Just $ Spatial (Sum [Product [Forward 1 1 True, Centered 1 2 True], - Product [Forward 1 1 True, Backward 3 4 True]])) Nothing)]) + Product [Forward 1 1 True, Backward 3 4 True]])) Nothing) True)) + + it "rejects stencils with undefined regions" $ + parseAndConvert "= stencil r1 :: a" + `shouldBe` (Left . regionNotInScope $ "r1") + + describe "stencils check" $ do + checkTestShow exampleUnusedRegion + "warns about unused regions" + "(2:3)-(2:34) Warning: Unused region 'r1'" + checkTestShow exampleRedefinedRegion + "warns about redefined" + "(4:3)-(4:34) Region 'r1' already defined\n\ + \(6:5)-(6:32) Correct." + checkTestShow exampleSimpleInvalidSyntax + "warns about specification parse errors" + "(2:3)-(2:16) Could not parse specification at: \"... \"\n" + checkTestShow exampleSimpleCorrect + "recognises correct stencils" + "(4:5)-(4:63) Correct." + checkTestShow exampleUnusedRegionWithOtherSpecs + "provides reports in correct order" + "(3:3)-(3:34) Warning: Unused region 'r1'\n\ + \(5:5)-(5:63) Correct.\n\ + \(9:5)-(9:52) Not well specified.\n\ + \ Specification is:\n\ + \ stencil readOnce, forward(depth=1, dim=1) :: a\n\n\ + \ but at (10:5)-(10:17) the code behaves as\n\ + \ stencil readOnce, forward(depth=1, dim=1, nonpointed) :: a\n\n\ + \(12:3)-(12:16) Could not parse specification at: \"... \"\n" + checkTestShow exampleSpecWrongVar + "validates that a specification is applied to the correct variables" + "(4:5)-(4:44) Not well specified.\n\ + \ Specification is:\n\ + \ stencil readOnce, pointed(dim=1) :: b\n\n\ + \ but at (5:5)-(5:15) the code behaves as\n\ + \ stencil readOnce, pointed(dim=1) :: a\n" + +checkText text = + either (error "received test input with invalid syntax") + (stencilChecking . getBlocks . fmap (const unitAnnotation)) $ fortranParser text "example" + where getBlocks = FAB.analyseBBlocks . FAR.analyseRenames . FA.initAnalysis + +runCheck :: String -> CheckResult +runCheck = checkText . BS.packChars + +checkTestShow :: String -> String -> String -> SpecWith () +checkTestShow exampleText testDescription expected = + it testDescription $ show (runCheck exampleText) `shouldBe` expected + +exampleUnusedRegion :: String +exampleUnusedRegion = + "program example\n\ + \ != region :: r1 = pointed(dim=1)\n\ + \end program" + +exampleRedefinedRegion :: String +exampleRedefinedRegion = + "program example\n\ + \ real, dimension(10) :: a\n\ + \ != region :: r1 = forward(depth=1,dim=1, nonpointed)\n\ + \ != region :: r1 = pointed(dim=1)\n\ + \ do i = 1, 10\n\ + \ != stencil readOnce, r1 :: a\n\ + \ a(i) = a(i+1)\n\ + \ end do\n\ + \end program" + +exampleSimpleCorrect :: String +exampleSimpleCorrect = + "program example\n\ + \ real, dimension(10) :: a\n\ + \ do i = 1, 10\n\ + \ != stencil readOnce, forward(depth=1,dim=1,nonpointed) :: a\n\ + \ a(i) = a(i+1)\n\ + \ end do\n\ + \end program" + +exampleSimpleInvalidSyntax :: String +exampleSimpleInvalidSyntax = + "program example\n\ + \ != stencil foo\n\ + \end program" + +exampleUnusedRegionWithOtherSpecs :: String +exampleUnusedRegionWithOtherSpecs = + "program example\n\ + \ real, dimension(10) :: a, b\n\ + \ != region :: r1 = pointed(dim=1)\n\ + \ do i = 1, 10\n\ + \ != stencil readOnce, forward(depth=1,dim=1,nonpointed) :: a\n\ + \ a(i) = a(i+1)\n\ + \ end do\n\ + \ do i = 1, 10\n\ + \ != stencil readOnce, forward(depth=1,dim=1) :: a\n\ + \ a(i) = a(i+1)\n\ + \ end do\n\ + \ != stencil foo\n\ + \end program" + +exampleSpecWrongVar :: String +exampleSpecWrongVar = + "program example\n\ + \ real, dimension(10) :: a\n\ + \ do i = 1, 10\n\ + \ != stencil readOnce, pointed(dim=1) :: b\n\ + \ a(i) = a(i)\n\ + \ end do\n\ + \end program" diff --git a/tests/Camfort/Specification/Stencils/ConsistencySpec.hs b/tests/Camfort/Specification/Stencils/ConsistencySpec.hs --- a/tests/Camfort/Specification/Stencils/ConsistencySpec.hs +++ b/tests/Camfort/Specification/Stencils/ConsistencySpec.hs @@ -14,9 +14,9 @@ spec :: Spec spec = describe "Consistency spec" $ do - let fivePointSpec = Specification . Once . Exact . Spatial $ + 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 ] ] + , Product [ Centered 1 2 True, Centered 0 1 True ] ]) True let offFivePoint = return (V.Cons (Offsets . S.fromList $ [-1]) (V.Cons (Offsets . S.fromList $ [0]) V.Nil)) diff --git a/tests/Camfort/Specification/Stencils/DenotationalSemanticsSpec.hs b/tests/Camfort/Specification/Stencils/DenotationalSemanticsSpec.hs --- a/tests/Camfort/Specification/Stencils/DenotationalSemanticsSpec.hs +++ b/tests/Camfort/Specification/Stencils/DenotationalSemanticsSpec.hs @@ -3,11 +3,9 @@ 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 diff --git a/tests/Camfort/Specification/Stencils/GrammarSpec.hs b/tests/Camfort/Specification/Stencils/GrammarSpec.hs deleted file mode 100644 --- a/tests/Camfort/Specification/Stencils/GrammarSpec.hs +++ /dev/null @@ -1,91 +0,0 @@ -module Camfort.Specification.Stencils.GrammarSpec (spec) where - -import Camfort.Analysis.CommentAnnotator -import Camfort.Specification.Stencils.Grammar - -import Test.Hspec hiding (Spec) -import qualified Test.Hspec as Test - -spec :: Test.Spec -spec = - describe "Stencils - Grammar" $ do - it "basic unmodified stencil" $ - parse "= stencil r1 + r2 :: a" - `shouldBe` - Right (SpecDec (Spatial [] (Or (Var "r1") (Var "r2"))) ["a"]) - -{- Should no longer be possible - it "just pointed stencil" $ - parse "= stencil pointed(dims=1,2) :: a" - `shouldBe` - Right (SpecDec (Spatial [Pointed [1, 2]] Nothing) ["a"]) --} - - - it "basic modified stencil (1)" $ - parse " = stencil readonce, r1 + r2 :: a" - `shouldBe` - Right (SpecDec (Spatial [ReadOnce] (Or (Var "r1") (Var "r2"))) ["a"]) - -{- Should no longer be possible - it "basic monfieid stencil (2)" $ - parse "= stencil atleast, pointed(dims=1,2), \ - \ forward(depth=1, dim=1) :: x" - `shouldBe` - Right (SpecDec (Spatial [AtLeast,Pointed [1,2]] (Just $ Forward 1 1)) ["x"]) - - 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, Nonpointed [1], Pointed [2]] - (Just $ Forward 1 1)) ["frob"]) --} - - it "region defn" $ - parse "= region :: r = forward(depth=1, dim=1) + backward(depth=2, dim=2)" - `shouldBe` - Right (RegionDec "r" (Or (Forward 1 1 True) (Backward 2 2 True))) - - it "region defn syntactic permutation" $ - parse "= region :: r = forward(dim=1,depth=1) + backward(depth=2, dim=2)" - `shouldBe` - Right (RegionDec "r" (Or (Forward 1 1 True) (Backward 2 2 True))) - - it "region defn irreflx syntactic permutation" $ - 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, pointed(dims=1,2), readonce, \ - \ (forward(depth=1, dim=1) + r) * backward(depth=3, dim=4) \ - \ :: frob" - `shouldBe` - 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, pointed(dims=1,2), \ - \ forward(depth=1, dim=1) :: x" - `shouldBe` - (Left $ ProbablyAnnotation $ - "Conflicting modifiers: cannot use 'atLeast' and 'atMost' together") - - 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\ - \ nonpointed and pointed in dimensions = 2") --} - - -parse = specParser - --- Local variables: --- mode: haskell --- haskell-program-name: "cabal repl test-suite:spec" --- End: 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 @@ -4,7 +4,6 @@ import Algebra.Lattice import qualified Data.Set as S -import Data.List.NonEmpty import qualified Camfort.Helpers.Vec as V import Camfort.Specification.Stencils.Model diff --git a/tests/Camfort/Specification/Stencils/ParserSpec.hs b/tests/Camfort/Specification/Stencils/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Camfort/Specification/Stencils/ParserSpec.hs @@ -0,0 +1,160 @@ +module Camfort.Specification.Stencils.ParserSpec (spec) where + +import Data.Either (isLeft) + +import Camfort.Specification.Parser (runParser) +import qualified Camfort.Specification.Parser as Parser +import Camfort.Specification.Stencils.Parser (specParser, SpecParseError) +import Camfort.Specification.Stencils.Parser.Types +import Camfort.Specification.Stencils.Model ( + Approximation(..) + , Multiplicity(..)) +import qualified Camfort.Specification.Stencils.Syntax as Syn + +import Test.Hspec hiding (Spec) +import qualified Test.Hspec as Test + +-- | Helper for building stencil strings. +stencilString :: String -> String +stencilString body = "= stencil " ++ body ++ " :: a" + +-- | Helper for building stencils. +mkSpec :: Multiplicity (Approximation Region) -> Either a Specification +mkSpec m = Right (SpecDec (SpecInner m True) ["a"]) + +modifierTest :: String -> (Region -> Multiplicity (Approximation Region)) -> SpecWith () +modifierTest modifiers f = + it ("modified with " ++ modifiers) $ parse (stencilString (modifiers ++ " r1 + r2")) + `shouldBe` (mkSpec . f $ Or (Var "r1") (Var "r2")) + +-- | Check that a stencil specification does not parse. +-- +-- Automatically inserts a leading "= stencil " and trailing " :: a". +invalidStencilTest :: String -> String -> SpecWith () +invalidStencilTest description stencilStr = + it description $ parse (stencilString stencilStr) `shouldSatisfy` isLeft + +-- | Check that a stencil specification does not parse. +-- +-- Tests the @stencilStr@ as is. +invalidStencilTest' :: String -> String -> SpecWith () +invalidStencilTest' description stencilStr = + it description $ parse stencilStr `shouldSatisfy` isLeft + +-- | Check that a stencil specification does not parse, and that the +-- error string matches that provided. +-- +-- Tests the @stencilStr@ as is. +invalidStencilTestStr :: String -- ^ Test description + -> String -- ^ Specification string + -> String -- ^ Expected error string + -> SpecWith () +invalidStencilTestStr description stencilStr errStr = + it description $ show (parse stencilStr) `shouldBe` ("Left " ++ errStr) + +spec :: Test.Spec +spec = + describe "Stencils - Parser" $ do + it "basic unmodified stencil" $ + parse (stencilString "r1 + r2") + `shouldBe` + mkSpec (Mult . Exact $ Or (Var "r1") (Var "r2")) + + context "with modifiers" $ do + modifierTest "readOnce," (Once . Exact) + modifierTest "atLeast," (Mult . (`Bound` Nothing) . Just) + modifierTest "atMost," (Mult . Bound Nothing . Just) + modifierTest "readOnce, atLeast," (Once . (`Bound` Nothing) . Just) + modifierTest "readOnce, atMost," (Once . Bound Nothing . Just) + + describe "modifiers are case insensitive" $ do + modifierTest "readOnce, atLeast," (Once . (`Bound` Nothing) . Just) + modifierTest "readOnce, atMost," (Once . Bound Nothing . Just) + modifierTest "readonce, atleast," (Once . (`Bound` Nothing) . Just) + modifierTest "readonce, atmost," (Once . Bound Nothing . Just) + + let dimDepthTest (depth, dim) = + let depthDim = concat ["depth=", depth, ", dim=", dim] + in it depthDim $ + parse (stencilString $ concat ["forward(", depthDim, ")"]) + `shouldBe` mkSpec (Mult . Exact $ RegionConst $ + Syn.Forward (read depth) (read dim) True) + + describe "depth and dim" $ + mapM_ dimDepthTest [("1", "1"), ("10", "20")] + + describe "invalid stencils" $ do + invalidStencilTest "approximation before multiplicity" + "atLeast, readOnce r1" + invalidStencilTest "repeated multiplicities" + "readOnce, readOnce r1" + invalidStencilTest "repeated approximations" + "atLeast, atLeast, r1" + invalidStencilTest "multiple approximations" + "atLeast, atMost, r1" + invalidStencilTest "zero dim" + "forward(depth=1, dim=0)" + invalidStencilTest "zero depth" + "forward(depth=0, dim=1)" + invalidStencilTest "negative dim" + "forward(depth=1, dim=-1)" + invalidStencilTest "negative depth" + "forward(depth=-1, dim=1)" + invalidStencilTest "just pointed stencil" + "pointed(dims=1,2)" + invalidStencilTest "basic monfieid stencil (2)" + "atleast, pointed(dims=1,2), forward(depth=1, dim=1)" + invalidStencilTest "basic stencil with pointed and nonpointed" + "atleast, pointed(dims=2), \ + \ nonpointed(dims=1), forward(depth=1, dim=1)" + invalidStencilTest "complex stencil" + "atleast, pointed(dims=1,2), readonce, \ + \ (forward(depth=1, dim=1) + r) * backward(depth=3, dim=4)" + invalidStencilTest "pointed/nonpointed on same dim" + "atleast, nonpointed(dims=2), pointed(dims=1,2), \ + \ forward(depth=1, dim=1)" + invalidStencilTest' "empty specification" + "= stencil" + invalidStencilTest' "only identifier" + "= stencil foo" + + it "basic modified stencil (1)" $ + parse (stencilString " readonce, r1 + r2") + `shouldBe` + mkSpec (Once . Exact $ Or (Var "r1") (Var "r2")) + + + let regionTestCase isRefl = + Right (RegionDec "r" + (Or (RegionConst (Syn.Forward 1 1 isRefl)) + (RegionConst (Syn.Backward 2 2 isRefl)))) + it "region defn" $ + parse "= region :: r = forward(depth=1, dim=1) + backward(depth=2, dim=2)" + `shouldBe` + regionTestCase True + + it "region defn syntactic permutation" $ + parse "= region :: r = forward(dim=1,depth=1) + backward(depth=2, dim=2)" + `shouldBe` + regionTestCase True + + it "region defn irreflx syntactic permutation" $ + parse "= region :: r = forward(nonpointed,dim=1,depth=1) + backward(depth=2,nonpointed,dim=2)" + `shouldBe` + regionTestCase False + + describe "error messages" $ do + invalidStencilTestStr "invalid identifier" + "= stencil foo$ :: a" + "Invalid character in identifier: '$'" + invalidStencilTestStr "invalid syntax" + "= stencil readonce, readonce, pointed(dim=1) :: a" + "Could not parse specification at: \"readonce... \"\n" + +parse :: String -> Either (Parser.SpecParseError SpecParseError) Specification +parse = runParser specParser + +-- Local variables: +-- mode: haskell +-- haskell-program-name: "cabal repl test-suite:spec" +-- End: 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 @@ -8,7 +8,6 @@ module Camfort.Specification.StencilsSpec (spec) where -import GHC.TypeLits import Control.Monad.Writer.Strict hiding (Sum, Product) import Data.List @@ -16,21 +15,24 @@ import Camfort.Helpers.Vec import Camfort.Input import Camfort.Specification.Stencils +import Camfort.Specification.Stencils.Generate + (Neighbour(..), indicesToSpec, convIxToNeighbour) import Camfort.Specification.Stencils.Synthesis import Camfort.Specification.Stencils.Model import Camfort.Specification.Stencils.InferenceBackend import Camfort.Specification.Stencils.InferenceFrontend -import Camfort.Specification.Stencils.Syntax hiding (Spec) +import Camfort.Specification.Stencils.Syntax import qualified Language.Fortran.AST as F +import Language.Fortran.Parser.Any (deduceVersion) import Language.Fortran.ParserMonad import Camfort.Reprint import Camfort.Output -import qualified Data.IntMap as IM import qualified Data.Set as S import Data.Functor.Identity import qualified Data.ByteString.Char8 as B +import System.Directory (listDirectory) import System.FilePath import Test.Hspec @@ -108,36 +110,36 @@ describe "Example stencil inferences" $ do it "five point stencil 2D" $ - inferFromIndices (VL fivepoint) + inferFromIndicesWithoutLinearity (VL fivepoint) `shouldBe` - (Specification $ Once $ Exact $ Spatial + (Specification (Mult $ Exact $ Spatial (Sum [ Product [ Centered 1 1 True, Centered 0 2 True] , Product [ Centered 0 1 True, Centered 1 2 True] - ])) + ])) True) it "seven point stencil 2D" $ - inferFromIndices (VL sevenpoint) + inferFromIndicesWithoutLinearity (VL sevenpoint) `shouldBe` - (Specification $ Once $ Exact $ Spatial + (Specification (Mult $ 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] - ])) + ])) True) it "five point stencil 2D with blip" $ - inferFromIndices (VL fivepointErr) + inferFromIndicesWithoutLinearity (VL fivepointErr) `shouldBe` - (Specification $ Once $ Exact $ Spatial + (Specification (Mult $ Exact $ Spatial (Sum [ Product [ Centered 1 1 True, Centered 0 2 True], Product [ Centered 0 1 True, Centered 1 2 True], - Product [ Forward 1 1 True, Forward 1 2 True] ])) + Product [ Forward 1 1 True, Forward 1 2 True] ])) True) it "centered forward" $ - inferFromIndices (VL centeredFwd) + inferFromIndicesWithoutLinearity (VL centeredFwd) `shouldBe` - (Specification $ Once $ Exact $ Spatial + (Specification (Mult $ Exact $ Spatial (Sum [ Product [ Forward 1 1 True - , Centered 1 2 True] ])) + , Centered 1 2 True] ])) True) describe "2D stencil verification" $ mapM_ (test2DSpecVariation (Neighbour "i" 0) (Neighbour "j" 0)) variations @@ -159,19 +161,19 @@ [Neighbour "i" 0, Neighbour "j" 0] [[offsetToIx "i" 1, offsetToIx "j" 1], [offsetToIx "i" 0, offsetToIx "j" 0]] - `shouldBe` (Just $ Specification $ Once $ 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]]))) + Product [Centered 0 1 True, Centered 0 2 True]]))) True) it "consistent (2) a(i,c,j) = b(i,j+1) + b(i,j) \ \:: 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 $ Once $ Exact + `shouldBe` (Just $ Specification (Once $ Exact (Spatial - (Sum [Product [Centered 0 1 True, Forward 1 2 True]]))) + (Sum [Product [Centered 0 1 True, Forward 1 2 True]]))) True) it "consistent (3) a(i+1,c,j) = b(j,i+1) + b(j,i) \ \:: backward(depth=1,dim=2)*pointed(dim=1)" $ @@ -179,9 +181,9 @@ [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 $ Once $ Exact + `shouldBe` (Just $ Specification (Once $ Exact (Spatial - (Sum [Product [Centered 0 1 True, Backward 1 2 True]]))) + (Sum [Product [Centered 0 1 True, Backward 1 2 True]]))) True) it "consistent (4) a(i+1,j) = b(0,i+1) + b(0,i) \ \:: backward(depth=1,dim=2)" $ @@ -189,19 +191,19 @@ [Neighbour "i" 1, Neighbour "j" 0] [[offsetToIx "j" absoluteRep, offsetToIx "i" 1], [offsetToIx "j" absoluteRep, offsetToIx "i" 0]] - `shouldBe` (Just $ Specification $ Once $ Exact + `shouldBe` (Just $ Specification (Once $ Exact (Spatial - (Sum [Product [Backward 1 2 True]]))) + (Sum [Product [Backward 1 2 True]]))) True) it "consistent (5) a(i) = b(i,i+1) \ \:: pointed(dim=1)*forward(depth=1,dim=2,nonpointed)" $ indicesToSpec' ["i", "j"] [Neighbour "i" 0] [[offsetToIx "i" 0, offsetToIx "i" 1]] - `shouldBe` (Just $ Specification $ Once $ Exact + `shouldBe` (Just $ Specification (Once $ Exact (Spatial (Sum [Product [Centered 0 1 True, - Forward 1 2 False]]))) + Forward 1 2 False]]))) True) it "consistent (6) a(i) = b(i) + b(0) \ \:: pointed(dim=1)" $ @@ -228,66 +230,160 @@ -- Some integration tests ------------------------- - let file = "tests" - "fixtures" - "Specification" - "Stencils" - "example2.f" - let fileSynthExpected = "tests" - "fixtures" - "Specification" - "Stencils" - "example2.expected.f" - program <- runIO $ readParseSrcDir file [] - programSrc <- runIO $ readFile file - synthExpectedSrc <- runIO $ readFile fileSynthExpected + let example2In = fixturesDir "example2.f" + program <- runIO $ readParseSrcDir example2In [] describe "integration test on inference for example2.f" $ do it "stencil infer" $ fst (callAndSummarise (infer AssignMode '=') program) `shouldBe` "\ntests/fixtures/Specification/Stencils/example2.f\n\ - \(32:7)-(32:26) stencil readOnce, (backward(depth=1, dim=1)) :: a\n\ - \(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" + \(32:7)-(32:26) stencil readOnce, backward(depth=1, dim=1) :: a\n\ + \(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" it "stencil check" $ - fst (callAndSummarise (\f p -> (check f p, p)) program) + fst (callAndSummarise (\p -> (check p, p)) program) `shouldBe` "\ntests/fixtures/Specification/Stencils/example2.f\n\ - \(23:1)-(23:82) Correct.\n(31:1)-(31:56) Correct." - - it "stencil synth" $ - (B.unpack . runIdentity - $ reprint (refactoring Fortran77) - (snd . head . snd $ synth AssignMode '=' (map (\(f, _, p) -> (f, p)) program)) - (B.pack programSrc)) - `shouldBe` synthExpectedSrc - - let file = "tests" - "fixtures" - "Specification" - "Stencils" - "example3.f" - program <- runIO $ readParseSrcDir file [] + \(23:1)-(23:78) Correct.\n(31:1)-(31:56) Correct." - let file = "tests" - "fixtures" - "Specification" - "Stencils" - "example4.f" - program <- runIO $ readParseSrcDir file [] + let example4In = fixturesDir "example4.f" + program <- runIO $ readParseSrcDir example4In [] describe "integration test on inference for example4.f" $ it "stencil infer" $ fst (callAndSummarise (infer AssignMode '=') program) `shouldBe` "\ntests/fixtures/Specification/Stencils/example4.f\n\ - \(6:8)-(6:33) stencil readOnce, (pointed(dim=1)) :: x" + \(6:8)-(6:33) stencil readOnce, pointed(dim=1) :: x" + describe "integration test on inference for example5" $ + describe "stencil synth" $ do + assertStencilInferenceNoWarn "example5.f" + "inserts correct comment types for old fortran" + assertStencilInferenceNoWarn "example5.f90" + "inserts correct comment types for modern fortran" + + describe "synth on files already containing stencils" $ do + assertStencilInferenceNoWarn "example6.f" + "complements existing stencils (when second missing)" + assertStencilInferenceNoWarn "example7.f" + "complements existing stencils (when none missing)" + assertStencilInferenceNoWarn "example8.f" + "complements existing stencils (when first missing)" + assertStencilInferenceNoWarn "example9.f" + "complements existing stencils (when none missing - only one stencil)" + assertStencilInferenceNoWarn "example10.f" + "complements existing stencils (when one missing - inside if)" + assertStencilInferenceNoWarn "example13.f" + "complements existing stencils (when using regions references)" + assertStencilInferenceNoWarn "example11.f" + "inserts correct access specification" + assertStencilSynthResponse "example12.f" + "reports errors when conflicting stencil exists" + "\nEncountered the following errors when checking stencil specs for 'tests/fixtures/Specification/Stencils/example12.f'\n\n\ +\(8:1)-(8:52) Not well specified.\n\ +\ Specification is:\n\ +\ stencil readOnce, backward(depth=1, dim=1) :: a\n\ +\\n\ +\ but at (9:8)-(9:32) the code behaves as\n\ +\ stencil readOnce, forward(depth=1, dim=1) :: a\n\n\ +\Please resolve these errors, and then run synthesis again." + assertStencilSynthResponseOut "example14.f" + "warns when duplicate stencils exist, but continues" + "\nEncountered the following errors when checking stencil specs for 'tests/fixtures/Specification/Stencils/example14.f'\n\n\ +\(10:1)-(10:49) Warning: Duplicate specification." + + assertStencilSynthResponseOut "example15.f" + "warns when duplicate stencils exist (combined stencils), but continues" + "\nEncountered the following errors when checking stencil specs for 'tests/fixtures/Specification/Stencils/example15.f'\n\n\ +\(9:1)-(9:49) Warning: Duplicate specification." + + assertStencilCheck "example16.f" + "error trying to check an access spec against a stencil" + "\ntests/fixtures/Specification/Stencils/example16.f\n\ +\(8:1)-(8:50) Not well specified.\n\ +\ Specification is:\n\ +\ access readOnce, forward(depth=1, dim=1) :: a\n\ +\\n\ +\ but at (9:8)-(9:32) the code behaves as\n\ +\ stencil readOnce, forward(depth=1, dim=1) :: a\n" + + assertStencilCheck "example17.f" + "error trying to check an access spec against a stencil" + "\ntests/fixtures/Specification/Stencils/example17.f\n\ +\(8:1)-(8:51) Not well specified.\n\ +\ Specification is:\n\ +\ stencil readOnce, forward(depth=1, dim=1) :: a\n\ +\\n\ +\ but at (9:8)-(9:29) the code behaves as\n\ +\ access readOnce, forward(depth=1, dim=1) :: a\n" + + + describe "synth/inference works correctly with nested loops" $ do + assertStencilInferenceNoWarn "nestedLoops.f90" "inserts correct specification" + + -- Run over all the samples and test fixtures + + sampleDirConts <- runIO $ listDirectory samplesDir + expectedDirConts <- runIO $ listDirectory (samplesDir "expected") + + let hasExpectedSrcFile f = f `elem` expectedDirConts + sampleFiles = filter hasExpectedSrcFile sampleDirConts + + describe "sample file tests" $ + mapM_ (\file -> assertStencilInferenceSample + file ("produces correct output file for " ++ file)) + sampleFiles + + where -- Helpers go here for loading files and running analyses + assertStencilCheck fileName testComment expected = do + let file = fixturesDir fileName + programs <- runIO $ readParseSrcDir file [] + let [(program,_)] = programs + it testComment $ check program `shouldBe` expected + + assertStencilInferenceDir expected dir fileName testComment = + let file = dir fileName + version = deduceVersion file + expectedFile = expected dir fileName + in do + program <- runIO $ readParseSrcDir file [] + programSrc <- runIO $ readFile file + synthExpectedSrc <- runIO $ readFile expectedFile + it testComment $ + (map (B.unpack . runIdentity . flip (reprint (refactoring version)) (B.pack programSrc)) + (snd . synth AssignMode '=' . fmap fst $ program)) + `shouldBe` [synthExpectedSrc] + + assertStencilInferenceOnFile = assertStencilInferenceDir + (\d f -> d getExpectedSrcFileName f) fixturesDir + + assertStencilInferenceSample = assertStencilInferenceDir + (\d f -> d "expected" f) samplesDir + + assertStencilSynthResponse fileName testComment expectedResponse = + let file = fixturesDir fileName + in do + program <- runIO $ readParseSrcDir file [] + programSrc <- runIO $ readFile file + it testComment $ (fst . synth AssignMode '=' . fmap fst $ program) + `shouldBe` expectedResponse + + assertStencilSynthResponseOut fileName testComment expectedResponse = + describe testComment $ do + assertStencilInferenceOnFile fileName "correct synthesis" + assertStencilSynthResponse fileName "correct output" expectedResponse + + assertStencilInferenceNoWarn fileName testComment = assertStencilSynthResponseOut fileName testComment "" + fixturesDir = "tests" "fixtures" "Specification" "Stencils" + samplesDir = "samples" "stencils" + getExpectedSrcFileName file = + let oldExtension = takeExtension file + in addExtension (replaceExtension file "expected") oldExtension + -- Indices for the 2D five point stencil (deliberately in an odd order) fivepoint = [ Cons (-1) (Cons 0 Nil), Cons 0 (Cons (-1) Nil) , Cons 1 (Cons 0 Nil) , Cons 0 (Cons 1 Nil), Cons 0 (Cons 0 Nil) @@ -325,11 +421,10 @@ indicesToSpec' ["i", "j"] [a, b] (map fromFormatToIx input) `shouldBe` Just expectedSpec where - expectedSpec = Specification expectation + expectedSpec = Specification expectation True fromFormatToIx [ri,rj] = [ offsetToIx "i" ri, offsetToIx "j" rj ] -indicesToSpec' ivs lhs = fst . runWriter . indicesToSpec ivmap "a" lhs - where ivmap = IM.singleton 0 (S.fromList ivs) +indicesToSpec' ivs lhs = fst . runWriter . indicesToSpec ivs "a" lhs variations = [ ( [ [0,0] ] @@ -407,7 +502,7 @@ `shouldBe` Just expectedSpec where - expectedSpec = Specification expectation + expectedSpec = Specification expectation True fromFormatToIx [ri,rj,rk] = [offsetToIx "i" ri, offsetToIx "j" rj, offsetToIx "k" rk] @@ -426,7 +521,7 @@ prop_extract_synth_inverse :: F.Name -> Int -> Bool prop_extract_synth_inverse v o = - ixToNeighbour' [v] (offsetToIx v o) == Neighbour v o + convIxToNeighbour [v] (offsetToIx v o) == Neighbour v o -- Local variables: -- mode: haskell diff --git a/tests/Camfort/Specification/Units/InferenceBackendSpec.hs b/tests/Camfort/Specification/Units/InferenceBackendSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Camfort/Specification/Units/InferenceBackendSpec.hs @@ -0,0 +1,122 @@ +module Camfort.Specification.Units.InferenceBackendSpec (spec) where + +import GHC.Real ((%)) + +import Test.Hspec hiding (Spec) +import qualified Test.Hspec as Test + +import Camfort.Specification.Units.Environment +import Camfort.Specification.Units.InferenceBackend + ( criticalVariables + , flattenConstraints + , inconsistentConstraints + , inferVariables + , shiftTerms ) + +spec :: Test.Spec +spec = do + describe "Flatten constraints" $ + it "testCons1" $ + flattenConstraints testCons1 `shouldBe` testCons1_flattened + describe "Shift terms" $ do + it "testCons1" $ + map shiftTerms (flattenConstraints testCons1) `shouldBe` testCons1_shifted + it "testCons2" $ + map shiftTerms (flattenConstraints testCons2) `shouldBe` testCons2_shifted + it "testCons3" $ + map shiftTerms (flattenConstraints testCons3) `shouldBe` testCons3_shifted + describe "Consistency" $ do + it "testCons1" $ + inconsistentConstraints testCons1 `shouldBe` Just [ConEq (UnitName "kg") (UnitName "m")] + it "testCons2" $ + inconsistentConstraints testCons2 `shouldBe` Nothing + it "testCons3" $ + inconsistentConstraints testCons3 `shouldBe` Nothing + describe "Critical Variables" $ do + it "testCons2" $ + criticalVariables testCons2 `shouldSatisfy` null + it "testCons3" $ + criticalVariables testCons3 `shouldBe` [UnitVar ("c", "c"), UnitVar ("e", "e")] + it "testCons4" $ + criticalVariables testCons4 `shouldBe` [UnitVar ("simple2_a22", "simple2_a22")] + it "testCons5" $ + criticalVariables testCons5 `shouldSatisfy` null + describe "Infer Variables" $ + it "testCons5" $ + show (inferVariables testCons5) `shouldBe` show testCons5_infer + describe "Check that (restricted) double to ratios is consistent" $ + it "test all in -10/-10 ... 10/10, apart from /0" $ + and [testDoubleToRationalSubset x y | x <- [-10..10], y <- [-10..10]] + +testCons1 = [ ConEq (UnitName "kg") (UnitName "m") + , ConEq (UnitVar ("x", "x")) (UnitName "m") + , ConEq (UnitVar ("y", "y")) (UnitName "kg")] + +testCons1_flattened = [([UnitPow (UnitName "kg") 1.0],[UnitPow (UnitName "m") 1.0]) + ,([UnitPow (UnitVar ("x", "x")) 1.0],[UnitPow (UnitName "m") 1.0]) + ,([UnitPow (UnitVar ("y", "y")) 1.0],[UnitPow (UnitName "kg") 1.0])] + +testCons1_shifted = [([],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "kg") (-1.0)]) + ,([UnitPow (UnitVar ("x", "x")) 1.0],[UnitPow (UnitName "m") 1.0]) + ,([UnitPow (UnitVar ("y", "y")) 1.0],[UnitPow (UnitName "kg") 1.0])] + +-------------------------------------------------- + +testCons2 = [ConEq (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-1.0))) (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-1.0))) + ,ConEq (UnitName "m") (UnitMul (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-1.0))) (UnitName "s")) + ,ConEq (UnitAlias "accel") (UnitMul (UnitName "m") (UnitPow (UnitParamPosUse (("simple1_sqr6", "sqr"),0,0)) (-1.0))) + ,ConEq (UnitName "s") (UnitParamPosUse (("simple1_sqr6", "sqr"),1,0)) + ,ConEq (UnitVar ("simple1_a5", "simple1_a5")) (UnitAlias "accel") + ,ConEq (UnitVar ("simple1_t4", "simple1_t4")) (UnitName "s") + ,ConEq (UnitVar ("simple1_v3", "simple1_v3")) (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-1.0))) + ,ConEq (UnitVar ("simple1_x1", "simple1_x1")) (UnitName "m") + ,ConEq (UnitVar ("simple1_y2", "simple1_y2")) (UnitName "m") + ,ConEq (UnitParamPosUse (("simple1_sqr6","sqr"),0,0)) (UnitParamPosUse (("simple1_mul7","mul"),0,1)) + ,ConEq (UnitParamPosUse (("simple1_sqr6","sqr"),1,0)) (UnitParamPosUse (("simple1_mul7","mul"),1,1)) + ,ConEq (UnitParamPosUse (("simple1_sqr6","sqr"),1,0)) (UnitParamPosUse (("simple1_mul7","mul"),2,1)) + ,ConEq (UnitParamPosUse (("simple1_mul7","mul"),0,1)) (UnitMul (UnitParamPosUse (("simple1_mul7","mul"),1,1)) (UnitParamPosUse (("simple1_mul7","mul"),2,1))) + ,ConEq (UnitAlias "accel") (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-2.0)))] + +testCons2_shifted = [([],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "s") (-1.0),UnitPow (UnitName "m") (-1.0),UnitPow (UnitName "s") 1.0]) + ,([],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "m") (-1.0)]) + ,([UnitPow (UnitAlias "accel") 1.0,UnitPow (UnitParamPosUse (("simple1_sqr6","sqr"),0,0)) 1.0],[UnitPow (UnitName "m") 1.0]) + ,([UnitPow (UnitParamPosUse (("simple1_sqr6","sqr"),1,0)) (-1.0)],[UnitPow (UnitName "s") (-1.0)]) + ,([UnitPow (UnitVar ("simple1_a5", "simple1_a5")) 1.0,UnitPow (UnitAlias "accel") (-1.0)],[]) + ,([UnitPow (UnitVar ("simple1_t4", "simple1_t4")) 1.0],[UnitPow (UnitName "s") 1.0]) + ,([UnitPow (UnitVar ("simple1_v3", "simple1_v3")) 1.0],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "s") (-1.0)]) + ,([UnitPow (UnitVar ("simple1_x1", "simple1_x1")) 1.0],[UnitPow (UnitName "m") 1.0]) + ,([UnitPow (UnitVar ("simple1_y2", "simple1_y2")) 1.0],[UnitPow (UnitName "m") 1.0]) + ,([UnitPow (UnitParamPosUse (("simple1_sqr6","sqr"),0,0)) 1.0,UnitPow (UnitParamPosUse (("simple1_mul7","mul"),0,1)) (-1.0)],[]) + ,([UnitPow (UnitParamPosUse (("simple1_sqr6","sqr"),1,0)) 1.0,UnitPow (UnitParamPosUse (("simple1_mul7","mul"),1,1)) (-1.0)],[]) + ,([UnitPow (UnitParamPosUse (("simple1_sqr6","sqr"),1,0)) 1.0,UnitPow (UnitParamPosUse (("simple1_mul7","mul"),2,1)) (-1.0)],[]) + ,([UnitPow (UnitParamPosUse (("simple1_mul7","mul"),0,1)) 1.0,UnitPow (UnitParamPosUse (("simple1_mul7","mul"),1,1)) (-1.0),UnitPow (UnitParamPosUse (("simple1_mul7","mul"),2,1)) (-1.0)],[]) + ,([UnitPow (UnitAlias "accel") 1.0],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "s") (-2.0)])] + +testCons3 = [ ConEq (UnitVar ("a", "a")) (UnitVar ("e", "e")) + , ConEq (UnitVar ("a", "a")) (UnitMul (UnitVar ("b", "b")) (UnitMul (UnitVar ("c", "c")) (UnitVar ("d", "d")))) + , ConEq (UnitVar ("d", "d")) (UnitName "m") ] + +testCons3_shifted = [([UnitPow (UnitVar ("a", "a")) 1.0,UnitPow (UnitVar ("e", "e")) (-1.0)],[]) + ,([UnitPow (UnitVar ("a", "a")) 1.0,UnitPow (UnitVar ("b", "b")) (-1.0),UnitPow (UnitVar ("c", "c")) (-1.0),UnitPow (UnitVar ("d", "d")) (-1.0)],[]) + ,([UnitPow (UnitVar ("d", "d")) 1.0],[UnitPow (UnitName "m") 1.0])] + +testCons4 = [ConEq (UnitVar ("simple2_a11", "simple2_a11")) (UnitParamPosUse (("simple2_sqr3","sqr"),0,0)) + ,ConEq (UnitVar ("simple2_a22", "simple2_a22")) (UnitParamPosUse (("simple2_sqr3","sqr"),1,0)) + ,ConEq (UnitVar ("simple2_a11", "simple2_a11")) (UnitVar ("simple2_a11", "simple2_a11")) + ,ConEq (UnitVar ("simple2_a22", "simple2_a22")) (UnitVar ("simple2_a22", "simple2_a22")) + ,ConEq (UnitParamPosUse (("simple2_sqr3","sqr"),0,0)) (UnitMul (UnitParamPosUse (("simple2_sqr3","sqr"),1,0)) (UnitParamPosUse (("simple2_sqr3","sqr"),1,0)))] + +testCons5 = [ConEq (UnitVar ("simple2_a11", "simple2_a11")) (UnitParamPosUse (("simple2_sqr3","sqr"),0,0)) + ,ConEq (UnitAlias "accel") (UnitParamPosUse (("simple2_sqr3","sqr"),1,0)) + ,ConEq (UnitVar ("simple2_a11", "simple2_a11")) (UnitVar ("simple2_a11", "simple2_a11")) + ,ConEq (UnitVar ("simple2_a22", "simple2_a22")) (UnitAlias "accel") + ,ConEq (UnitParamPosUse (("simple2_sqr3","sqr"),0,0)) (UnitMul (UnitParamPosUse (("simple2_sqr3","sqr"),1,0)) (UnitParamPosUse (("simple2_sqr3","sqr"),1,0))) + ,ConEq (UnitAlias "accel") (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-2.0)))] + +testCons5_infer = [(("simple2_a11", "simple2_a11"),UnitMul (UnitPow (UnitName "m") 2.0) (UnitPow (UnitName "s") (-4.0))) + ,(("simple2_a22", "simple2_a22"),UnitMul (UnitPow (UnitName "m") 1.0) (UnitPow (UnitName "s") (-2.0)))] + +testDoubleToRationalSubset :: Integer -> Integer -> Bool +testDoubleToRationalSubset x y = + not (x <= 10 && y <= 10 && x >= -10 && y >= -10 && y /= 0) + || doubleToRationalSubset (fromIntegral x / fromIntegral y) == Just (x % y) diff --git a/tests/Camfort/Specification/Units/InferenceFrontendSpec.hs b/tests/Camfort/Specification/Units/InferenceFrontendSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Camfort/Specification/Units/InferenceFrontendSpec.hs @@ -0,0 +1,295 @@ +module Camfort.Specification.Units.InferenceFrontendSpec (spec) where + +import qualified Data.ByteString.Char8 as B +import Data.Either (rights) +import Data.Generics.Uniplate.Operations (universeBi) +import Data.List (nub, sort) +import Data.Maybe (fromJust, isJust, mapMaybe, maybeToList) + +import Test.Hspec hiding (Spec) +import qualified Test.Hspec as Test + +import Language.Fortran.Parser.Any (fortranParser) +import Language.Fortran.ParserMonad (fromRight) +import qualified Language.Fortran.AST as F +import qualified Language.Fortran.Analysis as FA + +import Camfort.Analysis.Annotations (UA, unitAnnotation) +import Camfort.Specification.Units (chooseImplicitNames) +import Camfort.Specification.Units.Environment +import Camfort.Specification.Units.InferenceFrontend + ( initInference + , runInconsistentConstraints + , runInferVariables + ) +import Camfort.Specification.Units.Monad + (LiteralsOpt(..), runUnitSolver, unitOpts0, uoDebug, uoLiterals, usConstraints) + +spec :: Test.Spec +spec = do + let showClean = show . nub . sort . head . rights . (:[]) . fst + describe "Unit Inference Frontend" $ do + describe "Literal Mode" $ do + it "litTest1 Mixed" $ + 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" $ + 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" $ + fromJust (head (rights [fst (runUnits LitUnitless litTest1 runInconsistentConstraints)])) `shouldSatisfy` + any (conParamEq (ConEq UnitlessLit (UnitVar ("j", "j")))) + it "Polymorphic non-zero literal is not OK" $ + head (rights [fst (runUnits LitMixed inconsist1 runInconsistentConstraints)]) `shouldSatisfy` isJust + + describe "Polymorphic functions" $ + it "squarePoly1" $ + 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" $ + it "Recursive Addition is OK" $ + 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" $ + it "Recursive Multiplication is not OK" $ + fromJust (head (rights [fst (runUnits LitMixed recursive2 runInconsistentConstraints)])) `shouldSatisfy` + any (conParamEq (ConEq (UnitParamPosAbs (("recur", "recur"), 0)) (UnitParamPosAbs (("recur", "recur"), 2)))) + + describe "Explicitly annotated parametric polymorphic unit variables" $ do + it "inside-outside" $ + 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" $ + show (sort (fst (runUnitInference LitMixed eapVarScope))) `shouldBe` + "[(\"f\",('a)**3),(\"g\",'a),(\"j\",'a),(\"k\",('a)**3),(\"x\",'a),(\"y\",'a)]" + it "eapVarApp" $ + 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" $ + it "inferPoly1" $ + 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" $ + it "sqrtPoly" $ + show (sort (fst (runUnitInference LitMixed sqrtPoly))) `shouldBe` + "[(\"a\",m**2),(\"b\",s**4),(\"c\",j**2),(\"n\",'a),(\"x\",m),(\"y\",s),(\"z\",j)]" + +runUnits litMode pf m = (r, usConstraints state) + where + pf' = FA.initAnalysis . fmap (mkUnitAnnotation . const unitAnnotation) $ pf + uOpts = unitOpts0 { uoDebug = False, uoLiterals = litMode } + (r, state, _) = 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 . const unitAnnotation) $ pf + uOpts = unitOpts0 { uoDebug = False, uoLiterals = litMode } + (r, state, _) = 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 + +fortranParser' x = fromRight . fortranParser x + +litTest1 = flip fortranParser' "litTest1.f90" . B.pack $ unlines + [ "program main" + , " != unit(a) :: x" + , " real :: x, j, k" + , "" + , " j = 1 + 1" + , " k = j * j" + , " x = x + k" + , " x = x * j ! inconsistent" + , "end program main" ] + +squarePoly1 = flip fortranParser' "squarePoly1.f90" . B.pack $ unlines + [ "! Demonstrates parametric polymorphism through functions-calling-functions." + , "program squarePoly" + , " implicit none" + , " real :: x" + , " real :: y" + , " != unit(m) :: a" + , " real :: a" + , " != unit(s) :: b" + , " real :: b" + , " x = squareP(a)" + , " y = squareP(b)" + , " contains" + , " real function square(n)" + , " real :: n" + , " square = n * n" + , " end function" + , " real function squareP(m)" + , " real :: m" + , " squareP = square(m)" + , " end function" + , "end program" ] + +recursive1 = flip fortranParser' "recursive1.f90" . B.pack $ unlines + [ "program main" + , " != unit(m) :: y" + , " integer :: x = 5, y = 2, z" + , " z = recur(x,y)" + , " print *, y" + , "contains" + , " real recursive function recur(n, b) result(r)" + , " integer :: n, b" + , " if (n .EQ. 0) then" + , " r = b" + , " else" + , " r = b + recur(n - 1, b)" + , " end if" + , " end function recur" + , "end program main" ] + +recursive2 = flip fortranParser' "recursive2.f90" . B.pack $ unlines + [ "program main" + , " != unit(m) :: y" + , " integer :: x = 5, y = 2, z" + , " z = recur(x,y)" + , " print *, y" + , "contains" + , " real recursive function recur(n, b) result(r)" + , " integer :: n, b" + , " if (n .EQ. 0) then" + , " r = b" + , " else" + , " r = b * recur(n - 1, b) ! inconsistent" + , " 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" ] diff --git a/tests/Camfort/Specification/Units/ParserSpec.hs b/tests/Camfort/Specification/Units/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Camfort/Specification/Units/ParserSpec.hs @@ -0,0 +1,45 @@ +module Camfort.Specification.Units.ParserSpec (spec) where + +import Camfort.Specification.Parser (runParser, SpecParseError) +import Camfort.Specification.Units.Parser (unitParser, UnitParseError) +import Camfort.Specification.Units.Parser.Types (UnitStatement) + +import Test.Hspec + +spec :: Spec +spec = do + let shouldParseSameAs s s' = + parseUnits s `shouldBe` parseUnits s' + unitEquivalences = + [ ("m * s", "m s") + , ("m * s**2", "m s**2") + , ("m * s/t", "m s/t") + ] + describe "Parsing Equivalence" $ + mapM_ (\(s1,s2) -> it (concat ["\"", s1, "\" is the same as \"", s2, "\""]) $ + s1 `shouldParseSameAs` s2) unitEquivalences + + describe "error messages" $ do + invalidUnitSpecTestStr "invalid identifier character" + "= unit ($) :: a" + "Invalid character in identifier: '$'" + invalidUnitSpecTestStr "invalid syntax" + "= unit :: s" + "Could not parse specification at: \"[]\"\n" + +-- | Check that a unit specification does not parse, and that the +-- error string matches that provided. +-- +-- Tests the @unitStr@ as is. +invalidUnitSpecTestStr :: String -- ^ Test description + -> String -- ^ Specification string + -> String -- ^ Expected error string + -> SpecWith () +invalidUnitSpecTestStr description unitStr errStr = + it description $ show (parse unitStr) `shouldBe` ("Left " ++ errStr) + +parseUnits :: String -> Either (SpecParseError UnitParseError) UnitStatement +parseUnits = parse . (\s -> "= unit " ++ s ++ " :: a") + +parse :: String -> Either (SpecParseError UnitParseError) UnitStatement +parse = runParser unitParser 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 @@ -1,433 +1,37 @@ -{-# LANGUAGE ImplicitParams #-} module Camfort.Specification.UnitsSpec (spec) where -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 -import Camfort.Analysis.Annotations -import Camfort.Specification.Units -import Camfort.Specification.Units.Monad -import Camfort.Specification.Units.InferenceFrontend -import Camfort.Specification.Units.InferenceBackend -import Camfort.Specification.Units.Environment -import Data.List -import Data.Maybe -import Data.Either -import qualified Data.Array as A -import qualified Numeric.LinearAlgebra as H -import qualified Data.Map.Strict as M -import GHC.Real -import Numeric.LinearAlgebra ( - atIndex, (<>), (><), rank, (?), toLists, toList, fromLists, fromList, rows, cols, - takeRows, takeColumns, dropRows, dropColumns, subMatrix, diag, build, fromBlocks, - ident, flatten, lu, dispf, Matrix - ) +import System.FilePath (()) import Test.Hspec -import Test.QuickCheck -import Test.Hspec.QuickCheck -runFrontendInit litMode pf = usConstraints state - where - pf' = FA.initAnalysis . fmap mkUnitAnnotation . fmap (const unitAnnotation) $ pf - uOpts = unitOpts0 { uoNameMap = M.empty, uoDebug = False, uoLiterals = litMode } - (_, state, logs) = runUnitSolver uOpts pf' initInference - -runUnits litMode pf m = (r, 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 >> m - -runUnits' litMode pf m = (state, logs) - where - pf' = FA.initAnalysis . fmap mkUnitAnnotation . fmap (const unitAnnotation) $ pf - uOpts = unitOpts0 { uoNameMap = M.empty, uoDebug = True, uoLiterals = litMode } - (r, state, logs) = runUnitSolver uOpts pf' $ initInference >> m - -runUnitsRenamed' litMode pf m = (state, logs) - where - pf' = FAR.analyseRenames . FA.initAnalysis . fmap mkUnitAnnotation . fmap (const unitAnnotation) $ pf - 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 - +import Camfort.Input (readParseSrcDir) +import Camfort.Specification.Units (checkUnits) +import Camfort.Specification.Units.Monad + (LiteralsOpt(..), unitOpts0, uoDebug, uoLiterals) 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 - (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 - (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 - (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 - 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 - 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 - (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 - flattenConstraints testCons1 `shouldBe` testCons1_flattened - describe "Shift terms" $ do - it "testCons1" $ do - map shiftTerms (flattenConstraints testCons1) `shouldBe` testCons1_shifted - it "testCons2" $ do - map shiftTerms (flattenConstraints testCons2) `shouldBe` testCons2_shifted - it "testCons3" $ do - map shiftTerms (flattenConstraints testCons3) `shouldBe` testCons3_shifted - describe "Consistency" $ do - it "testCons1" $ do - inconsistentConstraints testCons1 `shouldBe` Just [ConEq (UnitName "kg") (UnitName "m")] - it "testCons2" $ do - inconsistentConstraints testCons2 `shouldBe` Nothing - it "testCons3" $ do - inconsistentConstraints testCons3 `shouldBe` Nothing - describe "Critical Variables" $ do - it "testCons2" $ do - criticalVariables testCons2 `shouldSatisfy` null - it "testCons3" $ do - criticalVariables testCons3 `shouldBe` [UnitVar ("c", "c"), UnitVar ("e", "e")] - it "testCons4" $ do - criticalVariables testCons4 `shouldBe` [UnitVar ("simple2_a22", "simple2_a22")] - it "testCons5" $ do - criticalVariables testCons5 `shouldSatisfy` null - describe "Infer Variables" $ do - it "testCons5" $ do - 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]] - --------------------------------------------------- - -testCons1 = [ ConEq (UnitName "kg") (UnitName "m") - , ConEq (UnitVar ("x", "x")) (UnitName "m") - , ConEq (UnitVar ("y", "y")) (UnitName "kg")] - -testCons1_flattened = [([UnitPow (UnitName "kg") 1.0],[UnitPow (UnitName "m") 1.0]) - ,([UnitPow (UnitVar ("x", "x")) 1.0],[UnitPow (UnitName "m") 1.0]) - ,([UnitPow (UnitVar ("y", "y")) 1.0],[UnitPow (UnitName "kg") 1.0])] - -testCons1_shifted = [([],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "kg") (-1.0)]) - ,([UnitPow (UnitVar ("x", "x")) 1.0],[UnitPow (UnitName "m") 1.0]) - ,([UnitPow (UnitVar ("y", "y")) 1.0],[UnitPow (UnitName "kg") 1.0])] - --------------------------------------------------- - -testCons2 = [ConEq (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-1.0))) (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-1.0))) - ,ConEq (UnitName "m") (UnitMul (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-1.0))) (UnitName "s")) - ,ConEq (UnitAlias "accel") (UnitMul (UnitName "m") (UnitPow (UnitParamPosUse ("simple1_sqr6",0,0)) (-1.0))) - ,ConEq (UnitName "s") (UnitParamPosUse ("simple1_sqr6",1,0)) - ,ConEq (UnitVar ("simple1_a5", "simple1_a5")) (UnitAlias "accel") - ,ConEq (UnitVar ("simple1_t4", "simple1_t4")) (UnitName "s") - ,ConEq (UnitVar ("simple1_v3", "simple1_v3")) (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-1.0))) - ,ConEq (UnitVar ("simple1_x1", "simple1_x1")) (UnitName "m") - ,ConEq (UnitVar ("simple1_y2", "simple1_y2")) (UnitName "m") - ,ConEq (UnitParamPosUse ("simple1_sqr6",0,0)) (UnitParamPosUse ("simple1_mul7",0,1)) - ,ConEq (UnitParamPosUse ("simple1_sqr6",1,0)) (UnitParamPosUse ("simple1_mul7",1,1)) - ,ConEq (UnitParamPosUse ("simple1_sqr6",1,0)) (UnitParamPosUse ("simple1_mul7",2,1)) - ,ConEq (UnitParamPosUse ("simple1_mul7",0,1)) (UnitMul (UnitParamPosUse ("simple1_mul7",1,1)) (UnitParamPosUse ("simple1_mul7",2,1))) - ,ConEq (UnitAlias "accel") (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-2.0)))] - -testCons2_shifted = [([],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "s") (-1.0),UnitPow (UnitName "m") (-1.0),UnitPow (UnitName "s") 1.0]) - ,([],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "m") (-1.0)]) - ,([UnitPow (UnitAlias "accel") 1.0,UnitPow (UnitParamPosUse ("simple1_sqr6",0,0)) 1.0],[UnitPow (UnitName "m") 1.0]) - ,([UnitPow (UnitParamPosUse ("simple1_sqr6",1,0)) (-1.0)],[UnitPow (UnitName "s") (-1.0)]) - ,([UnitPow (UnitVar ("simple1_a5", "simple1_a5")) 1.0,UnitPow (UnitAlias "accel") (-1.0)],[]) - ,([UnitPow (UnitVar ("simple1_t4", "simple1_t4")) 1.0],[UnitPow (UnitName "s") 1.0]) - ,([UnitPow (UnitVar ("simple1_v3", "simple1_v3")) 1.0],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "s") (-1.0)]) - ,([UnitPow (UnitVar ("simple1_x1", "simple1_x1")) 1.0],[UnitPow (UnitName "m") 1.0]) - ,([UnitPow (UnitVar ("simple1_y2", "simple1_y2")) 1.0],[UnitPow (UnitName "m") 1.0]) - ,([UnitPow (UnitParamPosUse ("simple1_sqr6",0,0)) 1.0,UnitPow (UnitParamPosUse ("simple1_mul7",0,1)) (-1.0)],[]) - ,([UnitPow (UnitParamPosUse ("simple1_sqr6",1,0)) 1.0,UnitPow (UnitParamPosUse ("simple1_mul7",1,1)) (-1.0)],[]) - ,([UnitPow (UnitParamPosUse ("simple1_sqr6",1,0)) 1.0,UnitPow (UnitParamPosUse ("simple1_mul7",2,1)) (-1.0)],[]) - ,([UnitPow (UnitParamPosUse ("simple1_mul7",0,1)) 1.0,UnitPow (UnitParamPosUse ("simple1_mul7",1,1)) (-1.0),UnitPow (UnitParamPosUse ("simple1_mul7",2,1)) (-1.0)],[]) - ,([UnitPow (UnitAlias "accel") 1.0],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "s") (-2.0)])] - -testCons3 = [ ConEq (UnitVar ("a", "a")) (UnitVar ("e", "e")) - , ConEq (UnitVar ("a", "a")) (UnitMul (UnitVar ("b", "b")) (UnitMul (UnitVar ("c", "c")) (UnitVar ("d", "d")))) - , ConEq (UnitVar ("d", "d")) (UnitName "m") ] - -testCons3_shifted = [([UnitPow (UnitVar ("a", "a")) 1.0,UnitPow (UnitVar ("e", "e")) (-1.0)],[]) - ,([UnitPow (UnitVar ("a", "a")) 1.0,UnitPow (UnitVar ("b", "b")) (-1.0),UnitPow (UnitVar ("c", "c")) (-1.0),UnitPow (UnitVar ("d", "d")) (-1.0)],[]) - ,([UnitPow (UnitVar ("d", "d")) 1.0],[UnitPow (UnitName "m") 1.0])] - -testCons4 = [ConEq (UnitVar ("simple2_a11", "simple2_a11")) (UnitParamPosUse ("simple2_sqr3",0,0)) - ,ConEq (UnitVar ("simple2_a22", "simple2_a22")) (UnitParamPosUse ("simple2_sqr3",1,0)) - ,ConEq (UnitVar ("simple2_a11", "simple2_a11")) (UnitVar ("simple2_a11", "simple2_a11")) - ,ConEq (UnitVar ("simple2_a22", "simple2_a22")) (UnitVar ("simple2_a22", "simple2_a22")) - ,ConEq (UnitParamPosUse ("simple2_sqr3",0,0)) (UnitMul (UnitParamPosUse ("simple2_sqr3",1,0)) (UnitParamPosUse ("simple2_sqr3",1,0)))] - -testCons5 = [ConEq (UnitVar ("simple2_a11", "simple2_a11")) (UnitParamPosUse ("simple2_sqr3",0,0)) - ,ConEq (UnitAlias "accel") (UnitParamPosUse ("simple2_sqr3",1,0)) - ,ConEq (UnitVar ("simple2_a11", "simple2_a11")) (UnitVar ("simple2_a11", "simple2_a11")) - ,ConEq (UnitVar ("simple2_a22", "simple2_a22")) (UnitAlias "accel") - ,ConEq (UnitParamPosUse ("simple2_sqr3",0,0)) (UnitMul (UnitParamPosUse ("simple2_sqr3",1,0)) (UnitParamPosUse ("simple2_sqr3",1,0))) - ,ConEq (UnitAlias "accel") (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-2.0)))] - -testCons5_infer = [(("simple2_a11", "simple2_a11"),UnitMul (UnitPow (UnitName "m") 2.0) (UnitPow (UnitName "s") (-4.0))) - ,(("simple2_a22", "simple2_a22"),UnitMul (UnitPow (UnitName "m") 1.0) (UnitPow (UnitName "s") (-2.0)))] - -testDoubleToRationalSubset :: Integer -> Integer -> Bool -testDoubleToRationalSubset x y = - if x <= 10 && y <= 10 && x >= -10 && y >= -10 && y /= 0 - then doubleToRationalSubset (fromIntegral x / fromIntegral y) == Just (x % y) - else True --------------------------------------------------- - -litTest1 = flip fortranParser' "litTest1.f90" . B.pack $ unlines - [ "program main" - , " != unit(a) :: x" - , " real :: x, j, k" - , "" - , " j = 1 + 1" - , " k = j * j" - , " x = x + k" - , " x = x * j ! inconsistent" - , "end program main" ] - -squarePoly1 = flip fortranParser' "squarePoly1.f90" . B.pack $ unlines - [ "! Demonstrates parametric polymorphism through functions-calling-functions." - , "program squarePoly" - , " implicit none" - , " real :: x" - , " real :: y" - , " != unit(m) :: a" - , " real :: a" - , " != unit(s) :: b" - , " real :: b" - , " x = squareP(a)" - , " y = squareP(b)" - , " contains" - , " real function square(n)" - , " real :: n" - , " square = n * n" - , " end function" - , " real function squareP(m)" - , " real :: m" - , " squareP = square(m)" - , " end function" - , "end program" ] - -recursive1 = flip fortranParser' "recursive1.f90" . B.pack $ unlines - [ "program main" - , " != unit(m) :: y" - , " integer :: x = 5, y = 2, z" - , " z = recur(x,y)" - , " print *, y" - , "contains" - , " real recursive function recur(n, b) result(r)" - , " integer :: n, b" - , " if (n .EQ. 0) then" - , " r = b" - , " else" - , " r = b + recur(n - 1, b)" - , " end if" - , " end function recur" - , "end program main" ] - -recursive2 = flip fortranParser' "recursive2.f90" . B.pack $ unlines - [ "program main" - , " != unit(m) :: y" - , " integer :: x = 5, y = 2, z" - , " z = recur(x,y)" - , " print *, y" - , "contains" - , " real recursive function recur(n, b) result(r)" - , " integer :: n, b" - , " if (n .EQ. 0) then" - , " r = b" - , " else" - , " r = b * recur(n - 1, b) ! inconsistent" - , " 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" ] +spec = + describe "fixtures integration tests" $ + describe "units-check" $ + it "reports (simple) inconsistent units" $ + "example-inconsist-1.f90" `unitsCheckReportIs` exampleInconsist1CheckReport --- 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" ] +fixturesDir :: String +fixturesDir = "tests" "fixtures" "Specification" "Units" --- 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" ] +-- | Assert that the report of performing units checking on a file is as expected. +unitsCheckReportIs :: String -> String -> Expectation +fileName `unitsCheckReportIs` expectedReport = do + let file = fixturesDir fileName + [(pf,_)] <- readParseSrcDir file [] + checkUnits uOpts pf `shouldBe` expectedReport + where uOpts = unitOpts0 { uoDebug = False, uoLiterals = LitMixed } -fortranParser' = \x -> fromRight . (fortranParser x) +exampleInconsist1CheckReport :: String +exampleInconsist1CheckReport = + "\ntests/fixtures/Specification/Units/example-inconsist-1.f90: Inconsistent:\n\ + \ - at 7:7: 'z' should have unit 's'\n\ + \ - at 7:7: Units 's' and 'm' should be equal\n\n\n\ + \(7:7)-(7:11): s === m\n\ + \(7:3)-(7:11): unit_of(z) === s\n\ + \(1:1)-(8:19): unit_of(z) === s && s === m\n" diff --git a/tests/Camfort/Transformation/CommonSpec.hs b/tests/Camfort/Transformation/CommonSpec.hs --- a/tests/Camfort/Transformation/CommonSpec.hs +++ b/tests/Camfort/Transformation/CommonSpec.hs @@ -5,7 +5,6 @@ import Test.Hspec -import Camfort.Helpers import Camfort.Functionality samplesBase :: FilePath @@ -30,7 +29,7 @@ expectedMod <- runIO $ readSample "cmn.expected.f90" let outFile = samplesBase "common.f90.out" - runIO $ common (samplesBase "common.f90") [] outFile () + runIO $ common (samplesBase "common.f90") [] outFile actual <- runIO $ readSample "common.f90.out" actualMod <- runIO $ readSample "cmn.f90" diff --git a/tests/Camfort/Transformation/EquivalenceElimSpec.hs b/tests/Camfort/Transformation/EquivalenceElimSpec.hs --- a/tests/Camfort/Transformation/EquivalenceElimSpec.hs +++ b/tests/Camfort/Transformation/EquivalenceElimSpec.hs @@ -16,7 +16,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} -module Camfort.Transformation.EquivalenceElimSpec where +module Camfort.Transformation.EquivalenceElimSpec (spec) where import System.FilePath import System.Directory @@ -25,7 +25,6 @@ import Camfort.Transformation.EquivalenceElim import Camfort.Functionality -import Camfort.Helpers import Camfort.Input samplesBase :: FilePath @@ -40,7 +39,7 @@ readActual argumentFilename = do let argumentPath = samplesBase argumentFilename let outFile = argumentPath `addExtension` "out" - equivalences argumentPath [] outFile () + equivalences argumentPath [] outFile actual <- readFile outFile removeFile outFile return actual diff --git a/tests/fixtures/Specification/Stencils/example10.f b/tests/fixtures/Specification/Stencils/example10.f new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Stencils/example10.f @@ -0,0 +1,15 @@ + program example10 + + integer i, imax + parameter (imax = 3) + + real a(0:imax), b(0:imax) + + do 1 i = 1, (imax-1) + if (.true.) then +c= stencil readOnce, (pointed(dim=1)) :: b + a(i) = b(i) + end if + 1 continue + + end diff --git a/tests/fixtures/Specification/Stencils/example11.f b/tests/fixtures/Specification/Stencils/example11.f new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Stencils/example11.f @@ -0,0 +1,14 @@ + program example11 + + integer i, imax + parameter (imax = 3) + + real a(0:imax), b(0:imax), x + + do 1 i = 1, (imax-1) + if (.true.) then + x = b(i) + end if + 1 continue + + end diff --git a/tests/fixtures/Specification/Stencils/example12.f b/tests/fixtures/Specification/Stencils/example12.f new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Stencils/example12.f @@ -0,0 +1,12 @@ + program example12 + implicit none + + integer i + real a(0:10) + + do i = 0, 10 +c= stencil readOnce, (backward(depth=1, dim=1)) :: a + a(i) = a(i) + a(i+1) + end do + + end diff --git a/tests/fixtures/Specification/Stencils/example13.f b/tests/fixtures/Specification/Stencils/example13.f new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Stencils/example13.f @@ -0,0 +1,15 @@ + program example13 + implicit none + + integer i, imax + parameter (imax = 3) + real a(0:imax) + +c= region :: r1 = pointed(dim=1) + do i = 0, imax +c= stencil readOnce, atLeast, r1 :: a +c= stencil readOnce, atMost, forward(depth=2, dim=1) :: a + a(i) = a(i) + a(i+2) + end do + + end diff --git a/tests/fixtures/Specification/Stencils/example14.f b/tests/fixtures/Specification/Stencils/example14.f new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Stencils/example14.f @@ -0,0 +1,14 @@ + program example14 + implicit none + + integer i, imax + parameter (imax = 3) + real a(0:imax) + + do i = 0, imax +c= stencil readOnce, atLeast, pointed(dim=1) :: a +c= stencil readOnce, atLeast, pointed(dim=1) :: a + a(i) = a(i) + a(i+2) + end do + + end diff --git a/tests/fixtures/Specification/Stencils/example15.f b/tests/fixtures/Specification/Stencils/example15.f new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Stencils/example15.f @@ -0,0 +1,13 @@ + program example15 + implicit none + + integer i + real a(0:10) + + do i = 0, 10 +c= stencil readOnce, forward(depth=1, dim=1) :: a +c= stencil readOnce, forward(depth=1, dim=1) :: a + a(i) = a(i) + a(i+1) + end do + + end diff --git a/tests/fixtures/Specification/Stencils/example16.f b/tests/fixtures/Specification/Stencils/example16.f new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Stencils/example16.f @@ -0,0 +1,12 @@ + program example16 + implicit none + + integer i + real a(0:10) + + do i = 0, 10 +c= access readOnce, (forward(depth=1, dim=1)) :: a + a(i) = a(i) + a(i+1) + end do + + end diff --git a/tests/fixtures/Specification/Stencils/example17.f b/tests/fixtures/Specification/Stencils/example17.f new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Stencils/example17.f @@ -0,0 +1,12 @@ + program example16 + implicit none + + integer i + real a(0:10), x + + do i = 0, 10 +c= stencil readOnce, (forward(depth=1, dim=1)) :: a + x = a(i) + a(i+1) + end do + + end 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, (pointed(dim=1))*r2 + (pointed(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) diff --git a/tests/fixtures/Specification/Stencils/example5.f b/tests/fixtures/Specification/Stencils/example5.f new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Stencils/example5.f @@ -0,0 +1,12 @@ + program example5 + implicit none + + integer i, imax + parameter (imax = 3) + real a(0:imax) + + do i = 0, imax + a(i) = a(i) + a(i+2) + end do + + end diff --git a/tests/fixtures/Specification/Stencils/example6.f b/tests/fixtures/Specification/Stencils/example6.f new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Stencils/example6.f @@ -0,0 +1,13 @@ + program example6 + implicit none + + integer i, imax + parameter (imax = 3) + real a(0:imax) + + do i = 0, imax +c= stencil readOnce, atLeast, pointed(dim=1) :: a + a(i) = a(i) + a(i+2) + end do + + end diff --git a/tests/fixtures/Specification/Stencils/example7.f b/tests/fixtures/Specification/Stencils/example7.f new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Stencils/example7.f @@ -0,0 +1,14 @@ + program example7 + implicit none + + integer i, imax + parameter (imax = 3) + real a(0:imax) + + do i = 0, imax +c= stencil readOnce, atLeast, pointed(dim=1) :: a +c= stencil readOnce, atMost, forward(depth=2, dim=1) :: a + a(i) = a(i) + a(i+2) + end do + + end diff --git a/tests/fixtures/Specification/Stencils/example8.f b/tests/fixtures/Specification/Stencils/example8.f new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Stencils/example8.f @@ -0,0 +1,13 @@ + program example8 + implicit none + + integer i, imax + parameter (imax = 3) + real a(0:imax) + + do i = 0, imax +c= stencil readOnce, atMost, forward(depth=2, dim=1) :: a + a(i) = a(i) + a(i+2) + end do + + end diff --git a/tests/fixtures/Specification/Stencils/example9.f b/tests/fixtures/Specification/Stencils/example9.f new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Stencils/example9.f @@ -0,0 +1,13 @@ + program example9 + + integer i, imax + parameter (imax = 3) + + real a(0:imax), b(0:imax) + + do 1 i = 1, (imax-1) +c= stencil readOnce, pointed(dim=1) :: b + a(i) = b(i) + 1 continue + + end diff --git a/tests/fixtures/Specification/Units/example-inconsist-1.f90 b/tests/fixtures/Specification/Units/example-inconsist-1.f90 new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Units/example-inconsist-1.f90 @@ -0,0 +1,8 @@ +program example + implicit none + != unit (s) :: x + != unit (m) :: y + integer :: x, y + integer :: z + z = x + y +end program example