{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE Strict     #-}
-- | Facts about a whole program, found by analysing each of its translation
-- units without knowing anything about the rest, and joining what they show.
--
-- A field's values are the values the program stores in it, as long as it
-- only changes the field in ways the analysis sees. A function's results are
-- the values it returns, and a static function's parameters are the values its
-- direct calls pass, as long as nothing takes its address. A function's reach
-- into what a pointer parameter points to is the furthest of its own accesses
-- there, as long as its parameters bound each of them.
module Tokstyle.C.Analysis.Program
    ( Observed
    , Analysed
    , analysedWith
    , observe
    , programFrom
    ) where

import           Control.Monad                    (forM)
import           Data.List                        (isPrefixOf)
import           Data.Map.Strict                  (Map)
import qualified Data.Map.Strict                  as Map
import           Data.Maybe                       (catMaybes, fromMaybe, isJust,
                                                   isNothing, maybeToList)
import qualified Data.Set                         as Set
import           Language.C.Analysis.DeclAnalysis (analyseTypeDecl)
import           Language.C.Analysis.SemRep       (CompType (..), FunDef (..),
                                                   FunType (..),
                                                   GlobalDecls (..),
                                                   IdentDecl (..), ObjDef (..),
                                                   TagDef (..), Type (..),
                                                   TypeName (..), VarDecl (..),
                                                   VarName (..), constant,
                                                   declName, declType)
import           Language.C.Analysis.TravMonad    (MonadTrav, catchTravError,
                                                   lookupObject)
import           Language.C.Analysis.TypeUtils    (canonicalType, typeQuals)
import           Language.C.Data.Ident            (SUERef (..), identToString)
import           Language.C.Data.Node             (posOfNode, undefNode)
import           Language.C.Data.Position         (isSourcePos, posFile)
import           Language.C.Syntax.AST
import           Language.C.Syntax.Constants      (getCInteger)
import           Tokstyle.Analysis.AccessPath     (AccessPath (..))
import           Tokstyle.C.Analysis.Access       (Access (..), accesses,
                                                   changedNames)
import           Tokstyle.C.Analysis.CFG          (Node (..), NodeKind (..))
import           Tokstyle.C.Analysis.Interval     (Facts, Function, IntTy (..),
                                                   Linear (..), Origin (..),
                                                   Program (..), Range (..),
                                                   Term (..), TermKind (..),
                                                   anySum, atMost, constantSum,
                                                   convert, dependsOn,
                                                   emptyProgram, eval, intType,
                                                   normalise, pathSum, plus,
                                                   scale, solveFunction,
                                                   subTerms, translate)
import           Tokstyle.C.Analysis.Known        (Reach (..), harmless)
import           Tokstyle.C.Analysis.Syntax       (exprChildren, initExprs,
                                                   localDecls, statExprs)
import           Tokstyle.C.Analysis.Types        (FieldKey, exprType, fieldKey,
                                                   funKey, funType, structTag)


-- | Values seen for a field, a result or a parameter, with their type if
-- known.
type Values = (Maybe IntTy, [Range])

-- | Something a translation unit shows about the program.
data Observation
    = Stored FieldKey Values
    | Escaped FieldKey
    -- ^ A field changed in ways the analysis doesn't see.
    | EscapedTag String
    -- ^ A struct whose fields change in ways the analysis doesn't see.
    | HandedTo String [String]
    -- ^ Structs a function gets a pointer to that it may write through, or
    -- returns. Unless the program defines the function, their fields change
    -- in ways the analysis doesn't see.
    | Returned String Values
    | Passed String [Maybe Values]
    -- ^ The values a static function gets for each parameter.
    | Addressed String
    -- ^ A function used other than by calling it.
    | Defined String
    | Reaches String Reach
    -- ^ How far one of a function's accesses reaches into what a pointer
    -- parameter points to.
    | Unbounded String Int
    -- ^ How far one of a function's accesses reaches into what a pointer
    -- parameter points to isn't a multiple of a parameter plus a constant.

type Observed = [Observation]

-- | A function, with the facts before each of its nodes when nothing is known
-- about the rest of the program.
type Analysed = (FunDef, Function, [(Node, Facts, [Term])])

-- | The facts before each node of a function, knowing what is known about the
-- program.
analysedWith :: Program -> Analysed -> [(Node, Facts, [Term])]
analysedWith :: Program -> Analysed -> [(Node, Facts, [Term])]
analysedWith Program
prog (FunDef
_, Function
fn, [(Node, Facts, [Term])]
known)
    | Program -> Function -> Bool
dependsOn Program
prog Function
fn = Program -> Function -> [(Node, Facts, [Term])]
solveFunction Program
prog Function
fn
    | Bool
otherwise = [(Node, Facts, [Term])]
known

-- | Forgets where values came from: facts about the program carry bounds and
-- which values are reduced indices, not which ones wrapped around.
plain :: [Range] -> [Range]
plain :: [Range] -> [Range]
plain = (Range -> Range) -> [Range] -> [Range]
forall a b. (a -> b) -> [a] -> [b]
map ((Range -> Range) -> [Range] -> [Range])
-> (Range -> Range) -> [Range] -> [Range]
forall a b. (a -> b) -> a -> b
$ \Range
r -> if Range -> Origin
origin Range
r Origin -> Origin -> Bool
forall a. Eq a => a -> a -> Bool
== Origin
Reduced then Range
r else Range
r { origin = Plain }

-- | Facts that say no more than a value's type are left out.
programFrom :: Observed -> Program
programFrom :: Observed -> Program
programFrom Observed
obs = Program
    { progFields :: Map FieldKey [Range]
progFields = [(FieldKey, [Range])] -> Map FieldKey [Range]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (FieldKey
k, [Range]
v)
        | (k :: FieldKey
k@(String
tag, String
_), (Maybe IntTy
ty, [Range]
vs)) <- Map FieldKey (Maybe IntTy, [Range])
-> [(FieldKey, (Maybe IntTy, [Range]))]
forall k a. Map k a -> [(k, a)]
Map.toList (((Maybe IntTy, [Range])
 -> (Maybe IntTy, [Range]) -> (Maybe IntTy, [Range]))
-> [(FieldKey, (Maybe IntTy, [Range]))]
-> Map FieldKey (Maybe IntTy, [Range])
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (Maybe IntTy, [Range])
-> (Maybe IntTy, [Range]) -> (Maybe IntTy, [Range])
forall {a} {a}. (Maybe a, [a]) -> (Maybe a, [a]) -> (Maybe a, [a])
joinValues [ (FieldKey
k', (Maybe IntTy, [Range])
v) | Stored FieldKey
k' (Maybe IntTy, [Range])
v <- Observed
obs ])
        , String
tag String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set String
escapedTags
        , FieldKey
k FieldKey -> Set FieldKey -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set FieldKey
escaped
        , let v :: [Range]
v = [Range] -> [Range]
invariant [Range]
vs
        , Bool -> Bool
not (Maybe IntTy -> [Range] -> Bool
trivial Maybe IntTy
ty [Range]
v)
        ]
    , progReturns :: Map String [Range]
progReturns = [(String, [Range])] -> Map String [Range]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (String
k, [Range]
v)
        | (String
k, (Maybe IntTy
ty, [Range]
vs)) <- Map String (Maybe IntTy, [Range])
-> [(String, (Maybe IntTy, [Range]))]
forall k a. Map k a -> [(k, a)]
Map.toList (((Maybe IntTy, [Range])
 -> (Maybe IntTy, [Range]) -> (Maybe IntTy, [Range]))
-> [(String, (Maybe IntTy, [Range]))]
-> Map String (Maybe IntTy, [Range])
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (Maybe IntTy, [Range])
-> (Maybe IntTy, [Range]) -> (Maybe IntTy, [Range])
forall {a} {a}. (Maybe a, [a]) -> (Maybe a, [a]) -> (Maybe a, [a])
joinValues [ (String
k', (Maybe IntTy, [Range])
v) | Returned String
k' (Maybe IntTy, [Range])
v <- Observed
obs ])
        , String
k String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
defined
        , let v :: [Range]
v = [Range] -> [Range]
normalise [Range]
vs
        , Bool -> Bool
not (Maybe IntTy -> [Range] -> Bool
trivial Maybe IntTy
ty [Range]
v)
        ]
    , progParams :: Map String [Maybe [Range]]
progParams = [(String, [Maybe [Range]])] -> Map String [Maybe [Range]]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (String
k, [Maybe [Range]]
ps)
        | (String
k, [Maybe (Maybe IntTy, [Range])]
args) <- Map String [Maybe (Maybe IntTy, [Range])]
-> [(String, [Maybe (Maybe IntTy, [Range])])]
forall k a. Map k a -> [(k, a)]
Map.toList (([Maybe (Maybe IntTy, [Range])]
 -> [Maybe (Maybe IntTy, [Range])]
 -> [Maybe (Maybe IntTy, [Range])])
-> [(String, [Maybe (Maybe IntTy, [Range])])]
-> Map String [Maybe (Maybe IntTy, [Range])]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith ((Maybe (Maybe IntTy, [Range])
 -> Maybe (Maybe IntTy, [Range]) -> Maybe (Maybe IntTy, [Range]))
-> [Maybe (Maybe IntTy, [Range])]
-> [Maybe (Maybe IntTy, [Range])]
-> [Maybe (Maybe IntTy, [Range])]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Maybe (Maybe IntTy, [Range])
x Maybe (Maybe IntTy, [Range])
y -> (Maybe IntTy, [Range])
-> (Maybe IntTy, [Range]) -> (Maybe IntTy, [Range])
forall {a} {a}. (Maybe a, [a]) -> (Maybe a, [a]) -> (Maybe a, [a])
joinValues ((Maybe IntTy, [Range])
 -> (Maybe IntTy, [Range]) -> (Maybe IntTy, [Range]))
-> Maybe (Maybe IntTy, [Range])
-> Maybe ((Maybe IntTy, [Range]) -> (Maybe IntTy, [Range]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Maybe IntTy, [Range])
x Maybe ((Maybe IntTy, [Range]) -> (Maybe IntTy, [Range]))
-> Maybe (Maybe IntTy, [Range]) -> Maybe (Maybe IntTy, [Range])
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Maybe IntTy, [Range])
y)) [ (String
k', [Maybe (Maybe IntTy, [Range])]
a) | Passed String
k' [Maybe (Maybe IntTy, [Range])]
a <- Observed
obs ])
        , String
k String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
defined, String
k String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set String
addressed
        , let ps :: [Maybe [Range]]
ps = (Maybe (Maybe IntTy, [Range]) -> Maybe [Range])
-> [Maybe (Maybe IntTy, [Range])] -> [Maybe [Range]]
forall a b. (a -> b) -> [a] -> [b]
map Maybe (Maybe IntTy, [Range]) -> Maybe [Range]
known [Maybe (Maybe IntTy, [Range])]
args
        , (Maybe [Range] -> Bool) -> [Maybe [Range]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Maybe [Range] -> Bool
forall a. Maybe a -> Bool
isJust [Maybe [Range]]
ps
        ]
    , progReaches :: Map String [Reach]
progReaches = ([Reach] -> [Reach] -> [Reach])
-> [(String, [Reach])] -> Map String [Reach]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [Reach] -> [Reach] -> [Reach]
forall a. [a] -> [a] -> [a]
(++)
        [ (String
k, [Int -> Maybe (Int, Integer) -> Integer -> Reach
Reach Int
p Maybe (Int, Integer)
l ([Integer] -> Integer
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((Reach -> Integer) -> [Reach] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map Reach -> Integer
reachConst [Reach]
rs))])
        | ((String
k, Int
p), rs :: [Reach]
rs@(Reach Int
_ Maybe (Int, Integer)
l Integer
_ : [Reach]
_)) <- Map (String, Int) [Reach] -> [((String, Int), [Reach])]
forall k a. Map k a -> [(k, a)]
Map.toList (([Reach] -> [Reach] -> [Reach])
-> [((String, Int), [Reach])] -> Map (String, Int) [Reach]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [Reach] -> [Reach] -> [Reach]
forall a. [a] -> [a] -> [a]
(++) [ ((String
k', Reach -> Int
reachParam Reach
r), [Reach
r]) | Reaches String
k' Reach
r <- Observed
obs ])
        , String
k String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
defined
        , (String
k, Int
p) (String, Int) -> Set (String, Int) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set (String, Int)
unbounded
        , (Reach -> Bool) -> [Reach] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Maybe (Int, Integer) -> Maybe (Int, Integer) -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe (Int, Integer)
l) (Maybe (Int, Integer) -> Bool)
-> (Reach -> Maybe (Int, Integer)) -> Reach -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reach -> Maybe (Int, Integer)
reachLength) [Reach]
rs
        ]
    }
  where
    defined :: Set String
defined = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [ String
f | Defined String
f <- Observed
obs ]
    addressed :: Set String
addressed = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [ String
f | Addressed String
f <- Observed
obs ]
    escaped :: Set FieldKey
escaped = [FieldKey] -> Set FieldKey
forall a. Ord a => [a] -> Set a
Set.fromList [ FieldKey
k | Escaped FieldKey
k <- Observed
obs ]
    escapedTags :: Set String
escapedTags = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList ([String] -> Set String) -> [String] -> Set String
forall a b. (a -> b) -> a -> b
$ [ String
tag | EscapedTag String
tag <- Observed
obs ]
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
tag | HandedTo String
f [String]
tags <- Observed
obs, String
f String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set String
defined, String
tag <- [String]
tags ]

    unbounded :: Set (String, Int)
unbounded = [(String, Int)] -> Set (String, Int)
forall a. Ord a => [a] -> Set a
Set.fromList [ (String
k, Int
p) | Unbounded String
k Int
p <- Observed
obs ]

    joinValues :: (Maybe a, [a]) -> (Maybe a, [a]) -> (Maybe a, [a])
joinValues (Maybe a
t1, [a]
a) (Maybe a
t2, [a]
b) = (Maybe a -> (a -> Maybe a) -> Maybe a -> Maybe a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe a
t2 a -> Maybe a
forall a. a -> Maybe a
Just Maybe a
t1, [a]
a [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
b)

    known :: Maybe (Maybe IntTy, [Range]) -> Maybe [Range]
known = \case
        Just (Maybe IntTy
ty, [Range]
vs) | let v :: [Range]
v = [Range] -> [Range]
normalise [Range]
vs, Bool -> Bool
not (Maybe IntTy -> [Range] -> Bool
trivial Maybe IntTy
ty [Range]
v) -> [Range] -> Maybe [Range]
forall a. a -> Maybe a
Just [Range]
v
        Maybe (Maybe IntTy, [Range])
_                                                        -> Maybe [Range]
forall a. Maybe a
Nothing

    trivial :: Maybe IntTy -> [Range] -> Bool
trivial Maybe IntTy
ty [Range]
v = case (Maybe IntTy
ty, [Range]
v) of
        (Just IntTy
t, [Range Integer
l Integer
h Origin
Plain]) -> Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Range -> Integer
lo (IntTy -> Range
tyRange IntTy
t) Bool -> Bool -> Bool
&& Integer
h Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Range -> Integer
hi (IntTy -> Range
tyRange IntTy
t)
        (Maybe IntTy, [Range])
_                           -> Bool
False

    -- Zero is always among a field's values: memory starts out zeroed. A
    -- constant within an index range keeps it an index range.
    invariant :: [Range] -> [Range]
invariant [Range]
vs =
        let vals :: [Range]
vals = Integer -> Integer -> Origin -> Range
Range Integer
0 Integer
0 Origin
Plain Range -> [Range] -> [Range]
forall a. a -> [a] -> [a]
: [Range]
vs
            reduced :: [Range]
reduced = [ Range
r | Range
r <- [Range]
vals, Range -> Origin
origin Range
r Origin -> Origin -> Bool
forall a. Eq a => a -> a -> Bool
== Origin
Reduced ]
            absorbed :: Range -> Bool
absorbed Range
r = Range -> Integer
lo Range
r Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Range -> Integer
hi Range
r Bool -> Bool -> Bool
&& Range -> Origin
origin Range
r Origin -> Origin -> Bool
forall a. Eq a => a -> a -> Bool
== Origin
Plain
                Bool -> Bool -> Bool
&& (Range -> Bool) -> [Range] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Range
x -> Range -> Integer
lo Range
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Range -> Integer
lo Range
r Bool -> Bool -> Bool
&& Range -> Integer
hi Range
r Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Range -> Integer
hi Range
x) [Range]
reduced
        in [Range] -> [Range]
normalise ((Range -> Bool) -> [Range] -> [Range]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Range -> Bool) -> Range -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> Bool
absorbed) [Range]
vals)

-- | What a translation unit shows about the program, and the analysis of the
-- functions it defines that are wanted.
observe :: MonadTrav m => (FunDef -> Bool) -> FilePath -> Map String [IdentDecl] -> GlobalDecls -> m (Observed, [Analysed])
observe :: forall (m :: * -> *).
MonadTrav m =>
(FunDef -> Bool)
-> String
-> Map String [IdentDecl]
-> GlobalDecls
-> m (Observed, [Analysed])
observe FunDef -> Bool
wanted String
unit Map String [IdentDecl]
locals GlobalDecls
decls = do
    [(Observed, [Analysed])]
perFunction <- [(Ident, FunDef)]
-> ((Ident, FunDef) -> m (Observed, [Analysed]))
-> m [(Observed, [Analysed])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ (Ident
i, FunDef
fd) | FunctionDef fd :: FunDef
fd@(FunDef (VarDecl (VarName Ident
i Maybe AsmName
_) DeclAttrs
_ Type
_) Stmt
_ NodeInfo
_) <- [IdentDecl]
objs ] (((Ident, FunDef) -> m (Observed, [Analysed]))
 -> m [(Observed, [Analysed])])
-> ((Ident, FunDef) -> m (Observed, [Analysed]))
-> m [(Observed, [Analysed])]
forall a b. (a -> b) -> a -> b
$ \(Ident
i, FunDef
fd) -> do
        (Observed
o, Analysed
analysed) <- String -> [IdentDecl] -> FunDef -> m (Observed, Analysed)
forall (m :: * -> *).
MonadTrav m =>
String -> [IdentDecl] -> FunDef -> m (Observed, Analysed)
observeFunction String
unit ([IdentDecl] -> String -> Map String [IdentDecl] -> [IdentDecl]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] (Ident -> String
identToString Ident
i) Map String [IdentDecl]
locals) FunDef
fd
        (Observed, [Analysed]) -> m (Observed, [Analysed])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Observed
o, [ Analysed
analysed | FunDef -> Bool
wanted FunDef
fd ])
    [Observed]
perObject <- [ObjDef] -> (ObjDef -> m Observed) -> m [Observed]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ ObjDef
od | ObjectDef ObjDef
od <- [IdentDecl]
objs ] (String -> ObjDef -> m Observed
forall (m :: * -> *). MonadTrav m => String -> ObjDef -> m Observed
observeObject String
unit)
    (Observed, [Analysed]) -> m (Observed, [Analysed])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ( ((Observed, [Analysed]) -> Observed)
-> [(Observed, [Analysed])] -> Observed
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Observed, [Analysed]) -> Observed
forall a b. (a, b) -> a
fst [(Observed, [Analysed])]
perFunction Observed -> Observed -> Observed
forall a. [a] -> [a] -> [a]
++ [Observed] -> Observed
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Observed]
perObject Observed -> Observed -> Observed
forall a. [a] -> [a] -> [a]
++ (String -> Observation) -> [String] -> Observed
forall a b. (a -> b) -> [a] -> [b]
map String -> Observation
EscapedTag (Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
externalTags)
           , ((Observed, [Analysed]) -> [Analysed])
-> [(Observed, [Analysed])] -> [Analysed]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Observed, [Analysed]) -> [Analysed]
forall a b. (a, b) -> b
snd [(Observed, [Analysed])]
perFunction )
  where
    objs :: [IdentDecl]
objs = Map Ident IdentDecl -> [IdentDecl]
forall k a. Map k a -> [a]
Map.elems (GlobalDecls -> Map Ident IdentDecl
gObjs GlobalDecls
decls)
    -- Structs the project doesn't define, like the system's, change in ways
    -- the analysis doesn't see.
    externalTags :: Set String
externalTags = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList
        [ Ident -> String
identToString Ident
i
        | (NamedRef Ident
i, CompDef (CompType SUERef
_ CompTyKind
_ [MemberDecl]
_ Attributes
_ NodeInfo
ni)) <- Map SUERef TagDef -> [(SUERef, TagDef)]
forall k a. Map k a -> [(k, a)]
Map.toList (GlobalDecls -> Map SUERef TagDef
gTags GlobalDecls
decls)
        , let pos :: Position
pos = NodeInfo -> Position
posOfNode NodeInfo
ni
        , Bool -> Bool
not (Position -> Bool
isSourcePos Position
pos) Bool -> Bool -> Bool
|| String
"/" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` Position -> String
posFile Position
pos
        ]

observeObject :: MonadTrav m => FilePath -> ObjDef -> m Observed
observeObject :: forall (m :: * -> *). MonadTrav m => String -> ObjDef -> m Observed
observeObject String
unit (ObjDef (VarDecl VarName
_ DeclAttrs
_ Type
ty) Maybe Initializer
ini NodeInfo
_) = case Maybe Initializer
ini of
    Just Initializer
i  -> Observed -> Observed -> Observed
forall a. Semigroup a => a -> a -> a
(<>) (Observed -> Observed -> Observed)
-> m Observed -> m (Observed -> Observed)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Initializer -> m Observed
forall (m :: * -> *).
MonadTrav m =>
Type -> Initializer -> m Observed
initializer Type
ty Initializer
i m (Observed -> Observed) -> m Observed -> m Observed
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (CExpr -> m Observed) -> [CExpr] -> m Observed
forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
foldMapM (String -> CExpr -> m Observed
forall (m :: * -> *). MonadTrav m => String -> CExpr -> m Observed
observeExpr String
unit) (Initializer -> [CExpr]
initExprs Initializer
i)
    Maybe Initializer
Nothing -> Observed -> m Observed
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Observed
forall a. Monoid a => a
mempty

foldMapM :: (Monad m, Monoid b) => (a -> m b) -> [a] -> m b
foldMapM :: forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
foldMapM a -> m b
f [a]
xs = [b] -> b
forall a. Monoid a => [a] -> a
mconcat ([b] -> b) -> m [b] -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> m b) -> [a] -> m [b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM a -> m b
f [a]
xs

-- | What an initialiser for an object of a type stores in its fields.
initializer :: MonadTrav m => Type -> CInit -> m Observed
initializer :: forall (m :: * -> *).
MonadTrav m =>
Type -> Initializer -> m Observed
initializer Type
ty = \case
    CInitList CInitializerList NodeInfo
items NodeInfo
_ | Just String
tag <- Type -> Maybe String
structTag Type
ty -> Observed -> m Observed
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Observed -> m Observed) -> Observed -> m Observed
forall a b. (a -> b) -> a -> b
$ [Observed] -> Observed
forall a. Monoid a => [a] -> a
mconcat ((([CPartDesignator NodeInfo], Initializer) -> Observed)
-> CInitializerList NodeInfo -> [Observed]
forall a b. (a -> b) -> [a] -> [b]
map (String -> ([CPartDesignator NodeInfo], Initializer) -> Observed
forall {a} {a}.
String -> ([CPartDesignator a], CInitializer a) -> Observed
item String
tag) CInitializerList NodeInfo
items)
    Initializer
_ -> Observed -> m Observed
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Observed
forall a. Monoid a => a
mempty
  where
    item :: String -> ([CPartDesignator a], CInitializer a) -> Observed
item String
tag = \case
        ([CMemberDesig Ident
f a
_], CInitExpr CExpression a
e a
_) -> case CExpression a -> Maybe Integer
forall {a}. CExpression a -> Maybe Integer
literalValue CExpression a
e of
            Just Integer
v  -> [FieldKey -> (Maybe IntTy, [Range]) -> Observation
Stored (String
tag, Ident -> String
identToString Ident
f) (Maybe IntTy
forall a. Maybe a
Nothing, [Integer -> Integer -> Origin -> Range
Range Integer
v Integer
v Origin
Plain])]
            Maybe Integer
Nothing -> [FieldKey -> Observation
Escaped (String
tag, Ident -> String
identToString Ident
f)]
        ([], CInitExpr CExpression a
e a
_) | CExpression a -> Maybe Integer
forall {a}. CExpression a -> Maybe Integer
literalValue CExpression a
e Maybe Integer -> Maybe Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
0 -> Observed
forall a. Monoid a => a
mempty
        ([CPartDesignator a], CInitializer a)
_ -> [String -> Observation
EscapedTag String
tag]
    literalValue :: CExpression a -> Maybe Integer
literalValue = \case
        CConst (CIntConst CInteger
i a
_) -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just (CInteger -> Integer
getCInteger CInteger
i)
        CExpression a
_                      -> Maybe Integer
forall a. Maybe a
Nothing

observeFunction :: MonadTrav m => FilePath -> [IdentDecl] -> FunDef -> m (Observed, Analysed)
observeFunction :: forall (m :: * -> *).
MonadTrav m =>
String -> [IdentDecl] -> FunDef -> m (Observed, Analysed)
observeFunction String
unit [IdentDecl]
locals fd :: FunDef
fd@(FunDef (VarDecl VarName
self DeclAttrs
_ Type
fty) Stmt
body NodeInfo
_) = do
    Maybe String
key <- case VarName
self of
        VarName Ident
i Maybe AsmName
_ -> String -> Ident -> m (Maybe String)
forall (m :: * -> *).
MonadTrav m =>
String -> Ident -> m (Maybe String)
funKey String
unit Ident
i
        VarName
NoName      -> Maybe String -> m (Maybe String)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
    Function
fn <- String -> [IdentDecl] -> FunDef -> m Function
forall (m :: * -> *).
MonadTrav m =>
String -> [IdentDecl] -> FunDef -> m Function
translate String
unit [IdentDecl]
locals FunDef
fd
    let nodes :: [(Node, Facts, [Term])]
nodes = Program -> Function -> [(Node, Facts, [Term])]
solveFunction Program
emptyProgram Function
fn
    let retTy :: Maybe IntTy
retTy = case Type
fty of
            FunctionType (FunType Type
rt [ParamDecl]
_ Bool
_) Attributes
_ -> Type -> Maybe IntTy
intType Type
rt
            Type
_                               -> Maybe IntTy
forall a. Maybe a
Nothing
    [Observed]
perNode <- [(Node, Facts, [Term])]
-> ((Node, Facts, [Term]) -> m Observed) -> m [Observed]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Node, Facts, [Term])]
nodes (((Node, Facts, [Term]) -> m Observed) -> m [Observed])
-> ((Node, Facts, [Term]) -> m Observed) -> m [Observed]
forall a b. (a -> b) -> a -> b
$ \(Node
n, Facts
facts, [Term]
terms) -> do
        Observed
stores <- (Term -> m Observed) -> [Term] -> m Observed
forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
foldMapM (Facts -> Term -> m Observed
forall {m :: * -> *}. MonadTrav m => Facts -> Term -> m Observed
store Facts
facts) ((Term -> [Term]) -> [Term] -> [Term]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Term -> [Term]
subTerms [Term]
terms)
        Observed
calls <- (Term -> m Observed) -> [Term] -> m Observed
forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
foldMapM (Facts -> Term -> m Observed
forall {m :: * -> *}. MonadTrav m => Facts -> Term -> m Observed
call Facts
facts) ((Term -> [Term]) -> [Term] -> [Term]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Term -> [Term]
subTerms [Term]
terms)
        let returned :: Observed
returned = case (Node
n, Maybe IntTy
retTy, Maybe String
key) of
                (Node Int
_ (StatNode CReturn{}), Just IntTy
rt, Just String
k) ->
                    [String -> (Maybe IntTy, [Range]) -> Observation
Returned String
k (IntTy -> Maybe IntTy
forall a. a -> Maybe a
Just IntTy
rt,
                        [Range] -> [Range]
plain [ Range
c | Term
t <- [Term]
terms, Just [Range]
v <- [Facts -> Term -> Maybe [Range]
eval Facts
facts Term
t], Range
r <- [Range]
v, Range
c <- NodeInfo -> IntTy -> Range -> [Range]
convert (CExpr -> NodeInfo
forall a. CExpression a -> a
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation (Term -> CExpr
termExpr Term
t)) IntTy
rt Range
r ])]
                (Node, Maybe IntTy, Maybe String)
_ -> Observed
forall a. Monoid a => a
mempty
        Observed -> m Observed
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Observed
stores Observed -> Observed -> Observed
forall a. Semigroup a => a -> a -> a
<> Observed
calls Observed -> Observed -> Observed
forall a. Semigroup a => a -> a -> a
<> Observed
returned)
    Observed
syntactic <- (CExpr -> m Observed) -> [CExpr] -> m Observed
forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
foldMapM (String -> CExpr -> m Observed
forall (m :: * -> *). MonadTrav m => String -> CExpr -> m Observed
observeExpr String
unit) (Stmt -> [CExpr]
statExprs Stmt
body)
    let reaches :: Observed
reaches = case Maybe String
key of
            Just String
k -> [ Observation -> (Reach -> Observation) -> Maybe Reach -> Observation
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Int -> Observation
Unbounded String
k Int
p) (String -> Reach -> Observation
Reaches String
k) (Int -> Facts -> Access -> Maybe Reach
reach Int
p Facts
facts Access
acc)
                      | (Node
_, Facts
facts, [Term]
terms) <- [(Node, Facts, [Term])]
nodes, Term
t <- (Term -> [Term]) -> [Term] -> [Term]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Term -> [Term]
subTerms [Term]
terms, Access
acc <- Program -> Term -> [Access]
accesses Program
emptyProgram Term
t
                      , Just Int
p <- [String -> Maybe Int
pointerParam (Access -> String
accBuffer Access
acc)] ]
            Maybe String
Nothing -> []
    Observed
inits <- ((Ident, NodeInfo, Initializer) -> m Observed)
-> [(Ident, NodeInfo, Initializer)] -> m Observed
forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
foldMapM (Ident, NodeInfo, Initializer) -> m Observed
forall {m :: * -> *}.
MonadTrav m =>
(Ident, NodeInfo, Initializer) -> m Observed
localInit [ (Ident
i, NodeInfo
ni, Initializer
ini) | CDecl [CDeclarationSpecifier NodeInfo]
_ [(Maybe (CDeclarator NodeInfo), Maybe Initializer, Maybe CExpr)]
ds NodeInfo
_ <- Stmt -> [CDeclaration NodeInfo]
localDecls Stmt
body, (Just (CDeclr (Just Ident
i) [CDerivedDeclarator NodeInfo]
_ Maybe AsmName
_ [CAttribute NodeInfo]
_ NodeInfo
ni), Just ini :: Initializer
ini@CInitList{}, Maybe CExpr
_) <- [(Maybe (CDeclarator NodeInfo), Maybe Initializer, Maybe CExpr)]
ds ]
    (Observed, Analysed) -> m (Observed, Analysed)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Observed] -> Observed
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Observed]
perNode Observed -> Observed -> Observed
forall a. [a] -> [a] -> [a]
++ Observed
syntactic Observed -> Observed -> Observed
forall a. [a] -> [a] -> [a]
++ Observed
inits Observed -> Observed -> Observed
forall a. [a] -> [a] -> [a]
++ Observed
reaches Observed -> Observed -> Observed
forall a. [a] -> [a] -> [a]
++ (String -> Observation) -> [String] -> Observed
forall a b. (a -> b) -> [a] -> [b]
map String -> Observation
Defined (Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList Maybe String
key), (FunDef
fd, Function
fn, [(Node, Facts, [Term])]
nodes))
  where
    -- The parameters that keep the values the caller passes.
    ownParams :: [(String, (Int, Type))]
ownParams = case Type
fty of
        FunctionType (FunType Type
_ [ParamDecl]
ps Bool
_) Attributes
_ ->
            [ (String
name, (Int
n, ParamDecl -> Type
forall n. Declaration n => n -> Type
declType ParamDecl
d))
            | (Int
n, ParamDecl
d) <- [Int] -> [ParamDecl] -> [(Int, ParamDecl)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [ParamDecl]
ps, VarName Ident
i Maybe AsmName
_ <- [ParamDecl -> VarName
forall n. Declaration n => n -> VarName
declName ParamDecl
d]
            , let name :: String
name = Ident -> String
identToString Ident
i, String
name String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Stmt -> Set String
changedNames Stmt
body ]
        Type
_ -> []
    pointerParam :: String -> Maybe Int
pointerParam String
name = case String -> [(String, (Int, Type))] -> Maybe (Int, Type)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
name [(String, (Int, Type))]
ownParams of
        Just (Int
n, Type
ty) | Type -> Bool
isPointer Type
ty -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n
        Maybe (Int, Type)
_                           -> Maybe Int
forall a. Maybe a
Nothing
    isPointer :: Type -> Bool
isPointer Type
ty = case Type -> Type
canonicalType Type
ty of
        PtrType{}   -> Bool
True
        ArrayType{} -> Bool
True
        Type
_           -> Bool
False
    -- How far an access into what a parameter points to reaches. An integer
    -- parameter the function checks the access against comes first, as that
    -- is how it says how much memory it needs. Otherwise it is another
    -- parameter times a coefficient plus a constant, or a constant.
    reach :: Int -> Facts -> Access -> Maybe Reach
reach Int
p Facts
facts Access
acc = case [ Int
n | (String
v, (Int
n, Type
ty)) <- [(String, (Int, Type))]
ownParams, Just IntTy
ity <- [Type -> Maybe IntTy
intType Type
ty], Facts -> Access -> String -> IntTy -> Bool
bounds Facts
facts Access
acc String
v IntTy
ity ] of
        Int
n : [Int]
_ -> Reach -> Maybe Reach
forall a. a -> Maybe a
Just (Int -> Maybe (Int, Integer) -> Integer -> Reach
Reach Int
p ((Int, Integer) -> Maybe (Int, Integer)
forall a. a -> Maybe a
Just (Int
n, Integer
1)) Integer
0)
        [] -> do
            [Linear]
parts <- ((Integer, Term) -> Maybe Linear)
-> [(Integer, Term)] -> Maybe [Linear]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(Integer
k, Term
t) -> Integer -> Linear -> Linear
scale Integer
k (Linear -> Linear) -> Maybe Linear -> Maybe Linear
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Facts -> Term -> Maybe Linear
anySum Facts
facts Term
t) (Access -> [(Integer, Term)]
accTerms Access
acc)
            let Linear Map AccessPath (Integer, Maybe (Integer, Integer))
ps Integer
c = (Linear -> Linear -> Linear) -> Linear -> [Linear] -> Linear
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Linear -> Linear -> Linear
plus (Integer -> Linear
constantSum (Access -> Integer
accConst Access
acc)) [Linear]
parts
            case Map AccessPath (Integer, Maybe (Integer, Integer))
-> [(AccessPath, (Integer, Maybe (Integer, Integer)))]
forall k a. Map k a -> [(k, a)]
Map.toList Map AccessPath (Integer, Maybe (Integer, Integer))
ps of
                []                    -> Reach -> Maybe Reach
forall a. a -> Maybe a
Just (Int -> Maybe (Int, Integer) -> Integer -> Reach
Reach Int
p Maybe (Int, Integer)
forall a. Maybe a
Nothing Integer
c)
                [(PathVar String
v, (Integer
k, Maybe (Integer, Integer)
_))] -> (\(Int
n, Type
_) -> Int -> Maybe (Int, Integer) -> Integer -> Reach
Reach Int
p ((Int, Integer) -> Maybe (Int, Integer)
forall a. a -> Maybe a
Just (Int
n, Integer
k)) Integer
c) ((Int, Type) -> Reach) -> Maybe (Int, Type) -> Maybe Reach
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [(String, (Int, Type))] -> Maybe (Int, Type)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
v [(String, (Int, Type))]
ownParams
                [(AccessPath, (Integer, Maybe (Integer, Integer)))]
_                     -> Maybe Reach
forall a. Maybe a
Nothing
    bounds :: Facts -> Access -> String -> IntTy -> Bool
bounds Facts
facts Access
acc String
v IntTy
ity = Facts -> [(Integer, Term)] -> Integer -> Linear -> Bool
atMost Facts
facts (Access -> [(Integer, Term)]
accTerms Access
acc) (Access -> Integer
accConst Access
acc) (Facts -> AccessPath -> IntTy -> Linear
pathSum Facts
facts (String -> AccessPath
PathVar String
v) IntTy
ity)
    localInit :: (Ident, NodeInfo, Initializer) -> m Observed
localInit (Ident
i, NodeInfo
ni, Initializer
ini) = CExpr -> m (Maybe Type)
forall (m :: * -> *). MonadTrav m => CExpr -> m (Maybe Type)
exprType (Ident -> NodeInfo -> CExpr
forall a. Ident -> a -> CExpression a
CVar Ident
i NodeInfo
ni) m (Maybe Type) -> (Maybe Type -> m Observed) -> m Observed
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m Observed -> (Type -> m Observed) -> Maybe Type -> m Observed
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Observed -> m Observed
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Observed
forall a. Monoid a => a
mempty) (Type -> Initializer -> m Observed
forall (m :: * -> *).
MonadTrav m =>
Type -> Initializer -> m Observed
`initializer` Initializer
ini)

    store :: Facts -> Term -> m Observed
store Facts
facts Term
t = case Term -> TermKind
termKind Term
t of
        TAssign Maybe AccessPath
_ CAssignOp
_ Term
l Term
_ | CMember{} <- Term -> CExpr
termExpr Term
l -> CExpr -> Maybe IntTy -> Maybe [Range] -> m Observed
forall {m :: * -> *}.
MonadTrav m =>
CExpr -> Maybe IntTy -> Maybe [Range] -> m Observed
stored (Term -> CExpr
termExpr Term
l) (Term -> Maybe IntTy
termTy Term
l) (Facts -> Term -> Maybe [Range]
eval Facts
facts Term
t)
        TUnary CUnaryOp
op Term
a | CUnaryOp
op CUnaryOp -> [CUnaryOp] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CUnaryOp
CPreIncOp, CUnaryOp
CPreDecOp, CUnaryOp
CPostIncOp, CUnaryOp
CPostDecOp], CMember{} <- Term -> CExpr
termExpr Term
a ->
            let d :: Integer
d = if CUnaryOp
op CUnaryOp -> [CUnaryOp] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CUnaryOp
CPreIncOp, CUnaryOp
CPostIncOp] then Integer
1 else -Integer
1
                after :: Maybe [Range]
after = do
                    IntTy
ty <- Term -> Maybe IntTy
termTy Term
a
                    [Range]
v <- Facts -> Term -> Maybe [Range]
eval Facts
facts Term
a
                    [Range] -> Maybe [Range]
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Range
c | Range
r <- [Range]
v, Range
c <- NodeInfo -> IntTy -> Range -> [Range]
convert (CExpr -> NodeInfo
forall a. CExpression a -> a
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation (Term -> CExpr
termExpr Term
t)) IntTy
ty (Integer -> Integer -> Origin -> Range
Range (Range -> Integer
lo Range
r Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
d) (Range -> Integer
hi Range
r Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
d) Origin
Arith) ]
            in CExpr -> Maybe IntTy -> Maybe [Range] -> m Observed
forall {m :: * -> *}.
MonadTrav m =>
CExpr -> Maybe IntTy -> Maybe [Range] -> m Observed
stored (Term -> CExpr
termExpr Term
a) (Term -> Maybe IntTy
termTy Term
a) Maybe [Range]
after
        TermKind
_ -> Observed -> m Observed
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Observed
forall a. Monoid a => a
mempty
    stored :: CExpr -> Maybe IntTy -> Maybe [Range] -> m Observed
stored CExpr
lhs Maybe IntTy
ty Maybe [Range]
value = CExpr -> m (Maybe FieldKey)
forall (m :: * -> *). MonadTrav m => CExpr -> m (Maybe FieldKey)
fieldKey CExpr
lhs m (Maybe FieldKey) -> (Maybe FieldKey -> m Observed) -> m Observed
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe FieldKey
k -> Observed -> m Observed
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Observed -> m Observed) -> Observed -> m Observed
forall a b. (a -> b) -> a -> b
$ case (Maybe FieldKey
k, Maybe [Range]
value) of
        (Just FieldKey
key, Just [Range]
v)  -> [FieldKey -> (Maybe IntTy, [Range]) -> Observation
Stored FieldKey
key (Maybe IntTy
ty, [Range] -> [Range]
plain [Range]
v)]
        (Just FieldKey
key, Maybe [Range]
Nothing) -> [FieldKey -> Observation
Escaped FieldKey
key]
        (Maybe FieldKey, Maybe [Range])
_                   -> Observed
forall a. Monoid a => a
mempty
    call :: Facts -> Term -> m Observed
call Facts
facts Term
t = case Term -> TermKind
termKind Term
t of
        TCall (Term (CVar Ident
f NodeInfo
_) Maybe IntTy
_ Maybe Fact
_ Maybe [Range]
_ TermKind
_) [Term]
args -> String -> Ident -> m (Maybe String)
forall (m :: * -> *).
MonadTrav m =>
String -> Ident -> m (Maybe String)
funKey String
unit Ident
f m (Maybe String) -> (Maybe String -> m Observed) -> m Observed
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just String
k | (String
unit String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":") String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
k -> do
                Maybe [Type]
params <- Ident -> m (Maybe [Type])
forall {m :: * -> *}. MonadTrav m => Ident -> m (Maybe [Type])
calleeParams Ident
f
                Observed -> m Observed
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Observed -> m Observed) -> Observed -> m Observed
forall a b. (a -> b) -> a -> b
$ case Maybe [Type]
params of
                    Just [Type]
ps | [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ps Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Term] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Term]
args ->
                        [String -> [Maybe (Maybe IntTy, [Range])] -> Observation
Passed String
k ((Type -> Term -> Maybe (Maybe IntTy, [Range]))
-> [Type] -> [Term] -> [Maybe (Maybe IntTy, [Range])]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Facts -> Type -> Term -> Maybe (Maybe IntTy, [Range])
argValue Facts
facts) [Type]
ps [Term]
args)]
                    Maybe [Type]
_ -> Observed
forall a. Monoid a => a
mempty
            Maybe String
_ -> Observed -> m Observed
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Observed
forall a. Monoid a => a
mempty
        TermKind
_ -> Observed -> m Observed
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Observed
forall a. Monoid a => a
mempty
    argValue :: Facts -> Type -> Term -> Maybe (Maybe IntTy, [Range])
argValue Facts
facts Type
p Term
a = do
        IntTy
ty <- Type -> Maybe IntTy
intType Type
p
        [Range]
v <- Facts -> Term -> Maybe [Range]
eval Facts
facts Term
a
        (Maybe IntTy, [Range]) -> Maybe (Maybe IntTy, [Range])
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (IntTy -> Maybe IntTy
forall a. a -> Maybe a
Just IntTy
ty, [Range] -> [Range]
plain [ Range
c | Range
r <- [Range]
v, Range
c <- NodeInfo -> IntTy -> Range -> [Range]
convert (CExpr -> NodeInfo
forall a. CExpression a -> a
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation (Term -> CExpr
termExpr Term
a)) IntTy
ty Range
r ])
    calleeParams :: Ident -> m (Maybe [Type])
calleeParams Ident
f = CExpr -> m (Maybe Type)
forall (m :: * -> *). MonadTrav m => CExpr -> m (Maybe Type)
exprType (Ident -> NodeInfo -> CExpr
forall a. Ident -> a -> CExpression a
CVar Ident
f NodeInfo
undefNode) m (Maybe Type)
-> (Maybe Type -> m (Maybe [Type])) -> m (Maybe [Type])
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Type
ty | Just (FunType Type
_ [ParamDecl]
ps Bool
False) <- Type -> Maybe FunType
funType Type
ty -> Maybe [Type] -> m (Maybe [Type])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type] -> Maybe [Type]
forall a. a -> Maybe a
Just ((ParamDecl -> Type) -> [ParamDecl] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map ParamDecl -> Type
forall n. Declaration n => n -> Type
declType [ParamDecl]
ps))
        Maybe Type
_ -> Maybe [Type] -> m (Maybe [Type])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Type]
forall a. Maybe a
Nothing

-- | What an expression shows, whatever the facts: fields whose address it
-- takes, structs it casts or hands to functions, functions it uses other than
-- by calling them, and what compound literals store.
observeExpr :: MonadTrav m => FilePath -> CExpr -> m Observed
observeExpr :: forall (m :: * -> *). MonadTrav m => String -> CExpr -> m Observed
observeExpr String
unit = CExpr -> m Observed
go
  where
    go :: CExpr -> m Observed
go CExpr
e = Observed -> Observed -> Observed
forall a. Semigroup a => a -> a -> a
(<>) (Observed -> Observed -> Observed)
-> m Observed -> m (Observed -> Observed)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CExpr -> m Observed
here CExpr
e m (Observed -> Observed) -> m Observed -> m Observed
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (CExpr -> m Observed) -> [CExpr] -> m Observed
forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
foldMapM CExpr -> m Observed
go (CExpr -> [CExpr]
children CExpr
e)

    -- A function a call names isn't used other than by calling it.
    children :: CExpr -> [CExpr]
children = \case
        CCall CVar{} [CExpr]
args NodeInfo
_ -> [CExpr]
args
        CExpr
e                   -> CExpr -> [CExpr]
exprChildren CExpr
e

    here :: CExpr -> m Observed
here = \case
        CUnary CUnaryOp
CAdrOp CExpr
e NodeInfo
_ -> CExpr -> m Observed
forall {f :: * -> *}. MonadTrav f => CExpr -> f Observed
addressed CExpr
e
        CVar Ident
i NodeInfo
_ -> (String -> Observation) -> [String] -> Observed
forall a b. (a -> b) -> [a] -> [b]
map String -> Observation
Addressed ([String] -> Observed)
-> (Maybe String -> [String]) -> Maybe String -> Observed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList (Maybe String -> Observed) -> m (Maybe String) -> m Observed
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Ident -> m (Maybe String)
forall (m :: * -> *).
MonadTrav m =>
String -> Ident -> m (Maybe String)
funKey String
unit Ident
i
        CCast CDeclaration NodeInfo
d CExpr
inner NodeInfo
_ -> CDeclaration NodeInfo -> m (Maybe Type)
forall {m :: * -> *}.
MonadTrav m =>
CDeclaration NodeInfo -> m (Maybe Type)
declaredType CDeclaration NodeInfo
d m (Maybe Type) -> (Maybe Type -> m Observed) -> m Observed
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            -- Only pointer casts can let the program change fields unseen.
            to :: Maybe Type
to@(Just Type
t) | Maybe Type -> Bool
forall a. Maybe a -> Bool
isJust (Type -> Maybe Type
pointee Type
t) -> do
                Maybe Type
from <- CExpr -> m (Maybe Type)
forall (m :: * -> *). MonadTrav m => CExpr -> m (Maybe Type)
exprType CExpr
inner
                Observed -> m Observed
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Observed -> m Observed) -> Observed -> m Observed
forall a b. (a -> b) -> a -> b
$ (String -> Observation) -> [String] -> Observed
forall a b. (a -> b) -> [a] -> [b]
map String -> Observation
EscapedTag ([Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Type -> Maybe Type -> Maybe String
castTag Maybe Type
from Maybe Type
to, Maybe Type -> Maybe Type -> Maybe String
castTag Maybe Type
to Maybe Type
from])
            Maybe Type
_ -> Observed -> m Observed
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Observed
forall a. Monoid a => a
mempty
        CCall CExpr
f [CExpr]
args NodeInfo
_ -> do
            Maybe String
callee <- case CExpr
f of
                CVar Ident
i NodeInfo
_ -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> m String -> m (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (Ident -> String
identToString Ident
i) (Maybe String -> String) -> m (Maybe String) -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Ident -> m (Maybe String)
forall (m :: * -> *).
MonadTrav m =>
String -> Ident -> m (Maybe String)
funKey String
unit Ident
i)
                CExpr
_        -> Maybe String -> m (Maybe String)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
            Maybe Type
calleeTy <- case CExpr
f of
                CVar Ident
i NodeInfo
_ -> (IdentDecl -> Type) -> Maybe IdentDecl -> Maybe Type
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IdentDecl -> Type
forall n. Declaration n => n -> Type
declType (Maybe IdentDecl -> Maybe Type)
-> m (Maybe IdentDecl) -> m (Maybe Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ident -> m (Maybe IdentDecl)
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Ident -> m (Maybe IdentDecl)
lookupObject Ident
i m (Maybe IdentDecl)
-> (CError -> m (Maybe IdentDecl)) -> m (Maybe IdentDecl)
forall a. m a -> (CError -> m a) -> m a
forall (m :: * -> *) a.
MonadCError m =>
m a -> (CError -> m a) -> m a
`catchTravError` m (Maybe IdentDecl) -> CError -> m (Maybe IdentDecl)
forall a b. a -> b -> a
const (Maybe IdentDecl -> m (Maybe IdentDecl)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe IdentDecl
forall a. Maybe a
Nothing))
                CExpr
_        -> CExpr -> m (Maybe Type)
forall (m :: * -> *). MonadTrav m => CExpr -> m (Maybe Type)
exprType CExpr
f
            let calleeName :: String
calleeName = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
callee
                sig :: Maybe FunType
sig = Maybe Type
calleeTy Maybe Type -> (Type -> Maybe FunType) -> Maybe FunType
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> Maybe FunType
funType
            [String]
written <- case Maybe FunType
sig of
                Just (FunType Type
_ [ParamDecl]
params Bool
variadic) -> do
                    let paramTys :: [Maybe Type]
paramTys = (ParamDecl -> Maybe Type) -> [ParamDecl] -> [Maybe Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type)
-> (ParamDecl -> Type) -> ParamDecl -> Maybe Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParamDecl -> Type
forall n. Declaration n => n -> Type
declType) [ParamDecl]
params [Maybe Type] -> [Maybe Type] -> [Maybe Type]
forall a. [a] -> [a] -> [a]
++ Maybe Type -> [Maybe Type]
forall a. a -> [a]
repeat Maybe Type
forall a. Maybe a
Nothing
                    ([Maybe String] -> [String]) -> m [Maybe String] -> m [String]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes (m [Maybe String] -> m [String])
-> (((CExpr, Maybe Type) -> m (Maybe String)) -> m [Maybe String])
-> ((CExpr, Maybe Type) -> m (Maybe String))
-> m [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(CExpr, Maybe Type)]
-> ((CExpr, Maybe Type) -> m (Maybe String)) -> m [Maybe String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([CExpr] -> [Maybe Type] -> [(CExpr, Maybe Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CExpr]
args [Maybe Type]
paramTys) (((CExpr, Maybe Type) -> m (Maybe String)) -> m [String])
-> ((CExpr, Maybe Type) -> m (Maybe String)) -> m [String]
forall a b. (a -> b) -> a -> b
$ \(CExpr
arg, Maybe Type
pty) -> case Maybe Type
pty of
                        -- A parameter's own type says what the callee can write,
                        -- unless it is a pointer to bytes or to anything.
                        Just Type
t | Just Type
p <- Type -> Maybe Type
pointee Type
t, Type -> Bool
isConst Type
p -> Maybe String -> m (Maybe String)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
                        Just Type
t | Just Type
p <- Type -> Maybe Type
pointee Type
t, Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Type -> Maybe String
structTag Type
p) ->
                            Maybe String -> m (Maybe String)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Maybe String
writableTag Type
t)
                        Just Type
t | Maybe Type
Nothing <- Type -> Maybe Type
pointee Type
t -> Maybe String -> m (Maybe String)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
                        Maybe Type
_ | Maybe Type -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Type
pty Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
variadic -> Maybe String -> m (Maybe String)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
                        Maybe Type
_ -> (Maybe Type -> (Type -> Maybe String) -> Maybe String
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> Maybe String
writableTag) (Maybe Type -> Maybe String) -> m (Maybe Type) -> m (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CExpr -> m (Maybe Type)
forall (m :: * -> *). MonadTrav m => CExpr -> m (Maybe Type)
exprType CExpr
arg
                Maybe FunType
_ -> [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe String] -> [String])
-> ([Maybe Type] -> [Maybe String]) -> [Maybe Type] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Type -> Maybe String) -> [Maybe Type] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Type -> (Type -> Maybe String) -> Maybe String
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> Maybe String
writableTag) ([Maybe Type] -> [String]) -> m [Maybe Type] -> m [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CExpr -> m (Maybe Type)) -> [CExpr] -> m [Maybe Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM CExpr -> m (Maybe Type)
forall (m :: * -> *). MonadTrav m => CExpr -> m (Maybe Type)
exprType [CExpr]
args
            let returned :: [String]
returned = case Maybe FunType
sig of
                    Just (FunType Type
rt [ParamDecl]
_ Bool
_) -> [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [Type -> Maybe String
returnedTag Type
rt]
                    Maybe FunType
_                     -> []
                tags :: [String]
tags = if String
calleeName String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
harmless then [] else [String]
written [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
returned
            Observed -> m Observed
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> [String] -> Observation
HandedTo String
calleeName [String]
tags]
        CCompoundLit CDeclaration NodeInfo
d CInitializerList NodeInfo
i NodeInfo
ni -> CDeclaration NodeInfo -> m (Maybe Type)
forall {m :: * -> *}.
MonadTrav m =>
CDeclaration NodeInfo -> m (Maybe Type)
declaredType CDeclaration NodeInfo
d m (Maybe Type) -> (Maybe Type -> m Observed) -> m Observed
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m Observed -> (Type -> m Observed) -> Maybe Type -> m Observed
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Observed -> m Observed
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Observed
forall a. Monoid a => a
mempty) (Type -> Initializer -> m Observed
forall (m :: * -> *).
MonadTrav m =>
Type -> Initializer -> m Observed
`initializer` CInitializerList NodeInfo -> NodeInfo -> Initializer
forall a. CInitializerList a -> a -> CInitializer a
CInitList CInitializerList NodeInfo
i NodeInfo
ni)
        CExpr
_ -> Observed -> m Observed
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Observed
forall a. Monoid a => a
mempty

    declaredType :: CDeclaration NodeInfo -> m (Maybe Type)
declaredType CDeclaration NodeInfo
d = (Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> m Type -> m (Maybe Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CDeclaration NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
CDeclaration NodeInfo -> m Type
analyseTypeDecl CDeclaration NodeInfo
d) m (Maybe Type) -> (CError -> m (Maybe Type)) -> m (Maybe Type)
forall a. m a -> (CError -> m a) -> m a
forall (m :: * -> *) a.
MonadCError m =>
m a -> (CError -> m a) -> m a
`catchTravError` m (Maybe Type) -> CError -> m (Maybe Type)
forall a b. a -> b -> a
const (Maybe Type -> m (Maybe Type)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Type
forall a. Maybe a
Nothing)

    addressed :: CExpr -> f Observed
addressed CExpr
e = case CExpr -> CExpr
forall {a}. CExpression a -> CExpression a
stripIndex CExpr
e of
        m :: CExpr
m@CMember{} -> (FieldKey -> Observation) -> [FieldKey] -> Observed
forall a b. (a -> b) -> [a] -> [b]
map FieldKey -> Observation
Escaped ([FieldKey] -> Observed)
-> (Maybe FieldKey -> [FieldKey]) -> Maybe FieldKey -> Observed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe FieldKey -> [FieldKey]
forall a. Maybe a -> [a]
maybeToList (Maybe FieldKey -> Observed) -> f (Maybe FieldKey) -> f Observed
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CExpr -> f (Maybe FieldKey)
forall (m :: * -> *). MonadTrav m => CExpr -> m (Maybe FieldKey)
fieldKey CExpr
m
        CExpr
_           -> Observed -> f Observed
forall a. a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return Observed
forall a. Monoid a => a
mempty

    stripIndex :: CExpression a -> CExpression a
stripIndex = \case
        CIndex CExpression a
b CExpression a
_ a
_ -> CExpression a -> CExpression a
stripIndex CExpression a
b
        CExpression a
e            -> CExpression a
e

    -- A pointer to a struct cast to a pointer to anything but void or the
    -- same struct lets the program change the struct's fields unseen.
    castTag :: Maybe Type -> Maybe Type -> Maybe String
castTag Maybe Type
from Maybe Type
to = do
        Type
f <- Maybe Type
from Maybe Type -> (Type -> Maybe Type) -> Maybe Type
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> Maybe Type
pointee
        Type
t <- Maybe Type
to Maybe Type -> (Type -> Maybe Type) -> Maybe Type
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> Maybe Type
pointee
        String
tag <- Type -> Maybe String
structTag Type
f
        if Type -> Bool
isVoid Type
t Bool -> Bool -> Bool
|| Type -> Maybe String
structTag Type
t Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just String
tag then Maybe String
forall a. Maybe a
Nothing else String -> Maybe String
forall a. a -> Maybe a
Just String
tag

    writableTag :: Type -> Maybe String
writableTag Type
ty = do
        Type
p <- Type -> Maybe Type
pointee Type
ty
        if Type -> Bool
isConst Type
p then Maybe String
forall a. Maybe a
Nothing else Type -> Maybe String
structTag Type
p

    returnedTag :: Type -> Maybe String
returnedTag Type
ty = Type -> Maybe String
structTag Type
ty Maybe String -> Maybe String -> Maybe String
forall {a}. Maybe a -> Maybe a -> Maybe a
`orElse` (Type -> Maybe Type
pointee Type
ty Maybe Type -> (Type -> Maybe String) -> Maybe String
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> Maybe String
structTag)

    orElse :: Maybe a -> Maybe a -> Maybe a
orElse (Just a
x) Maybe a
_ = a -> Maybe a
forall a. a -> Maybe a
Just a
x
    orElse Maybe a
Nothing Maybe a
y  = Maybe a
y

    pointee :: Type -> Maybe Type
pointee Type
ty = case Type -> Type
canonicalType Type
ty of
        PtrType Type
p TypeQuals
_ Attributes
_ -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
p
        Type
_             -> Maybe Type
forall a. Maybe a
Nothing

    isConst :: Type -> Bool
isConst = TypeQuals -> Bool
constant (TypeQuals -> Bool) -> (Type -> TypeQuals) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> TypeQuals
typeQuals

    isVoid :: Type -> Bool
isVoid Type
t = case Type -> Type
canonicalType Type
t of
        DirectType TypeName
TyVoid TypeQuals
_ Attributes
_ -> Bool
True
        Type
_                     -> Bool
False