{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, KindSignatures, FlexibleContexts, GADTs, DeriveGeneric #-} {-| This module provides a number of helper functions for working with Fortran syntax that are useful between different analyses and transformations. -} module Analysis.Syntax 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 Analysis.Annotations import Analysis.IntermediateReps import Traverse import Language.Fortran -- * Comparison and ordering {-| 'AnnotationFree' is a data type that wraps other types and denotes terms which should be compared for equality modulo their annotations and source location information -} data AnnotationFree t = AnnotationFree { annotationBound :: t } deriving Show {-| short-hand constructor for 'AnnotationFree' -} af = AnnotationFree {-| short-hand deconstructor for 'AnnotationFree' -} unaf = annotationBound {-| A helpful function, used by the 'Eq AnnotationFree' instance that resets and source location information -} eraseSrcLocs :: (Typeable (t a), Data (t a)) => t a -> t a eraseSrcLocs = transformBi erase' where erase' :: SrcLoc -> SrcLoc erase' _ = SrcLoc { srcFilename = "", srcLine = 0, srcColumn = 0 } {-| Sets the @SrcLoc@ information to have the filename "compact" which triggers a special compact form of pretty printing in the @Show SrcLoc@ instances -} setCompactSrcLocs :: (Typeable (t a), Data (t a)) => t a -> t a setCompactSrcLocs = transformBi cmpact' where cmpact' :: SrcLoc -> SrcLoc cmpact' (SrcLoc _ l c) = SrcLoc { srcFilename = "compact", srcLine = l, srcColumn = c } lower = map toLower -- Here begins varioous 'Eq' instances for instantiations of 'AnnotationFree' instance Eq (AnnotationFree a) => Eq (AnnotationFree [a]) where (AnnotationFree xs) == (AnnotationFree xs') = if (length xs == length xs') then foldl (\b -> \(x, x') -> ((af x) == (af x')) && b) True (zip xs xs') else False instance Eq (AnnotationFree Int) where x == y = (unaf x) == (unaf y) instance Eq (AnnotationFree Char) where x == y = (unaf x) == (unaf y) instance Eq (AnnotationFree (AccessP ())) where x == y = (unaf x) == (unaf y) instance (Eq (AnnotationFree a), Eq (AnnotationFree b)) => Eq (AnnotationFree (a, b)) where (AnnotationFree (x, y)) == (AnnotationFree (x', y')) = ((af x) == (af x')) && ((af y) == (af y')) instance Eq (AnnotationFree (Expr a)) where -- Compute variable equality modulo annotations and spans (AnnotationFree (Var _ _ vs)) == (AnnotationFree (Var _ _ vs')) = cmp vs vs' where cmp [] [] = True cmp ((VarName _ v,es):vs) ((VarName _ v',es'):vs') = -- Since whether variable names are upper or lower case is irrelevant -- in Fortran, we must compare variables for equality by normalising first -- (here to lower case) if (lower v) == (lower v') then (and (map (\(e, e') -> (af e) == (af e')) (zip es es'))) && (cmp vs vs') else False cmp _ _ = False -- For other expressions we can get away with reseting their annotations are erasing their source locs (AnnotationFree e1) == (AnnotationFree e2) = (eraseSrcLocs $ fmap (const ()) e1) == (eraseSrcLocs $ fmap (const ()) e2) instance Eq (AnnotationFree (Type a)) where (AnnotationFree (BaseType _ b attrs e1 e2)) == (AnnotationFree (BaseType _ b' attrs' e1' e2')) = (af b == af b') && (af attrs == af attrs') && (af e1 == af e1') && (af e2 == af e2') (AnnotationFree (ArrayT _ eps b attrs e1 e2)) == (AnnotationFree (ArrayT _ eps' b' attrs' e1' e2')) = (af eps == af eps') && (af b == af b') && (af attrs == af attrs') && (af e1 == af e1') && (af e2 == af e2') instance Eq (AnnotationFree (Attr p)) where (AnnotationFree (Dimension _ es)) == (AnnotationFree (Dimension _ es')) = af es == af es' (AnnotationFree x) == (AnnotationFree y) = (fmap (const ()) x) == (fmap (const ()) y) instance Eq (AnnotationFree (BaseType p)) where (AnnotationFree (DerivedType _ s)) == (AnnotationFree (DerivedType _ s')) = (af s) == (af s') (AnnotationFree x) == (AnnotationFree y) = (fmap (const ()) x) == (fmap (const ()) y) instance Eq (AnnotationFree (SubName p)) where (AnnotationFree (SubName _ s)) == (AnnotationFree (SubName _ s')) = (lower s) == (lower s') (AnnotationFree (NullSubName _)) == (AnnotationFree (NullSubName _)) = True _ == _ = False instance Eq (AnnotationFree (IntentAttr p)) where (AnnotationFree x) == (AnnotationFree y) = (fmap (const ()) x) == (fmap (const ()) y) instance Eq (AnnotationFree (MeasureUnitSpec p)) where (AnnotationFree (UnitProduct _ u)) == (AnnotationFree (UnitProduct _ u')) = (af u) == (af u') (AnnotationFree (UnitQuotient _ u1 u2)) == (AnnotationFree (UnitQuotient _ u1' u2')) = (af u1 == af u1') && (af u2 == af u2') (AnnotationFree (UnitNone _)) == (AnnotationFree (UnitNone _)) = True _ == _ = False instance Eq (AnnotationFree (Fraction p)) where (AnnotationFree (IntegerConst _ n)) == (AnnotationFree (IntegerConst _ n')) = (af n) == (af n') (AnnotationFree (FractionConst _ p q)) == (AnnotationFree (FractionConst _ p' q')) = (af p == af p') && (af q == af q') (AnnotationFree (NullFraction _)) == (AnnotationFree (NullFraction _)) = True _ == _ = False {-| Ordering on accessor syntax -} instance Ord (AccessP ()) where (VarA s1) <= (VarA s2) = s1 <= s2 (ArrayA s1 e1) <= (ArrayA s2 e2) = if (s1 == s2) then e1 <= e2 else s1 <= s2 (VarA s1) <= (ArrayA s2 e1) = True _ <= _ = False {-| Partial-ordering for expressions (constructors only so far), ignores annotations -} instance Eq p => Ord (Expr p) where (Con _ _ c) <= (Con _ _ c') = c <= c' e <= e' = error "Ordering on expressions only for constructors so far" -- * Accessor functions for extracting various pieces of information out of syntax trees {-| Extracts the subprocedure name from a program unit -} getSubName :: ProgUnit p -> Maybe String getSubName (Main _ _ (SubName _ s) _ _ _) = Just s getSubName (Sub _ _ _ (SubName _ s) _ _) = Just s getSubName (Function _ _ _ (SubName _ s) _ _ _) = Just s getSubName (Module _ _ (SubName _ s) _ _ _ _) = Just s getSubName (BlockData _ _ (SubName _ s) _ _ _) = Just s getSubName _ = Nothing {-| Extracts all accessors (variables and array indexing) from a piece of syntax -} accesses f = nub $ [VarA (lower v) | (AssgExpr _ _ v _) <- (universeBi f)::[Expr Annotation]] ++ concat [varExprToAccesses ve | ve@(Var _ _ _) <- (universeBi f)::[Expr Annotation]] {-| Extracts a string of the (root) variable name from a variable expression (if it is indeed a variable expression -} varExprToVariable :: Expr a -> Maybe Variable varExprToVariable (Var _ _ ((VarName _ v, es):_)) = Just v varExprToVariable _ = Nothing {-| Extracts an 'accessor' form a variable from a variable expression -} varExprToAccess :: Expr a -> Maybe Access varExprToAccess v = varExprToVariable v >>= (Just . VarA) {-| Extracts all 'accessors' from a variable expression e.g., @varExprToAccess@ on the syntax tree coming from @a(i, j)@ returns a list of @[VarA "a", VarA "i", VarA "j"]@ -} varExprToAccesses :: Expr a -> [Access] varExprToAccesses (Var _ _ ves) = [mkAccess v es | (VarName _ v, es) <- ves, all isConstant es] where mkAccess v [] = VarA v mkAccess v es = ArrayA v (map (fmap (const ())) es) varExprToAccesses _ = [] class Successors t where {-| Computes the 'root' successor from the current -} successorsRoot :: t a -> [t a] {-| Computes the successors nodes of a CFG (described by a zipper) for certain node types -} successors :: (Eq a, Typeable a) => Zipper (ProgUnit a) -> [t a] instance Successors Fortran where successorsRoot (FSeq _ _ f1 f2) = [f1] successorsRoot (For _ _ _ _ _ _ f) = [f] successorsRoot (If _ _ _ f efs f') = [f] successorsRoot (Forall _ _ _ f) = [f] successorsRoot (Where _ _ _ f Nothing) = [f] successorsRoot (Where _ _ _ f (Just f')) = [f, f'] successorsRoot (Label _ _ _ f) = [f] successorsRoot _ = [] successors = successorsF where successorsF :: forall a . (Eq a, Typeable a) => Zipper (ProgUnit a) -> [Fortran a] successorsF z = maybe [] id (do f <- (getHole z)::(Maybe (Fortran a)) ss <- return $ successorsRoot f return $ ss ++ seekUp f (Just z)) seekUp :: forall a . (Eq a, Typeable a) => Fortran a -> Maybe (Zipper (ProgUnit a)) -> [Fortran a] seekUp f z = case (z >>= up >>= getHole)::(Maybe (Fortran a)) of Just uf -> case uf of (FSeq _ _ f1 f2) -> if (f == f1) then [f2] else seekUp uf (z >>= up) (For _ _ _ _ _ _ f') -> seekUp uf (z >>= up) (If _ _ _ gf efs f') -> if (f == gf) then (maybe [] (:[]) f') ++ (map snd efs) else seekUp uf (z >>= up) (Forall _ _ _ f') -> seekUp uf (z >>= up) (Where _ _ _ f' _) -> seekUp uf (z >>= up) (Label _ _ _ f') -> seekUp uf (z >>= up) _ -> [] Nothing -> [] {-| extract all 'right-hand side' expressions e.g. @rhsExpr (parse "x = e") = parse "e"@ -} rhsExpr :: Fortran Annotation -> [Expr Annotation] rhsExpr (Assg _ _ _ e2) = (universeBi e2)::[Expr Annotation] rhsExpr (For _ _ v e1 e2 e3 _) = ((universeBi e1)::[Expr Annotation]) ++ ((universeBi e2)::[Expr Annotation]) ++ ((universeBi e3)::[Expr Annotation]) rhsExpr (If _ _ e f1 fes f3) = ((universeBi e)::[Expr Annotation]) rhsExpr (Allocate x sp e1 e2) = ((universeBi e1)::[Expr Annotation]) ++ ((universeBi e2)::[Expr Annotation]) rhsExpr (Call _ _ e as) = ((universeBi e)::[Expr Annotation]) ++ ((universeBi as)::[Expr Annotation]) rhsExpr (Deallocate _ _ es e) = (concatMap (\e -> (universeBi e)::[Expr Annotation]) es) ++ ((universeBi e)::[Expr Annotation]) rhsExpr (Forall _ _ (es, e) f) = concatMap (\(_, e1, e2, e3) -> -- TODO: maybe different here ((universeBi e1)::[Expr Annotation]) ++ ((universeBi e2)::[Expr Annotation]) ++ ((universeBi e3)::[Expr Annotation])) es ++ ((universeBi e)::[Expr Annotation]) rhsExpr (Nullify _ _ es) = concatMap (\e -> (universeBi e)::[Expr Annotation]) es rhsExpr (Inquire _ _ s es) = concatMap (\e -> (universeBi e)::[Expr Annotation]) es rhsExpr (Stop _ _ e) = (universeBi e)::[Expr Annotation] rhsExpr (Where _ _ e f _) = (universeBi e)::[Expr Annotation] rhsExpr (Write _ _ s es) = concatMap (\e -> (universeBi e)::[Expr Annotation]) es rhsExpr (PointerAssg _ _ _ e2) = (universeBi e2)::[Expr Annotation] rhsExpr (Return _ _ e) = (universeBi e)::[Expr Annotation] rhsExpr (Print _ _ e es) = ((universeBi e)::[Expr Annotation]) ++ (concatMap (\e -> (universeBi e)::[Expr Annotation]) es) rhsExpr (ReadS _ _ s es) = concatMap (\e -> (universeBi e)::[Expr Annotation]) es -- rhsExpr (Label x sp s f) = rhsExpr f rhsExpr _ = [] {-| extract all 'left-hand side' expressions e.g. @rhsExpr (parse "x = e") = parse "x"@ -} lhsExpr :: Fortran Annotation -> [Expr Annotation] lhsExpr (Assg _ _ e1 e2) = ((universeBi e1)::[Expr Annotation]) lhsExpr (For x sp v e1 e2 e3 fs) = [Var x sp [(v, [])]] lhsExpr (PointerAssg _ _ e1 e2) = ((universeBi e1)::[Expr Annotation]) lhsExpr t = [] -- concatMap lhsExpr ((children t)::[Fortran Annotation]) -- * Various simple analyses {-| Set a default monoid instances for Int -} instance Monoid Int where mempty = 0 mappend = (+) {-| Counts the number of declarations (of variables) in a whole program -} countVariableDeclarations :: Program Annotation -> Int countVariableDeclarations x = sum [length xs | (Decl _ _ xs _) <- (universeBi x)::[Decl Annotation]] {-| Numbers all the statements in a program unit (successively) which is useful for analysis output -} numberStmts :: ProgUnit Annotation -> ProgUnit Annotation numberStmts x = let numberF :: Fortran Annotation -> State Int (Fortran Annotation) numberF = descendBiM number' number' :: Annotation -> State Int Annotation -- actually numbers more than just statements, but this doesn't matter number' x = do n <- get put (n + 1) return $ x { number = n } in fst $ runState (descendBiM numberF x) 0 {-| All variables from a Fortran syntax tree -} variables f = nub $ map (map toLower) $ [v | (AssgExpr _ _ v _) <- (universeBi f)::[Expr Annotation]] ++ [v | (VarName _ v) <- (universeBi f)::[VarName Annotation]] {-| A predicate on whether an expression is actually a constant constructor -} isConstant :: Expr p -> Bool isConstant (Con _ _ _) = True isConstant (ConL _ _ _ _) = True isConstant (ConS _ _ _) = True isConstant _ = False {-| Free-variables in a piece of Fortran syntax -} freeVariables :: (Data (t a), Data a) => t a -> [String] freeVariables f = (variables f) \\ (binders f) {-| All variables from binders -} binders :: forall a t . (Data (t a), Typeable (t a), Data a, Typeable a) => t a -> [String] binders f = nub $ [v | (ArgName _ v) <- (universeBi f)::[ArgName a]] ++ [v | (VarName _ v) <- (universeBi ((universeBi f)::[Decl a]))::[VarName a]] ++ [v | (For _ _ (VarName _ v) _ _ _ _) <- (universeBi f)::[Fortran a]] {-| Tests whether an expression is an affine transformation (without scaling) on some variable, if so returns the variable and the translation factor -} affineMatch (Bin _ _ (Plus _) (Var _ _ [(VarName _ v, _)]) (Con _ _ n)) = Just (v, read n) affineMatch (Bin _ _ (Plus _) (Con _ _ n) (Var _ _ [(VarName _ v, _)])) = Just (v, read n) affineMatch (Bin _ _ (Minus _) (Var _ _ [(VarName _ v, _)]) (Con _ _ n)) = Just (v, - read n) affineMatch (Bin _ _ (Minus _) (Con _ _ n) (Var _ _ [(VarName _ v, _)])) = Just (v, - read n) affineMatch (Var _ _ [(VarName _ v, _)]) = Just (v, 0) affineMatch _ = Nothing -- * An embedded domain-specific language for describing syntax tree queries {-| 'QueryCmd' provides 'commands' of which pieces of syntax to find -} data QueryCmd t where Exprs :: QueryCmd (Expr Annotation) Blocks :: QueryCmd (Block Annotation) Decls :: QueryCmd (Decl Annotation) Locs :: QueryCmd Access Vars :: QueryCmd (Expr Annotation) {-| 'from' takes a command as its first parameter, a piece of syntax as its second, and returns all pieces of syntax matching the query request. For example: @from Decls x@ returns a list of all declarations in @x@, of type @[Decl Annotation]@ If @x@ is itself a declaration then this is returned as well (so be careful with recursive functions over things defined in turns of 'from'. See 'topFrom' for a solution to this. -} from :: forall t synTyp . (Data t, Data synTyp) => QueryCmd synTyp -> t -> [synTyp] from Locs x = accesses x from Vars x = [v | v@(Var _ _ _) <- (universeBi x)::[Expr Annotation]] from _ x = (universeBi x)::[synTyp] {-| 'topFrom' takes a command as first parameter, a piece of syntax as its second, and returns all pieces of syntax matching the query request that are *children* of the current piece of syntax. This means that it will not return itself. -} topFrom :: forall t synTyp . (Data t, Data synTyp) => QueryCmd synTyp -> t -> [synTyp] topFrom Locs x = accesses x topFrom _ x = (childrenBi x)::[synTyp]