{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
-- | Finds lists and arrays that peers can grow without limit by sending
-- packets.
module Tokstyle.Linter.UnboundedGrowth (descr) where

import qualified Control.Monad.State.Strict                as State
import           Data.Fix                                  (Fix (..))
import qualified Data.List                                 as List
import           Data.Map.Strict                           (Map)
import qualified Data.Map.Strict                           as Map
import           Data.Maybe                                (isJust, mapMaybe)
import           Data.Set                                  (Set)
import qualified Data.Set                                  as Set
import           Data.Text                                 (Text)
import qualified Data.Text                                 as Text
import           Language.Cimple                           (AssignOp (..),
                                                            BinaryOp (..),
                                                            Lexeme (..),
                                                            NodeF (..),
                                                            UnaryOp (..))
import qualified Language.Cimple                           as C
import           Language.Cimple.Diagnostics               (CimplePos,
                                                            Diagnostic (..),
                                                            DiagnosticLevel (..),
                                                            DiagnosticSpan (..),
                                                            HasDiagnosticInfo (..),
                                                            warnRich)
import           Prettyprinter                             (pretty, (<+>))
import           Tokstyle.Analysis.AccessPath              (AccessPath (..))
import           Tokstyle.Cimple.Analysis.CFG              (CFG, Node (..),
                                                            NodeKind (..),
                                                            fromFunction,
                                                            getFuncName)
import           Tokstyle.Cimple.Analysis.FunctionPointers (FieldKey,
                                                            FieldTargets,
                                                            Targets (..),
                                                            callTargets,
                                                            fieldTargets)
import           Tokstyle.Cimple.Analysis.Functions        (Function (..),
                                                            accessPath,
                                                            allocators,
                                                            assignments, bare,
                                                            bottomUp, callees,
                                                            definitions, intLit,
                                                            isNullLit,
                                                            localDecls,
                                                            nodeExprs, nullTest,
                                                            render, rootOf,
                                                            universe)
import           Tokstyle.Cimple.Analysis.Types            (Structs, structName,
                                                            structs, typeIn)
import           Tokstyle.Common                           (backticks)


-- | How a call makes something grow.
data By
    = Grows
    | ResizedBy Int
    -- ^ Resized to the size the caller passes in this parameter.
    deriving (By -> By -> Bool
(By -> By -> Bool) -> (By -> By -> Bool) -> Eq By
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: By -> By -> Bool
== :: By -> By -> Bool
$c/= :: By -> By -> Bool
/= :: By -> By -> Bool
Eq, Eq By
Eq By =>
(By -> By -> Ordering)
-> (By -> By -> Bool)
-> (By -> By -> Bool)
-> (By -> By -> Bool)
-> (By -> By -> Bool)
-> (By -> By -> By)
-> (By -> By -> By)
-> Ord By
By -> By -> Bool
By -> By -> Ordering
By -> By -> By
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: By -> By -> Ordering
compare :: By -> By -> Ordering
$c< :: By -> By -> Bool
< :: By -> By -> Bool
$c<= :: By -> By -> Bool
<= :: By -> By -> Bool
$c> :: By -> By -> Bool
> :: By -> By -> Bool
$c>= :: By -> By -> Bool
>= :: By -> By -> Bool
$cmax :: By -> By -> By
max :: By -> By -> By
$cmin :: By -> By -> By
min :: By -> By -> By
Ord, Int -> By -> ShowS
[By] -> ShowS
By -> String
(Int -> By -> ShowS)
-> (By -> String) -> ([By] -> ShowS) -> Show By
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> By -> ShowS
showsPrec :: Int -> By -> ShowS
$cshow :: By -> String
show :: By -> String
$cshowList :: [By] -> ShowS
showList :: [By] -> ShowS
Show)

-- | Something growing, and the object holding it. Paths use the names in the
-- function being analysed.
data Growth = Growth
    { Growth -> String
growFile  :: FilePath
    , Growth -> Text
growIn    :: Text
    , Growth -> Lexeme Text
growAt    :: Lexeme Text
    , Growth -> AccessPath
growWhat  :: AccessPath
    , Growth -> Maybe (Text, Text)
growField :: Maybe FieldKey
    , Growth -> AccessPath
growOwner :: AccessPath
    , Growth -> By
growBy    :: By
    , Growth -> [Text]
growVia   :: [Text]
    -- ^ The calls from the function analysed down to where it grows.
    }

instance Eq Growth where
    Growth
a == :: Growth -> Growth -> Bool
== Growth
b = Growth -> (String, Int, Int, AccessPath, By)
key Growth
a (String, Int, Int, AccessPath, By)
-> (String, Int, Int, AccessPath, By) -> Bool
forall a. Eq a => a -> a -> Bool
== Growth -> (String, Int, Int, AccessPath, By)
key Growth
b

instance Ord Growth where
    compare :: Growth -> Growth -> Ordering
compare Growth
a Growth
b = (String, Int, Int, AccessPath, By)
-> (String, Int, Int, AccessPath, By) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Growth -> (String, Int, Int, AccessPath, By)
key Growth
a) (Growth -> (String, Int, Int, AccessPath, By)
key Growth
b)

key :: Growth -> (FilePath, Int, Int, AccessPath, By)
key :: Growth -> (String, Int, Int, AccessPath, By)
key Growth
g = let L (C.AlexPn Int
_ Int
l Int
c) LexemeClass
_ Text
_ = Growth -> Lexeme Text
growAt Growth
g in (Growth -> String
growFile Growth
g, Int
l, Int
c, Growth -> AccessPath
growOwner Growth
g, Growth -> By
growBy Growth
g)

data Context = Context
    { Context -> Structs
ctxTypes     :: Structs
    , Context -> Map Text Function
ctxFns       :: Map Text Function
    , Context -> Map Text (Text, Text)
ctxFinders   :: Map Text FieldKey
    -- ^ Functions returning a pointer into an array field.
    , Context -> Set Text
ctxShrinkers :: Set Text
    -- ^ Functions that may make a list or array smaller.
    , Context -> Set (Text, Text)
ctxGrowing   :: Set FieldKey
    -- ^ Fields packets may make grow with nothing limiting them.
    }

-- | The growth each function leaves to its callers to limit.
type Summary = Map Text (Set Growth)

reallocators :: Map Text (Int, Int)
reallocators :: Map Text (Int, Int)
reallocators = [(Text, (Int, Int))] -> Map Text (Int, Int)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [(Text
"realloc", (Int
0, Int
1)), (Text
"mem_vrealloc", (Int
1, Int
2)), (Text
"mem_brealloc", (Int
1, Int
2))]

-- | List nodes, i.e. structs with a field pointing to their own type.
isNode :: Structs -> Text -> Bool
isNode :: Structs -> Text -> Bool
isNode Structs
types Text
s = (Node (Lexeme Text) -> Bool) -> [Node (Lexeme Text)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
s) (Maybe Text -> Bool)
-> (Node (Lexeme Text) -> Maybe Text) -> Node (Lexeme Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node (Lexeme Text) -> Maybe Text
structName) (Map Text (Node (Lexeme Text)) -> [Node (Lexeme Text)]
forall k a. Map k a -> [a]
Map.elems (Map Text (Node (Lexeme Text))
-> Text -> Structs -> Map Text (Node (Lexeme Text))
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map Text (Node (Lexeme Text))
forall k a. Map k a
Map.empty Text
s Structs
types))

nth :: Int -> [a] -> Maybe a
nth :: forall a. Int -> [a] -> Maybe a
nth Int
i [a]
xs = case Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
i [a]
xs of
    a
x : [a]
_ -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
    []    -> Maybe a
forall a. Maybe a
Nothing

fieldOf :: C.Node (Lexeme Text) -> Maybe (C.Node (Lexeme Text), Lexeme Text)
fieldOf :: Node (Lexeme Text) -> Maybe (Node (Lexeme Text), Lexeme Text)
fieldOf Node (Lexeme Text)
e = case Node (Lexeme Text) -> Node (Lexeme Text)
bare Node (Lexeme Text)
e of
    Fix (PointerAccess Node (Lexeme Text)
x Lexeme Text
f) -> (Node (Lexeme Text), Lexeme Text)
-> Maybe (Node (Lexeme Text), Lexeme Text)
forall a. a -> Maybe a
Just (Node (Lexeme Text)
x, Lexeme Text
f)
    Fix (MemberAccess Node (Lexeme Text)
x Lexeme Text
f)  -> (Node (Lexeme Text), Lexeme Text)
-> Maybe (Node (Lexeme Text), Lexeme Text)
forall a. a -> Maybe a
Just (Node (Lexeme Text)
x, Lexeme Text
f)
    Node (Lexeme Text)
_                       -> Maybe (Node (Lexeme Text), Lexeme Text)
forall a. Maybe a
Nothing

fieldKey :: Structs -> Function -> C.Node (Lexeme Text) -> Maybe FieldKey
fieldKey :: Structs -> Function -> Node (Lexeme Text) -> Maybe (Text, Text)
fieldKey Structs
types Function
fn Node (Lexeme Text)
e = do
    (Node (Lexeme Text)
x, L AlexPosn
_ LexemeClass
_ Text
f) <- Node (Lexeme Text) -> Maybe (Node (Lexeme Text), Lexeme Text)
fieldOf Node (Lexeme Text)
e
    Text
s <- Structs
-> Function -> Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
typeIn Structs
types Function
fn Node (Lexeme Text)
x Maybe (Node (Lexeme Text))
-> (Node (Lexeme Text) -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Node (Lexeme Text) -> Maybe Text
structName
    (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
s, Text
f)

-- | The values given to each local variable.
definedAs :: Function -> Map String [C.Node (Lexeme Text)]
definedAs :: Function -> Map String [Node (Lexeme Text)]
definedAs Function
fn = ([Node (Lexeme Text)]
 -> [Node (Lexeme Text)] -> [Node (Lexeme Text)])
-> Map String [Node (Lexeme Text)]
-> Map String [Node (Lexeme Text)]
-> Map String [Node (Lexeme Text)]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith [Node (Lexeme Text)]
-> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall a. [a] -> [a] -> [a]
(++)
    (([Node (Lexeme Text)]
 -> [Node (Lexeme Text)] -> [Node (Lexeme Text)])
-> [(String, [Node (Lexeme Text)])]
-> Map String [Node (Lexeme Text)]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [Node (Lexeme Text)]
-> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall a. [a] -> [a] -> [a]
(++) [ (String
v, [Node (Lexeme Text)
i]) | (String
v, Just Node (Lexeme Text)
i) <- Node (Lexeme Text) -> [(String, Maybe (Node (Lexeme Text)))]
localDecls (Function -> Node (Lexeme Text)
fnDefn Function
fn) ])
    (Node (Lexeme Text) -> Map String [Node (Lexeme Text)]
assignments (Function -> Node (Lexeme Text)
fnDefn Function
fn))

-- | The calls an expression makes, directly or through the local it reads.
callsIn :: Map String [C.Node (Lexeme Text)] -> C.Node (Lexeme Text) -> [(C.Node (Lexeme Text), Text, [C.Node (Lexeme Text)])]
callsIn :: Map String [Node (Lexeme Text)]
-> Node (Lexeme Text)
-> [(Node (Lexeme Text), Text, [Node (Lexeme Text)])]
callsIn Map String [Node (Lexeme Text)]
defs Node (Lexeme Text)
e = case Node (Lexeme Text) -> Node (Lexeme Text)
bare Node (Lexeme Text)
e of
    Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
v)) -> (Node (Lexeme Text)
 -> Maybe (Node (Lexeme Text), Text, [Node (Lexeme Text)]))
-> [Node (Lexeme Text)]
-> [(Node (Lexeme Text), Text, [Node (Lexeme Text)])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Node (Lexeme Text)
-> Maybe (Node (Lexeme Text), Text, [Node (Lexeme Text)])
call (Node (Lexeme Text)
 -> Maybe (Node (Lexeme Text), Text, [Node (Lexeme Text)]))
-> (Node (Lexeme Text) -> Node (Lexeme Text))
-> Node (Lexeme Text)
-> Maybe (Node (Lexeme Text), Text, [Node (Lexeme Text)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node (Lexeme Text) -> Node (Lexeme Text)
bare) ([Node (Lexeme Text)]
-> String
-> Map String [Node (Lexeme Text)]
-> [Node (Lexeme Text)]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] (Text -> String
Text.unpack Text
v) Map String [Node (Lexeme Text)]
defs)
    Node (Lexeme Text)
e'                      -> (Node (Lexeme Text)
 -> Maybe (Node (Lexeme Text), Text, [Node (Lexeme Text)]))
-> [Node (Lexeme Text)]
-> [(Node (Lexeme Text), Text, [Node (Lexeme Text)])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Node (Lexeme Text)
-> Maybe (Node (Lexeme Text), Text, [Node (Lexeme Text)])
call [Node (Lexeme Text)
e']
  where
    call :: Node (Lexeme Text)
-> Maybe (Node (Lexeme Text), Text, [Node (Lexeme Text)])
call = \case
        Fix (FunctionCall Node (Lexeme Text)
callee [Node (Lexeme Text)]
args) | Just Text
name <- Node (Lexeme Text) -> Maybe Text
getFuncName Node (Lexeme Text)
callee -> (Node (Lexeme Text), Text, [Node (Lexeme Text)])
-> Maybe (Node (Lexeme Text), Text, [Node (Lexeme Text)])
forall a. a -> Maybe a
Just (Node (Lexeme Text)
callee, Text
name, [Node (Lexeme Text)]
args)
        Node (Lexeme Text)
_ -> Maybe (Node (Lexeme Text), Text, [Node (Lexeme Text)])
forall a. Maybe a
Nothing

-- | Replace a function's parameters in a path by what a call passes.
substitute :: Map String (C.Node (Lexeme Text)) -> AccessPath -> Maybe AccessPath
substitute :: Map String (Node (Lexeme Text)) -> AccessPath -> Maybe AccessPath
substitute Map String (Node (Lexeme Text))
args = AccessPath -> Maybe AccessPath
go
  where
    go :: AccessPath -> Maybe AccessPath
go = \case
        PathDeref (PathVar String
p) | Just Node (Lexeme Text)
a <- String
-> Map String (Node (Lexeme Text)) -> Maybe (Node (Lexeme Text))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
p Map String (Node (Lexeme Text))
args -> Node (Lexeme Text) -> Maybe AccessPath
pointee Node (Lexeme Text)
a
        PathVar String
p | Just Node (Lexeme Text)
a <- String
-> Map String (Node (Lexeme Text)) -> Maybe (Node (Lexeme Text))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
p Map String (Node (Lexeme Text))
args -> Node (Lexeme Text) -> Maybe AccessPath
accessPath (Node (Lexeme Text) -> Node (Lexeme Text)
bare Node (Lexeme Text)
a)
        PathDeref AccessPath
p   -> AccessPath -> AccessPath
PathDeref (AccessPath -> AccessPath) -> Maybe AccessPath -> Maybe AccessPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AccessPath -> Maybe AccessPath
go AccessPath
p
        PathField AccessPath
p String
m -> (AccessPath -> String -> AccessPath
`PathField` String
m) (AccessPath -> AccessPath) -> Maybe AccessPath -> Maybe AccessPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AccessPath -> Maybe AccessPath
go AccessPath
p
        PathIndex AccessPath
p String
i -> (AccessPath -> String -> AccessPath
`PathIndex` String
i) (AccessPath -> AccessPath) -> Maybe AccessPath -> Maybe AccessPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AccessPath -> Maybe AccessPath
go AccessPath
p
        AccessPath
p             -> AccessPath -> Maybe AccessPath
forall a. a -> Maybe a
Just AccessPath
p
    pointee :: Node (Lexeme Text) -> Maybe AccessPath
pointee Node (Lexeme Text)
a = case Node (Lexeme Text) -> Node (Lexeme Text)
bare Node (Lexeme Text)
a of
        Fix (UnaryExpr UnaryOp
UopAddress Node (Lexeme Text)
e) -> Node (Lexeme Text) -> Maybe AccessPath
accessPath Node (Lexeme Text)
e
        Node (Lexeme Text)
e                            -> AccessPath -> AccessPath
PathDeref (AccessPath -> AccessPath) -> Maybe AccessPath -> Maybe AccessPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node (Lexeme Text) -> Maybe AccessPath
accessPath Node (Lexeme Text)
e

-- | Whether a size expression makes something larger than it was. Scaling
-- by an element size doesn't.
enlarges :: Map String [C.Node (Lexeme Text)] -> C.Node (Lexeme Text) -> Bool
enlarges :: Map String [Node (Lexeme Text)] -> Node (Lexeme Text) -> Bool
enlarges Map String [Node (Lexeme Text)]
defs = Int -> Node (Lexeme Text) -> Bool
forall {t}. (Eq t, Num t) => t -> Node (Lexeme Text) -> Bool
go (Int
3 :: Int)
  where
    go :: t -> Node (Lexeme Text) -> Bool
go t
0 Node (Lexeme Text)
_ = Bool
False
    go t
k Node (Lexeme Text)
e = (Node (Lexeme Text) -> Bool) -> [Node (Lexeme Text)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Node (Lexeme Text) -> Bool
grows (Node (Lexeme Text) -> [Node (Lexeme Text)]
universe Node (Lexeme Text)
e) Bool -> Bool -> Bool
|| [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ t -> Node (Lexeme Text) -> Bool
go (t
k t -> t -> t
forall a. Num a => a -> a -> a
- t
1) Node (Lexeme Text)
d | Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
v)) <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe Node (Lexeme Text)
e, Node (Lexeme Text)
d <- [Node (Lexeme Text)]
-> String
-> Map String [Node (Lexeme Text)]
-> [Node (Lexeme Text)]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] (Text -> String
Text.unpack Text
v) Map String [Node (Lexeme Text)]
defs ]
    grows :: Node (Lexeme Text) -> Bool
grows (Fix NodeF (Lexeme Text) (Node (Lexeme Text))
n) = case NodeF (Lexeme Text) (Node (Lexeme Text))
n of
        BinaryExpr Node (Lexeme Text)
_ BinaryOp
BopPlus Node (Lexeme Text)
_ -> Bool
True
        BinaryExpr Node (Lexeme Text)
a BinaryOp
BopMul Node (Lexeme Text)
b  -> (Node (Lexeme Text) -> Bool) -> [Node (Lexeme Text)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> (Integer -> Bool) -> Maybe Integer -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
1) (Maybe Integer -> Bool)
-> (Node (Lexeme Text) -> Maybe Integer)
-> Node (Lexeme Text)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node (Lexeme Text) -> Maybe Integer
intLit) [Node (Lexeme Text)
a, Node (Lexeme Text)
b]
        UnaryExpr UnaryOp
UopIncr Node (Lexeme Text)
_    -> Bool
True
        NodeF (Lexeme Text) (Node (Lexeme Text))
_                      -> Bool
False

-- | The parameter a size comes from, looking through scaling by an element
-- size.
sizeParam :: Map String Int -> C.Node (Lexeme Text) -> Maybe Int
sizeParam :: Map String Int -> Node (Lexeme Text) -> Maybe Int
sizeParam Map String Int
params Node (Lexeme Text)
e = case Node (Lexeme Text) -> Node (Lexeme Text)
bare Node (Lexeme Text)
e of
    Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
p))                                       -> String -> Map String Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> String
Text.unpack Text
p) Map String Int
params
    Fix (BinaryExpr Node (Lexeme Text)
a BinaryOp
BopMul Node (Lexeme Text)
b) | (Node (Lexeme Text) -> Bool) -> [Node (Lexeme Text)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Maybe Integer -> Maybe Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Integer
forall a. Maybe a
Nothing) (Maybe Integer -> Bool)
-> (Node (Lexeme Text) -> Maybe Integer)
-> Node (Lexeme Text)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node (Lexeme Text) -> Maybe Integer
intLit) [Node (Lexeme Text)
a, Node (Lexeme Text)
b] -> case (Map String Int -> Node (Lexeme Text) -> Maybe Int
sizeParam Map String Int
params Node (Lexeme Text)
a, Map String Int -> Node (Lexeme Text) -> Maybe Int
sizeParam Map String Int
params Node (Lexeme Text)
b) of
        (Just Int
i, Maybe Int
_) -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
        (Maybe Int
_, Maybe Int
j)      -> Maybe Int
j
    Node (Lexeme Text)
_ -> Maybe Int
forall a. Maybe a
Nothing

-- | The growth a function's own statements cause.
localGrowth :: Structs -> Function -> [(Node, Growth)]
localGrowth :: Structs -> Function -> [(Node, Growth)]
localGrowth Structs
types Function
fn =
    [ (Node
node, String
-> Text
-> Lexeme Text
-> AccessPath
-> Maybe (Text, Text)
-> AccessPath
-> By
-> [Text]
-> Growth
Growth (Function -> String
fnFile Function
fn) (Function -> Text
fnName Function
fn) Lexeme Text
at AccessPath
what (Structs -> Function -> Node (Lexeme Text) -> Maybe (Text, Text)
fieldKey Structs
types Function
fn Node (Lexeme Text)
l) AccessPath
owner By
by [])
    | (Node
node, Node (Lexeme Text)
e) <- Function -> [(Node, Node (Lexeme Text))]
stmtExprs Function
fn
    , Fix (AssignExpr Node (Lexeme Text)
l AssignOp
AopEq Node (Lexeme Text)
r) <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe Node (Lexeme Text)
e
    , Just what :: AccessPath
what@(PathField AccessPath
owner String
_) <- [Node (Lexeme Text) -> Maybe AccessPath
accessPath (Node (Lexeme Text) -> Node (Lexeme Text)
bare Node (Lexeme Text)
l)]
    , Just (Lexeme Text
at, By
by) <- [Node (Lexeme Text) -> Node (Lexeme Text) -> Maybe (Lexeme Text, By)
listLink Node (Lexeme Text)
l Node (Lexeme Text)
r, AccessPath -> Node (Lexeme Text) -> Maybe (Lexeme Text, By)
arrayGrowth AccessPath
what Node (Lexeme Text)
r]
    ]
  where
    defs :: Map String [Node (Lexeme Text)]
defs = Function -> Map String [Node (Lexeme Text)]
definedAs Function
fn
    params :: Map String Int
params = [(String, Int)] -> Map String Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([String] -> [Int] -> [(String, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
Text.unpack (Function -> [Text]
fnParams Function
fn)) [Int
0 ..])

    -- A new list node stored where it outlives the function. Linking it to
    -- another node doesn't count, as the limit is on the list's owner.
    listLink :: Node (Lexeme Text) -> Node (Lexeme Text) -> Maybe (Lexeme Text, By)
listLink Node (Lexeme Text)
l Node (Lexeme Text)
r = case Node (Lexeme Text) -> Node (Lexeme Text)
bare Node (Lexeme Text)
r of
        v :: Node (Lexeme Text)
v@(Fix VarExpr{})
            | ((Node (Lexeme Text), Text, [Node (Lexeme Text)]) -> Bool)
-> [(Node (Lexeme Text), Text, [Node (Lexeme Text)])] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Node (Lexeme Text)
_, Text
name, [Node (Lexeme Text)]
_) -> Text -> Map Text Int -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Text
name Map Text Int
allocators) (Map String [Node (Lexeme Text)]
-> Node (Lexeme Text)
-> [(Node (Lexeme Text), Text, [Node (Lexeme Text)])]
callsIn Map String [Node (Lexeme Text)]
defs Node (Lexeme Text)
r)
            , Just Text
s <- Structs
-> Function -> Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
typeIn Structs
types Function
fn Node (Lexeme Text)
v Maybe (Node (Lexeme Text))
-> (Node (Lexeme Text) -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Node (Lexeme Text) -> Maybe Text
structName
            , Structs -> Text -> Bool
isNode Structs
types Text
s
            , Just (Node (Lexeme Text)
x, Lexeme Text
f) <- Node (Lexeme Text) -> Maybe (Node (Lexeme Text), Lexeme Text)
fieldOf Node (Lexeme Text)
l
            , (Structs
-> Function -> Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
typeIn Structs
types Function
fn Node (Lexeme Text)
x Maybe (Node (Lexeme Text))
-> (Node (Lexeme Text) -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Node (Lexeme Text) -> Maybe Text
structName) Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> Maybe Text
forall a. a -> Maybe a
Just Text
s ->
                (Lexeme Text, By) -> Maybe (Lexeme Text, By)
forall a. a -> Maybe a
Just (Lexeme Text
f, By
Grows)
        Node (Lexeme Text)
_ -> Maybe (Lexeme Text, By)
forall a. Maybe a
Nothing

    -- A reallocation of the array stored back into the same field.
    arrayGrowth :: AccessPath -> Node (Lexeme Text) -> Maybe (Lexeme Text, By)
arrayGrowth AccessPath
what Node (Lexeme Text)
r = case [ (Node (Lexeme Text)
callee, Node (Lexeme Text)
size) | (Node (Lexeme Text)
callee, Text
name, [Node (Lexeme Text)]
args) <- Map String [Node (Lexeme Text)]
-> Node (Lexeme Text)
-> [(Node (Lexeme Text), Text, [Node (Lexeme Text)])]
callsIn Map String [Node (Lexeme Text)]
defs Node (Lexeme Text)
r
                                               , Just (Int
ptr, Int
sizeArg) <- [Text -> Map Text (Int, Int) -> Maybe (Int, Int)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name Map Text (Int, Int)
reallocators]
                                               , (Node (Lexeme Text) -> Maybe AccessPath
accessPath (Node (Lexeme Text) -> Maybe AccessPath)
-> (Node (Lexeme Text) -> Node (Lexeme Text))
-> Node (Lexeme Text)
-> Maybe AccessPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node (Lexeme Text) -> Node (Lexeme Text)
bare (Node (Lexeme Text) -> Maybe AccessPath)
-> Maybe (Node (Lexeme Text)) -> Maybe AccessPath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> [Node (Lexeme Text)] -> Maybe (Node (Lexeme Text))
forall a. Int -> [a] -> Maybe a
nth Int
ptr [Node (Lexeme Text)]
args) Maybe AccessPath -> Maybe AccessPath -> Bool
forall a. Eq a => a -> a -> Bool
== AccessPath -> Maybe AccessPath
forall a. a -> Maybe a
Just AccessPath
what
                                               , Just Node (Lexeme Text)
size <- [Int -> [Node (Lexeme Text)] -> Maybe (Node (Lexeme Text))
forall a. Int -> [a] -> Maybe a
nth Int
sizeArg [Node (Lexeme Text)]
args] ] of
        (Node (Lexeme Text)
callee, Node (Lexeme Text)
size) : [(Node (Lexeme Text), Node (Lexeme Text))]
_ -> case Map String Int -> Node (Lexeme Text) -> Maybe Int
sizeParam Map String Int
params Node (Lexeme Text)
size of
            Just Int
i -> (Lexeme Text, By) -> Maybe (Lexeme Text, By)
forall a. a -> Maybe a
Just (Node (Lexeme Text) -> Lexeme Text
lexOf Node (Lexeme Text)
callee, Int -> By
ResizedBy Int
i)
            Maybe Int
Nothing | Map String [Node (Lexeme Text)] -> Node (Lexeme Text) -> Bool
enlarges Map String [Node (Lexeme Text)]
defs Node (Lexeme Text)
size -> (Lexeme Text, By) -> Maybe (Lexeme Text, By)
forall a. a -> Maybe a
Just (Node (Lexeme Text) -> Lexeme Text
lexOf Node (Lexeme Text)
callee, By
Grows)
                    | Bool
otherwise -> Maybe (Lexeme Text, By)
forall a. Maybe a
Nothing
        [] -> Maybe (Lexeme Text, By)
forall a. Maybe a
Nothing
    lexOf :: Node (Lexeme Text) -> Lexeme Text
lexOf Node (Lexeme Text)
callee = case Node (Lexeme Text) -> Node (Lexeme Text)
bare Node (Lexeme Text)
callee of
        Fix (VarExpr Lexeme Text
l) -> Lexeme Text
l
        Node (Lexeme Text)
_               -> AlexPosn -> LexemeClass -> Text -> Lexeme Text
forall text. AlexPosn -> LexemeClass -> text -> Lexeme text
L (Int -> Int -> Int -> AlexPosn
C.AlexPn Int
0 Int
0 Int
0) LexemeClass
C.IdVar Text
""

stmtExprs :: Function -> [(Node, C.Node (Lexeme Text))]
stmtExprs :: Function -> [(Node, Node (Lexeme Text))]
stmtExprs Function
fn = [ (Node
node, Node (Lexeme Text)
e) | Node
node <- Map Node [Edge] -> [Node]
forall k a. Map k a -> [k]
Map.keys Map Node [Edge]
cfg, Node (Lexeme Text)
e <- Node -> [Node (Lexeme Text)]
nodeExprs Node
node ]
  where
    (Node
_, Map Node [Edge]
cfg) = Node (Lexeme Text) -> (Node, Map Node [Edge])
fromFunction (Function -> Node (Lexeme Text)
fnDefn Function
fn)

-- | Lookup functions, which return a pointer into an array field of an
-- argument, directly or through another lookup.
finders :: Structs -> [Function] -> Map Text FieldKey
finders :: Structs -> [Function] -> Map Text (Text, Text)
finders Structs
types [Function]
fns = Map Text (Text, Text) -> Map Text (Text, Text)
go Map Text (Text, Text)
forall k a. Map k a
Map.empty
  where
    go :: Map Text (Text, Text) -> Map Text (Text, Text)
go Map Text (Text, Text)
known =
        let known' :: Map Text (Text, Text)
known' = [(Text, (Text, Text))] -> Map Text (Text, Text)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Function -> Text
fnName Function
f, (Text, Text)
k) | Function
f <- [Function]
fns, (Text, Text)
k : [(Text, Text)]
_ <- [(Node (Lexeme Text) -> Maybe (Text, Text))
-> [Node (Lexeme Text)] -> [(Text, Text)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Map Text (Text, Text)
-> Function -> Node (Lexeme Text) -> Maybe (Text, Text)
into Map Text (Text, Text)
known Function
f) (Function -> [Node (Lexeme Text)]
returned Function
f)] ]
        in if Map Text (Text, Text) -> Set Text
forall k a. Map k a -> Set k
Map.keysSet Map Text (Text, Text)
known' Set Text -> Set Text -> Bool
forall a. Eq a => a -> a -> Bool
== Map Text (Text, Text) -> Set Text
forall k a. Map k a -> Set k
Map.keysSet Map Text (Text, Text)
known then Map Text (Text, Text)
known' else Map Text (Text, Text) -> Map Text (Text, Text)
go Map Text (Text, Text)
known'
    returned :: Function -> [Node (Lexeme Text)]
returned Function
f = [ Node (Lexeme Text)
e | Fix (Return (Just Node (Lexeme Text)
e)) <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe (Function -> Node (Lexeme Text)
fnDefn Function
f) ]
    into :: Map Text (Text, Text)
-> Function -> Node (Lexeme Text) -> Maybe (Text, Text)
into Map Text (Text, Text)
known Function
f Node (Lexeme Text)
e = case Node (Lexeme Text) -> Node (Lexeme Text)
bare Node (Lexeme Text)
e of
        Fix (UnaryExpr UnaryOp
UopAddress (Fix (ArrayAccess Node (Lexeme Text)
arr Node (Lexeme Text)
_))) -> Structs -> Function -> Node (Lexeme Text) -> Maybe (Text, Text)
fieldKey Structs
types Function
f Node (Lexeme Text)
arr
        Fix (BinaryExpr Node (Lexeme Text)
arr BinaryOp
BopPlus Node (Lexeme Text)
_)                       -> Structs -> Function -> Node (Lexeme Text) -> Maybe (Text, Text)
fieldKey Structs
types Function
f Node (Lexeme Text)
arr
        Fix (FunctionCall Node (Lexeme Text)
callee [Node (Lexeme Text)]
_) | Just Text
g <- Node (Lexeme Text) -> Maybe Text
getFuncName Node (Lexeme Text)
callee -> Text -> Map Text (Text, Text) -> Maybe (Text, Text)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
g Map Text (Text, Text)
known
        Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
v)) -> case [ (Text, Text)
k | Node (Lexeme Text)
d <- [Node (Lexeme Text)]
-> String
-> Map String [Node (Lexeme Text)]
-> [Node (Lexeme Text)]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] (Text -> String
Text.unpack Text
v) (Function -> Map String [Node (Lexeme Text)]
definedAs Function
f), Just (Text, Text)
k <- [Map Text (Text, Text)
-> Function -> Node (Lexeme Text) -> Maybe (Text, Text)
into Map Text (Text, Text)
known Function
f Node (Lexeme Text)
d] ] of
            (Text, Text)
k : [(Text, Text)]
_ -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text, Text)
k
            []    -> Maybe (Text, Text)
forall a. Maybe a
Nothing
        Node (Lexeme Text)
_ -> Maybe (Text, Text)
forall a. Maybe a
Nothing

-- | Functions that may make a list or array smaller, by lowering a count or
-- calling a function that does.
shrinkers :: [Function] -> Set Text
shrinkers :: [Function] -> Set Text
shrinkers [Function]
fns = Set Text -> Set Text
go ([Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList [ Function -> Text
fnName Function
f | Function
f <- [Function]
fns, (Node (Lexeme Text) -> Bool) -> [Node (Lexeme Text)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Node (Lexeme Text) -> Bool
lowers (Node (Lexeme Text) -> [Node (Lexeme Text)]
universe (Function -> Node (Lexeme Text)
fnDefn Function
f)) ])
  where
    go :: Set Text -> Set Text
go Set Text
known =
        let known' :: Set Text
known' = Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Text
known ([Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList [ Function -> Text
fnName Function
f | Function
f <- [Function]
fns, (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
known) (Function -> [Text]
callees Function
f) ])
        in if Set Text
known' Set Text -> Set Text -> Bool
forall a. Eq a => a -> a -> Bool
== Set Text
known then Set Text
known else Set Text -> Set Text
go Set Text
known'

lowers :: C.Node (Lexeme Text) -> Bool
lowers :: Node (Lexeme Text) -> Bool
lowers (Fix NodeF (Lexeme Text) (Node (Lexeme Text))
n) = case NodeF (Lexeme Text) (Node (Lexeme Text))
n of
    UnaryExpr UnaryOp
UopDecr Node (Lexeme Text)
e     -> Node (Lexeme Text) -> Bool
isField Node (Lexeme Text)
e
    AssignExpr Node (Lexeme Text)
e AssignOp
AopMinus Node (Lexeme Text)
_ -> Node (Lexeme Text) -> Bool
isField Node (Lexeme Text)
e
    NodeF (Lexeme Text) (Node (Lexeme Text))
_                       -> Bool
False
  where
    isField :: Node (Lexeme Text) -> Bool
isField Node (Lexeme Text)
e = Maybe (Node (Lexeme Text), Lexeme Text) -> Bool
forall a. Maybe a -> Bool
isJust (Node (Lexeme Text) -> Maybe (Node (Lexeme Text), Lexeme Text)
fieldOf Node (Lexeme Text)
e)

-- | Whether this function limits the growth at a node. Either a check like
-- `count >= MAX` returns before it, a failed lookup in a limited array returns
-- before it, or every path after it makes a list smaller, as moving an entry
-- between lists does.
limited :: Context -> Function -> CFG -> Node -> AccessPath -> Bool
limited :: Context
-> Function -> Map Node [Edge] -> Node -> AccessPath -> Bool
limited Context
ctx Function
fn Map Node [Edge]
cfg Node
site AccessPath
owner = (Node -> Bool) -> [Node] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Node -> Bool
guards (Map Node [Edge] -> [Node]
forall k a. Map k a -> [k]
Map.keys Map Node [Edge]
cfg) Bool -> Bool -> Bool
|| Bool
moves
  where
    succs :: Node -> [Node]
succs Node
n = (Edge -> Node) -> [Edge] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map Edge -> Node
forall a b. (a, b) -> b
snd ([Edge] -> Node -> Map Node [Edge] -> [Edge]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] Node
n Map Node [Edge]
cfg)
    reachable :: [Node] -> Set Node
reachable = Set Node -> [Node] -> Set Node
reach Set Node
forall a. Set a
Set.empty
    reach :: Set Node -> [Node] -> Set Node
reach Set Node
seen [] = Set Node
seen
    reach Set Node
seen (Node
n : [Node]
ns)
        | Node
n Node -> Set Node -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Node
seen = Set Node -> [Node] -> Set Node
reach Set Node
seen [Node]
ns
        | Bool
otherwise = Set Node -> [Node] -> Set Node
reach (Node -> Set Node -> Set Node
forall a. Ord a => a -> Set a -> Set a
Set.insert Node
n Set Node
seen) (Node -> [Node]
succs Node
n [Node] -> [Node] -> [Node]
forall a. [a] -> [a] -> [a]
++ [Node]
ns)
    reaches :: Node -> Bool
reaches Node
n = Node
site Node -> Set Node -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` [Node] -> Set Node
reachable (Node -> [Node]
succs Node
n)
    bails :: Node -> Bool
bails Node
n = Node
n Node -> Node -> Bool
forall a. Eq a => a -> a -> Bool
/= Node
site Bool -> Bool -> Bool
&& Bool -> Bool
not (Node
site Node -> Set Node -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` [Node] -> Set Node
reachable [Node
n])

    guards :: Node -> Bool
guards b :: Node
b@(Node Int
_ (BranchNode Node (Lexeme Text)
cond)) =
        Node -> Bool
reaches Node
b Bool -> Bool -> Bool
&& (Node (Lexeme Text) -> Bool
compares Node (Lexeme Text)
cond Bool -> Bool -> Bool
&& (Node -> Bool) -> [Node] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Node -> Bool
bails (Node -> [Node]
succs Node
b) Bool -> Bool -> Bool
|| Node -> Node (Lexeme Text) -> Bool
lookupFails Node
b Node (Lexeme Text)
cond)
    guards Node
_ = Bool
False

    -- Capacity, overflow, null, 0 and -1 checks aren't limits. They only say
    -- when to grow, or that something is missing, empty or failed.
    compares :: Node (Lexeme Text) -> Bool
compares Node (Lexeme Text)
cond = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
        [ (Node (Lexeme Text) -> Bool) -> [Node (Lexeme Text)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Node (Lexeme Text) -> Bool
ofOwner (Node (Lexeme Text) -> [Node (Lexeme Text)]
expand Node (Lexeme Text)
a) Bool -> Bool -> Bool
&& Bool -> Bool
not ((Node (Lexeme Text) -> Bool) -> [Node (Lexeme Text)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Node (Lexeme Text) -> Bool
ofOwner (Node (Lexeme Text) -> [Node (Lexeme Text)]
expand Node (Lexeme Text)
b)) Bool -> Bool -> Bool
&& Bool -> Bool
not (Node (Lexeme Text) -> Bool
typeMax Node (Lexeme Text)
b) Bool -> Bool -> Bool
&& Bool -> Bool
not (Node (Lexeme Text) -> Bool
isNullLit Node (Lexeme Text)
b)
          Bool -> Bool -> Bool
&& Bool -> Bool
not (Bool -> (Integer -> Bool) -> Maybe Integer -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0) (Node (Lexeme Text) -> Maybe Integer
intLit Node (Lexeme Text)
b))
        | Fix (BinaryExpr Node (Lexeme Text)
l BinaryOp
op Node (Lexeme Text)
r) <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe Node (Lexeme Text)
cond, BinaryOp
op BinaryOp -> [BinaryOp] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BinaryOp
BopLt, BinaryOp
BopLe, BinaryOp
BopGt, BinaryOp
BopGe, BinaryOp
BopEq, BinaryOp
BopNe]
        , (Node (Lexeme Text)
a, Node (Lexeme Text)
b) <- [(Node (Lexeme Text)
l, Node (Lexeme Text)
r), (Node (Lexeme Text)
r, Node (Lexeme Text)
l)] ]
    -- A struct stored inside another is limited by the outer one's limits.
    ofOwner :: Node (Lexeme Text) -> Bool
ofOwner Node (Lexeme Text)
e = case Node (Lexeme Text) -> Maybe AccessPath
accessPath (Node (Lexeme Text) -> Node (Lexeme Text)
bare Node (Lexeme Text)
e) of
        Just (PathField AccessPath
o String
_) -> AccessPath -> AccessPath -> Bool
holds AccessPath
o AccessPath
owner
        Maybe AccessPath
_                    -> Bool
False
    holds :: AccessPath -> AccessPath -> Bool
holds AccessPath
o AccessPath
p = AccessPath
o AccessPath -> AccessPath -> Bool
forall a. Eq a => a -> a -> Bool
== AccessPath
p Bool -> Bool -> Bool
|| case AccessPath
p of
        PathField AccessPath
p' String
_ -> AccessPath -> AccessPath -> Bool
holds AccessPath
o AccessPath
p'
        AccessPath
_              -> Bool
False
    defs :: Map String [Node (Lexeme Text)]
defs = Function -> Map String [Node (Lexeme Text)]
definedAs Function
fn
    expand :: Node (Lexeme Text) -> [Node (Lexeme Text)]
expand = Int -> Node (Lexeme Text) -> [Node (Lexeme Text)]
forall {t}.
(Eq t, Num t) =>
t -> Node (Lexeme Text) -> [Node (Lexeme Text)]
go (Int
3 :: Int)
      where
        go :: t -> Node (Lexeme Text) -> [Node (Lexeme Text)]
go t
0 Node (Lexeme Text)
e = Node (Lexeme Text) -> [Node (Lexeme Text)]
universe Node (Lexeme Text)
e
        go t
k Node (Lexeme Text)
e = Node (Lexeme Text) -> [Node (Lexeme Text)]
universe Node (Lexeme Text)
e [Node (Lexeme Text)]
-> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall a. [a] -> [a] -> [a]
++ [[Node (Lexeme Text)]] -> [Node (Lexeme Text)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ t -> Node (Lexeme Text) -> [Node (Lexeme Text)]
go (t
k t -> t -> t
forall a. Num a => a -> a -> a
- t
1) Node (Lexeme Text)
d | Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
v)) <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe Node (Lexeme Text)
e, Node (Lexeme Text)
d <- [Node (Lexeme Text)]
-> String
-> Map String [Node (Lexeme Text)]
-> [Node (Lexeme Text)]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] (Text -> String
Text.unpack Text
v) Map String [Node (Lexeme Text)]
defs, Node (Lexeme Text) -> Bool
arithmetic Node (Lexeme Text)
d ]
    arithmetic :: Node (Lexeme Text) -> Bool
arithmetic Node (Lexeme Text)
d = [()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ () | Fix NodeF (Lexeme Text) (Node (Lexeme Text))
n <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe Node (Lexeme Text)
d, case NodeF (Lexeme Text) (Node (Lexeme Text))
n of FunctionCall{} -> Bool
True; UnaryExpr UnaryOp
UopAddress Node (Lexeme Text)
_ -> Bool
True; NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> Bool
False ]
    typeMax :: Node (Lexeme Text) -> Bool
typeMax Node (Lexeme Text)
e = case Node (Lexeme Text) -> Node (Lexeme Text)
bare Node (Lexeme Text)
e of
        Fix (LiteralExpr LiteralType
_ (L AlexPosn
_ LexemeClass
_ Text
t)) -> Text
t Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"SIZE_MAX", Text
"INT_MAX", Text
"UINT_MAX", Text
"INT8_MAX", Text
"UINT8_MAX", Text
"INT16_MAX", Text
"UINT16_MAX", Text
"INT32_MAX", Text
"UINT32_MAX", Text
"INT64_MAX", Text
"UINT64_MAX"]
        Node (Lexeme Text)
_                             -> Bool
False

    -- Looking up the thing that grows doesn't limit it.
    lookupFails :: Node -> Node (Lexeme Text) -> Bool
lookupFails Node
b Node (Lexeme Text)
cond = case (Node (Lexeme Text) -> Maybe Text)
-> Node (Lexeme Text) -> Maybe (Text, EdgeType)
forall a.
(Node (Lexeme Text) -> Maybe a)
-> Node (Lexeme Text) -> Maybe (a, EdgeType)
nullTest Node (Lexeme Text) -> Maybe Text
found Node (Lexeme Text)
cond of
        Just (Text
v, EdgeType
edge) -> AccessPath -> Maybe String
rootOf AccessPath
owner Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> Maybe String
forall a. a -> Maybe a
Just (Text -> String
Text.unpack Text
v)
            Bool -> Bool -> Bool
&& (Edge -> Bool) -> [Edge] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(EdgeType
e, Node
n) -> EdgeType
e EdgeType -> EdgeType -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeType
edge Bool -> Bool -> Bool
&& Node -> Bool
bails Node
n) ([Edge] -> Node -> Map Node [Edge] -> [Edge]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] Node
b Map Node [Edge]
cfg)
        Maybe (Text, EdgeType)
Nothing        -> Bool
False
    found :: Node (Lexeme Text) -> Maybe Text
found Node (Lexeme Text)
e = case Node (Lexeme Text) -> Node (Lexeme Text)
bare Node (Lexeme Text)
e of
        Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
v))
            | (Text, Text)
k : [(Text, Text)]
_ <- [ (Text, Text)
k | (Node (Lexeme Text)
_, Text
name, [Node (Lexeme Text)]
_) <- Map String [Node (Lexeme Text)]
-> Node (Lexeme Text)
-> [(Node (Lexeme Text), Text, [Node (Lexeme Text)])]
callsIn (Function -> Map String [Node (Lexeme Text)]
definedAs Function
fn) Node (Lexeme Text)
e, Just (Text, Text)
k <- [Text -> Map Text (Text, Text) -> Maybe (Text, Text)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name (Context -> Map Text (Text, Text)
ctxFinders Context
ctx)] ]
            , Bool -> Bool
not ((Text, Text)
k (Text, Text) -> Set (Text, Text) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Context -> Set (Text, Text)
ctxGrowing Context
ctx) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
v
        Node (Lexeme Text)
_ -> Maybe Text
forall a. Maybe a
Nothing

    -- Every way out from the growth passes something making a list smaller.
    moves :: Bool
moves = Bool -> Bool
not ((Node -> Bool) -> [Node] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Node -> Bool
isExit (Set Node -> [Node]
forall a. Set a -> [a]
Set.toList (Set Node -> [Node] -> Set Node
avoiding Set Node
forall a. Set a
Set.empty (Node -> [Node]
succs Node
site))))
    avoiding :: Set Node -> [Node] -> Set Node
avoiding Set Node
seen [] = Set Node
seen
    avoiding Set Node
seen (Node
n : [Node]
ns)
        | Node
n Node -> Set Node -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Node
seen Bool -> Bool -> Bool
|| Node -> Bool
shrinks Node
n = Set Node -> [Node] -> Set Node
avoiding Set Node
seen [Node]
ns
        | Bool
otherwise = Set Node -> [Node] -> Set Node
avoiding (Node -> Set Node -> Set Node
forall a. Ord a => a -> Set a -> Set a
Set.insert Node
n Set Node
seen) (Node -> [Node]
succs Node
n [Node] -> [Node] -> [Node]
forall a. [a] -> [a] -> [a]
++ [Node]
ns)
    shrinks :: Node -> Bool
shrinks Node
n = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
        [ Node (Lexeme Text) -> Bool
lowers Node (Lexeme Text)
x Bool -> Bool -> Bool
|| Bool -> (Text -> Bool) -> Maybe Text -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Context -> Set Text
ctxShrinkers Context
ctx) (Node (Lexeme Text) -> Maybe Text
getFuncName' Node (Lexeme Text)
x)
        | Node (Lexeme Text)
e <- Node -> [Node (Lexeme Text)]
nodeExprs Node
n, Node (Lexeme Text)
x <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe Node (Lexeme Text)
e ]
    getFuncName' :: Node (Lexeme Text) -> Maybe Text
getFuncName' = \case
        Fix (FunctionCall Node (Lexeme Text)
callee [Node (Lexeme Text)]
_) -> Node (Lexeme Text) -> Maybe Text
getFuncName Node (Lexeme Text)
callee
        Node (Lexeme Text)
_                           -> Maybe Text
forall a. Maybe a
Nothing
    isExit :: Node -> Bool
isExit = \case
        Node Int
_ NodeKind
ExitNode -> Bool
True
        Node
_               -> Bool
False

-- | The growth a function doesn't limit itself.
unlimited :: Context -> Summary -> Function -> [Growth]
unlimited :: Context -> Summary -> Function -> [Growth]
unlimited Context
ctx Summary
summary Function
fn =
    [ Growth
g | (Node
node, Growth
g) <- Structs -> Function -> [(Node, Growth)]
localGrowth (Context -> Structs
ctxTypes Context
ctx) Function
fn [(Node, Growth)] -> [(Node, Growth)] -> [(Node, Growth)]
forall a. [a] -> [a] -> [a]
++ [(Node, Growth)]
callGrowth, Bool -> Bool
not (Context
-> Function -> Map Node [Edge] -> Node -> AccessPath -> Bool
limited Context
ctx Function
fn Map Node [Edge]
cfg Node
node (Growth -> AccessPath
growOwner Growth
g)) ]
  where
    (Node
_, Map Node [Edge]
cfg) = Node (Lexeme Text) -> (Node, Map Node [Edge])
fromFunction (Function -> Node (Lexeme Text)
fnDefn Function
fn)
    defs :: Map String [Node (Lexeme Text)]
defs = Function -> Map String [Node (Lexeme Text)]
definedAs Function
fn
    callGrowth :: [(Node, Growth)]
callGrowth =
        [ (Node
node, Growth
g { growOwner = owner, growBy = by, growVia = name : growVia g })
        | (Node
node, Node (Lexeme Text)
e) <- Function -> [(Node, Node (Lexeme Text))]
stmtExprs Function
fn
        , Fix (FunctionCall Node (Lexeme Text)
callee [Node (Lexeme Text)]
args) <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe Node (Lexeme Text)
e
        , Just Text
name <- [Node (Lexeme Text) -> Maybe Text
getFuncName Node (Lexeme Text)
callee]
        , Just Function
callee' <- [Text -> Map Text Function -> Maybe Function
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name (Context -> Map Text Function
ctxFns Context
ctx)]
        , Just Set Growth
grown <- [Text -> Summary -> Maybe (Set Growth)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name Summary
summary]
        , let argMap :: Map String (Node (Lexeme Text))
argMap = [(String, Node (Lexeme Text))] -> Map String (Node (Lexeme Text))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([String] -> [Node (Lexeme Text)] -> [(String, Node (Lexeme Text))]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
Text.unpack (Function -> [Text]
fnParams Function
callee')) [Node (Lexeme Text)]
args)
        , Growth
g <- Set Growth -> [Growth]
forall a. Set a -> [a]
Set.toList Set Growth
grown
        , Just AccessPath
owner <- [Map String (Node (Lexeme Text)) -> AccessPath -> Maybe AccessPath
substitute Map String (Node (Lexeme Text))
argMap (Growth -> AccessPath
growOwner Growth
g)]
        , Just By
by <- [[Node (Lexeme Text)] -> By -> Maybe By
resized [Node (Lexeme Text)]
args (Growth -> By
growBy Growth
g)]
        ]
    resized :: [Node (Lexeme Text)] -> By -> Maybe By
resized [Node (Lexeme Text)]
args = \case
        By
Grows -> By -> Maybe By
forall a. a -> Maybe a
Just By
Grows
        ResizedBy Int
i -> case Int -> [Node (Lexeme Text)] -> Maybe (Node (Lexeme Text))
forall a. Int -> [a] -> Maybe a
nth Int
i [Node (Lexeme Text)]
args of
            Just Node (Lexeme Text)
a | Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
p)) <- Node (Lexeme Text) -> Node (Lexeme Text)
bare Node (Lexeme Text)
a, Just Int
j <- Text -> [Text] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
List.elemIndex Text
p (Function -> [Text]
fnParams Function
fn) -> By -> Maybe By
forall a. a -> Maybe a
Just (Int -> By
ResizedBy Int
j)
                   | Map String [Node (Lexeme Text)] -> Node (Lexeme Text) -> Bool
enlarges Map String [Node (Lexeme Text)]
defs Node (Lexeme Text)
a -> By -> Maybe By
forall a. a -> Maybe a
Just By
Grows
            Maybe (Node (Lexeme Text))
_ -> Maybe By
forall a. Maybe a
Nothing

paramRooted :: Function -> Growth -> Bool
paramRooted :: Function -> Growth -> Bool
paramRooted Function
fn Growth
g = Bool -> (String -> Bool) -> Maybe String -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Function -> [Text]
fnParams Function
fn) (Text -> Bool) -> (String -> Text) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack) (AccessPath -> Maybe String
rootOf (Growth -> AccessPath
growOwner Growth
g))

summarise :: Context -> Summary
summarise :: Context -> Summary
summarise Context
ctx = (Function -> [Text])
-> (Summary -> Function -> Summary)
-> (Summary -> Function -> Set Growth)
-> [Function]
-> Summary
-> Summary
forall k s.
Eq k =>
(Function -> [Text])
-> (s -> Function -> s)
-> (s -> Function -> k)
-> [Function]
-> s
-> s
bottomUp Function -> [Text]
callees Summary -> Function -> Summary
add Summary -> Function -> Set Growth
forall {a}. Map Text (Set a) -> Function -> Set a
look (Map Text Function -> [Function]
forall k a. Map k a -> [a]
Map.elems (Context -> Map Text Function
ctxFns Context
ctx)) Summary
forall k a. Map k a
Map.empty
  where
    add :: Summary -> Function -> Summary
add Summary
s Function
fn = Text -> Set Growth -> Summary -> Summary
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Function -> Text
fnName Function
fn) ([Growth] -> Set Growth
forall a. Ord a => [a] -> Set a
Set.fromList ((Growth -> Bool) -> [Growth] -> [Growth]
forall a. (a -> Bool) -> [a] -> [a]
filter (Function -> Growth -> Bool
paramRooted Function
fn) (Context -> Summary -> Function -> [Growth]
unlimited Context
ctx Summary
s Function
fn))) Summary
s
    look :: Map Text (Set a) -> Function -> Set a
look Map Text (Set a)
s Function
fn = Set a -> Text -> Map Text (Set a) -> Set a
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Set a
forall a. Set a
Set.empty (Function -> Text
fnName Function
fn) Map Text (Set a)
s

-- | Struct types, field targets, and the functions passed for each
-- parameter, by function and parameter name.
data Pointers = Pointers Structs FieldTargets (Map (Text, Text) (Set Text))

pointers :: [(FilePath, [C.Node (Lexeme Text)])] -> [Function] -> Pointers
pointers :: [(String, [Node (Lexeme Text)])] -> [Function] -> Pointers
pointers [(String, [Node (Lexeme Text)])]
tus [Function]
fns = Structs -> FieldTargets -> Map (Text, Text) (Set Text) -> Pointers
Pointers Structs
types FieldTargets
targets Map (Text, Text) (Set Text)
passed
  where
    types :: Structs
types = [(String, [Node (Lexeme Text)])] -> Structs
structs [(String, [Node (Lexeme Text)])]
tus
    targets :: FieldTargets
targets = [(String, [Node (Lexeme Text)])] -> FieldTargets
fieldTargets [(String, [Node (Lexeme Text)])]
tus
    byName :: Map Text Function
byName = [(Text, Function)] -> Map Text Function
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Function -> Text
fnName Function
f, Function
f) | Function
f <- [Function]
fns ]
    passed :: Map (Text, Text) (Set Text)
passed = (Set Text -> Set Text -> Set Text)
-> [((Text, Text), Set Text)] -> Map (Text, Text) (Set Text)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
Set.union
        [ ((Text
g, Text
p), [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList (Function -> Node (Lexeme Text) -> [Text]
valueTargets Function
caller Node (Lexeme Text)
a))
        | Function
caller <- [Function]
fns
        , Fix (FunctionCall Node (Lexeme Text)
callee [Node (Lexeme Text)]
args) <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe (Function -> Node (Lexeme Text)
fnDefn Function
caller)
        , Just Text
g <- [Node (Lexeme Text) -> Maybe Text
getFuncName Node (Lexeme Text)
callee]
        , Just Function
f <- [Text -> Map Text Function -> Maybe Function
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
g Map Text Function
byName]
        , (Text
p, Node (Lexeme Text)
a) <- [Text] -> [Node (Lexeme Text)] -> [(Text, Node (Lexeme Text))]
forall a b. [a] -> [b] -> [(a, b)]
zip (Function -> [Text]
fnParams Function
f) [Node (Lexeme Text)]
args ]
    valueTargets :: Function -> Node (Lexeme Text) -> [Text]
valueTargets Function
caller Node (Lexeme Text)
a = case Node (Lexeme Text) -> Node (Lexeme Text)
bare Node (Lexeme Text)
a of
        Fix (UnaryExpr UnaryOp
UopAddress Node (Lexeme Text)
e) -> Function -> Node (Lexeme Text) -> [Text]
valueTargets Function
caller Node (Lexeme Text)
e
        Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
g)) | Text -> Map Text Function -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Text
g Map Text Function
byName -> [Text
g]
        Node (Lexeme Text)
e -> case Structs
-> FieldTargets -> Function -> Node (Lexeme Text) -> Maybe Targets
callTargets Structs
types FieldTargets
targets Function
caller Node (Lexeme Text)
e of
            Just (Only Set Text
s)     -> Set Text -> [Text]
forall a. Set a -> [a]
Set.toList Set Text
s
            Just (Anything Set Text
s) -> Set Text -> [Text]
forall a. Set a -> [a]
Set.toList Set Text
s
            Maybe Targets
Nothing           -> []

-- | The functions each function calls, directly or through a pointer.
calls :: Pointers -> Function -> [Text]
calls :: Pointers -> Function -> [Text]
calls (Pointers Structs
types FieldTargets
targets Map (Text, Text) (Set Text)
passed) Function
f =
    [ Text
name | Text
name <- Function -> [Text]
callees Function
f, Text
name Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Function -> [Text]
fnParams Function
f ] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    [ Text
t
    | Fix (FunctionCall Node (Lexeme Text)
callee [Node (Lexeme Text)]
_) <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe (Function -> Node (Lexeme Text)
fnDefn Function
f)
    , Text
t <- case Node (Lexeme Text) -> Maybe Text
getFuncName Node (Lexeme Text)
callee of
        Just Text
p | Text
p Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Function -> [Text]
fnParams Function
f -> Set Text -> [Text]
forall a. Set a -> [a]
Set.toList (Set Text -> (Text, Text) -> Map (Text, Text) (Set Text) -> Set Text
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Set Text
forall a. Set a
Set.empty (Function -> Text
fnName Function
f, Text
p) Map (Text, Text) (Set Text)
passed)
        Just Text
_ -> []
        Maybe Text
Nothing -> case Structs
-> FieldTargets -> Function -> Node (Lexeme Text) -> Maybe Targets
callTargets Structs
types FieldTargets
targets Function
f Node (Lexeme Text)
callee of
            Just Targets
ts -> Set Text -> [Text]
forall a. Set a -> [a]
Set.toList (case Targets
ts of Only Set Text
s -> Set Text
s; Anything Set Text
s -> Set Text
s)
            Maybe Targets
Nothing -> []
    ]

-- | Functions that read packets from a socket into their own buffer. The
-- analysis starts there.
receivers :: Pointers -> [Function] -> [Function]
receivers :: Pointers -> [Function] -> [Function]
receivers Pointers
ptrs [Function]
fns =
    [ Function
f
    | Function
f <- [Function]
fns
    , let buffers :: Set Text
buffers = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList [ Text
v | Fix (VarDecl Node (Lexeme Text)
_ (L AlexPosn
_ LexemeClass
_ Text
v) (Node (Lexeme Text)
_ : [Node (Lexeme Text)]
_)) <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe (Function -> Node (Lexeme Text)
fnDefn Function
f) ]
    , Bool -> Bool
not (Set Text -> Bool
forall a. Set a -> Bool
Set.null Set Text
buffers)
    , [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Text
name Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
readers Bool -> Bool -> Bool
&& (Node (Lexeme Text) -> Bool) -> [Node (Lexeme Text)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Set Text -> Node (Lexeme Text) -> Bool
usesBuffer Set Text
buffers) [Node (Lexeme Text)]
args
         | Fix (FunctionCall Node (Lexeme Text)
callee [Node (Lexeme Text)]
args) <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe (Function -> Node (Lexeme Text)
fnDefn Function
f), Just Text
name <- [Node (Lexeme Text) -> Maybe Text
getFuncName Node (Lexeme Text)
callee] ]
    ]
  where
    usesBuffer :: Set Text -> Node (Lexeme Text) -> Bool
usesBuffer Set Text
buffers Node (Lexeme Text)
a = case Node (Lexeme Text) -> Node (Lexeme Text)
bare Node (Lexeme Text)
a of
        Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
v))                                                    -> Text
v Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
buffers
        Fix (BinaryExpr (Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
v))) BinaryOp
BopPlus Node (Lexeme Text)
_)                       -> Text
v Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
buffers
        Fix (UnaryExpr UnaryOp
UopAddress (Fix (ArrayAccess (Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
v))) Node (Lexeme Text)
_))) -> Text
v Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
buffers
        Node (Lexeme Text)
_                                                                          -> Bool
False
    graph :: Map Text [Text]
graph = [(Text, [Text])] -> Map Text [Text]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Function -> Text
fnName Function
f, Pointers -> Function -> [Text]
calls Pointers
ptrs Function
f) | Function
f <- [Function]
fns ]
    -- Functions that end up calling the system's socket reads.
    readers :: Set Text
readers = Set Text -> Set Text
go ([Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList [Text
"recv", Text
"recvfrom"])
      where
        go :: Set Text -> Set Text
go Set Text
known =
            let known' :: Set Text
known' = Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Text
known (Map Text [Text] -> Set Text
forall k a. Map k a -> Set k
Map.keysSet (([Text] -> Bool) -> Map Text [Text] -> Map Text [Text]
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter ((Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
known)) Map Text [Text]
graph))
            in if Set Text
known' Set Text -> Set Text -> Bool
forall a. Eq a => a -> a -> Bool
== Set Text
known then Set Text
known else Set Text -> Set Text
go Set Text
known'

-- | Growth nothing limits, and the calls packets take to reach it.
data Finding = Finding Growth [Function]

findings :: [(FilePath, [C.Node (Lexeme Text)])] -> [Finding]
findings :: [(String, [Node (Lexeme Text)])] -> [Finding]
findings [(String, [Node (Lexeme Text)])]
tus = Set (Text, Text) -> [Finding]
settle ([(Text, Text)] -> Set (Text, Text)
forall a. Ord a => [a] -> Set a
Set.fromList [ (Text, Text)
k | Function
f <- [Function]
fns, (Node
_, Growth
g) <- Structs -> Function -> [(Node, Growth)]
localGrowth Structs
types Function
f, Just (Text, Text)
k <- [Growth -> Maybe (Text, Text)
growField Growth
g] ])
  where
    fns :: [Function]
fns = [(String, [Node (Lexeme Text)])] -> [Function]
definitions [(String, [Node (Lexeme Text)])]
tus
    types :: Structs
types = [(String, [Node (Lexeme Text)])] -> Structs
structs [(String, [Node (Lexeme Text)])]
tus
    ptrs :: Pointers
ptrs = [(String, [Node (Lexeme Text)])] -> [Function] -> Pointers
pointers [(String, [Node (Lexeme Text)])]
tus [Function]
fns
    byName :: Map Text Function
byName = [(Text, Function)] -> Map Text Function
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Function -> Text
fnName Function
f, Function
f) | Function
f <- [Function]
fns ]
    found :: Map Text (Text, Text)
found = Structs -> [Function] -> Map Text (Text, Text)
finders Structs
types [Function]
fns
    shrinking :: Set Text
shrinking = [Function] -> Set Text
shrinkers [Function]
fns

    -- Lookups only limit growth when what they look in is limited, so start
    -- with every field growing and drop the ones found limited until none
    -- change.
    settle :: Set (Text, Text) -> [Finding]
settle Set (Text, Text)
growing =
        let result :: [Finding]
result = Set (Text, Text) -> [Finding]
search Set (Text, Text)
growing
            growing' :: Set (Text, Text)
growing' = [(Text, Text)] -> Set (Text, Text)
forall a. Ord a => [a] -> Set a
Set.fromList [ (Text, Text)
k | Finding Growth
g [Function]
_ <- [Finding]
result, Just (Text, Text)
k <- [Growth -> Maybe (Text, Text)
growField Growth
g] ]
        in if Set (Text, Text)
growing' Set (Text, Text) -> Set (Text, Text) -> Bool
forall a. Eq a => a -> a -> Bool
== Set (Text, Text)
growing then [Finding]
result else Set (Text, Text) -> [Finding]
settle Set (Text, Text)
growing'

    search :: Set (Text, Text) -> [Finding]
search Set (Text, Text)
growing = Map (Text, AccessPath) Finding -> [Finding]
forall k a. Map k a -> [a]
Map.elems (Map (Text, AccessPath) Finding -> [Finding])
-> Map (Text, AccessPath) Finding -> [Finding]
forall a b. (a -> b) -> a -> b
$ (Finding -> Finding -> Finding)
-> [((Text, AccessPath), Finding)]
-> Map (Text, AccessPath) Finding
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Finding -> Finding -> Finding
first
        [ (Growth -> (Text, AccessPath)
site Growth
g, Growth -> [Function] -> Finding
Finding Growth
g (Text -> [Function]
chain (Function -> Text
fnName Function
fn)))
        | Function
fn <- [Function]
fns
        , Function -> Text
fnName Function
fn Text -> Map Text (Maybe Text) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map Text (Maybe Text)
reached
        , Growth
g <- Context -> Summary -> Function -> [Growth]
unlimited Context
ctx Summary
summary Function
fn
        , Bool -> Bool
not (Function -> Growth -> Bool
paramRooted Function
fn Growth
g) Bool -> Bool -> Bool
|| Function -> Text
fnName Function
fn Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
receiverNames
        ]
      where
        ctx :: Context
ctx = Structs
-> Map Text Function
-> Map Text (Text, Text)
-> Set Text
-> Set (Text, Text)
-> Context
Context Structs
types Map Text Function
byName Map Text (Text, Text)
found Set Text
shrinking Set (Text, Text)
growing
        summary :: Summary
summary = Context -> Summary
summarise Context
ctx

    -- One finding for each list or array a function grows.
    site :: Growth -> (Text, AccessPath)
site Growth
g = (Growth -> Text
growIn Growth
g, case Growth -> AccessPath
growWhat Growth
g of
        PathField AccessPath
o String
_ -> AccessPath
o
        AccessPath
p             -> AccessPath
p)
    first :: Finding -> Finding -> Finding
first a :: Finding
a@(Finding Growth
g [Function]
_) b :: Finding
b@(Finding Growth
g' [Function]
_) = if Growth -> (Int, Int)
pos Growth
g' (Int, Int) -> (Int, Int) -> Bool
forall a. Ord a => a -> a -> Bool
<= Growth -> (Int, Int)
pos Growth
g then Finding
b else Finding
a
    pos :: Growth -> (Int, Int)
pos Growth
g = let L (C.AlexPn Int
_ Int
l Int
c) LexemeClass
_ Text
_ = Growth -> Lexeme Text
growAt Growth
g in (Int
l, Int
c)

    roots :: [Function]
roots = Pointers -> [Function] -> [Function]
receivers Pointers
ptrs [Function]
fns
    receiverNames :: Set Text
receiverNames = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ((Function -> Text) -> [Function] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Function -> Text
fnName [Function]
roots)
    -- The function each reached function was first reached from.
    reached :: Map Text (Maybe Text)
reached = Map Text (Maybe Text) -> [Text] -> Map Text (Maybe Text)
bfs ([(Text, Maybe Text)] -> Map Text (Maybe Text)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Function -> Text
fnName Function
r, Maybe Text
forall a. Maybe a
Nothing) | Function
r <- [Function]
roots ]) ((Function -> Text) -> [Function] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Function -> Text
fnName [Function]
roots)
    bfs :: Map Text (Maybe Text) -> [Text] -> Map Text (Maybe Text)
bfs Map Text (Maybe Text)
seen [] = Map Text (Maybe Text)
seen
    bfs Map Text (Maybe Text)
seen [Text]
frontier =
        let fresh :: Map Text (Maybe Text)
fresh = [(Text, Maybe Text)] -> Map Text (Maybe Text)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Text
c, Text -> Maybe Text
forall a. a -> Maybe a
Just Text
n) | Text
n <- [Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
frontier, Text
c <- [Text] -> [Text]
forall a. [a] -> [a]
reverse (Text -> [Text]
next Text
n), Bool -> Bool
not (Text
c Text -> Map Text (Maybe Text) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map Text (Maybe Text)
seen) ]
        in Map Text (Maybe Text) -> [Text] -> Map Text (Maybe Text)
bfs (Map Text (Maybe Text)
-> Map Text (Maybe Text) -> Map Text (Maybe Text)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Text (Maybe Text)
seen Map Text (Maybe Text)
fresh) (Map Text (Maybe Text) -> [Text]
forall k a. Map k a -> [k]
Map.keys Map Text (Maybe Text)
fresh)
    next :: Text -> [Text]
next Text
n = [Text] -> (Function -> [Text]) -> Maybe Function -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Pointers -> Function -> [Text]
calls Pointers
ptrs) (Text -> Map Text Function -> Maybe Function
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
n Map Text Function
byName)
    chain :: Text -> [Function]
chain Text
n = case Text -> Map Text (Maybe Text) -> Maybe (Maybe Text)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
n Map Text (Maybe Text)
reached of
        Just (Just Text
parent) -> Text -> [Function]
chain Text
parent [Function] -> [Function] -> [Function]
forall a. [a] -> [a] -> [a]
++ [Function]
-> (Function -> [Function]) -> Maybe Function -> [Function]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Function -> [Function]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Map Text Function -> Maybe Function
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
n Map Text Function
byName)
        Maybe (Maybe Text)
_                  -> [Function]
-> (Function -> [Function]) -> Maybe Function -> [Function]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Function -> [Function]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Map Text Function -> Maybe Function
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
n Map Text Function
byName)

analyse :: [(FilePath, [C.Node (Lexeme Text)])] -> [Diagnostic CimplePos]
analyse :: [(String, [Node (Lexeme Text)])] -> [Diagnostic CimplePos]
analyse [(String, [Node (Lexeme Text)])]
tus = [Diagnostic CimplePos] -> [Diagnostic CimplePos]
forall a. [a] -> [a]
reverse ([Diagnostic CimplePos] -> [Diagnostic CimplePos])
-> [Diagnostic CimplePos] -> [Diagnostic CimplePos]
forall a b. (a -> b) -> a -> b
$ (State [Diagnostic CimplePos] ()
 -> [Diagnostic CimplePos] -> [Diagnostic CimplePos])
-> [Diagnostic CimplePos]
-> State [Diagnostic CimplePos] ()
-> [Diagnostic CimplePos]
forall a b c. (a -> b -> c) -> b -> a -> c
flip State [Diagnostic CimplePos] ()
-> [Diagnostic CimplePos] -> [Diagnostic CimplePos]
forall s a. State s a -> s -> s
State.execState [] (State [Diagnostic CimplePos] () -> [Diagnostic CimplePos])
-> State [Diagnostic CimplePos] () -> [Diagnostic CimplePos]
forall a b. (a -> b) -> a -> b
$ [State [Diagnostic CimplePos] ()]
-> State [Diagnostic CimplePos] ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
    [ Diagnostic CimplePos -> State [Diagnostic CimplePos] ()
forall diags pos.
HasDiagnosticsRich diags pos =>
Diagnostic pos -> DiagnosticsT diags ()
warnRich (Diagnostic CimplePos -> State [Diagnostic CimplePos] ())
-> Diagnostic CimplePos -> State [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$ CimplePos
-> Int
-> DiagnosticLevel
-> Doc AnsiStyle
-> Maybe Text
-> [DiagnosticSpan CimplePos]
-> [(DiagnosticLevel, Doc AnsiStyle)]
-> Diagnostic CimplePos
forall pos.
pos
-> Int
-> DiagnosticLevel
-> Doc AnsiStyle
-> Maybe Text
-> [DiagnosticSpan pos]
-> [(DiagnosticLevel, Doc AnsiStyle)]
-> Diagnostic pos
Diagnostic CimplePos
pos Int
len DiagnosticLevel
ErrorLevel Doc AnsiStyle
forall {ann}. Doc ann
msg Maybe Text
forall a. Maybe a
Nothing (CimplePos -> Int -> [Doc AnsiStyle] -> DiagnosticSpan CimplePos
forall pos. pos -> Int -> [Doc AnsiStyle] -> DiagnosticSpan pos
DiagnosticSpan CimplePos
pos Int
len [Doc AnsiStyle
"grows here"] DiagnosticSpan CimplePos
-> [DiagnosticSpan CimplePos] -> [DiagnosticSpan CimplePos]
forall a. a -> [a] -> [a]
: [DiagnosticSpan CimplePos
entrySpan]) [(DiagnosticLevel
NoteLevel, Doc AnsiStyle
forall {ann}. Doc ann
path)]
    | Finding Growth
g route :: [Function]
route@(Function
entry : [Function]
_) <- [(String, [Node (Lexeme Text)])] -> [Finding]
findings [(String, [Node (Lexeme Text)])]
tus
    , let (CimplePos
pos, Int
len) = String -> Lexeme Text -> (CimplePos, Int)
forall at pos.
HasDiagnosticInfo at pos =>
String -> at -> (pos, Int)
getDiagnosticInfo (Growth -> String
growFile Growth
g) (Growth -> Lexeme Text
growAt Growth
g)
    , let (CimplePos
epos, Int
elen) = String -> Lexeme Text -> (CimplePos, Int)
forall at pos.
HasDiagnosticInfo at pos =>
String -> at -> (pos, Int)
getDiagnosticInfo (Function -> String
fnFile Function
entry) (Function -> Lexeme Text
entryLexeme Function
entry)
    , let entrySpan :: DiagnosticSpan CimplePos
entrySpan = CimplePos -> Int -> [Doc AnsiStyle] -> DiagnosticSpan CimplePos
forall pos. pos -> Int -> [Doc AnsiStyle] -> DiagnosticSpan pos
DiagnosticSpan CimplePos
epos Int
elen [Doc AnsiStyle
"packets come in here"]
    , let msg :: Doc ann
msg = Doc ann
"nothing limits how far" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
backticks (AccessPath -> Doc ann
forall ann. AccessPath -> Doc ann
render (Growth -> AccessPath
growWhat Growth
g)) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"grows; reached from" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
backticks (Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Function -> Text
fnName Function
entry))
    , let names :: [Text]
names = (Function -> Text) -> [Function] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Function -> Text
fnName [Function]
route [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Growth -> [Text]
growVia Growth
g
    , let path :: Doc ann
path = Doc ann
"through" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat (Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
List.intersperse Doc ann
" -> " ((Text -> Doc ann) -> [Text] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
backticks (Doc ann -> Doc ann) -> (Text -> Doc ann) -> Text -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty) [Text]
names))
    ]
  where
    entryLexeme :: Function -> Lexeme Text
entryLexeme Function
f = case Function -> Node (Lexeme Text)
fnDefn Function
f of
        Fix (FunctionDefn Scope
_ (Fix (FunctionPrototype Node (Lexeme Text)
_ Lexeme Text
l [Node (Lexeme Text)]
_)) Node (Lexeme Text)
_) -> Lexeme Text
l
        Node (Lexeme Text)
_ -> AlexPosn -> LexemeClass -> Text -> Lexeme Text
forall text. AlexPosn -> LexemeClass -> text -> Lexeme text
L (Int -> Int -> Int -> AlexPosn
C.AlexPn Int
0 Int
0 Int
0) LexemeClass
C.IdVar (Function -> Text
fnName Function
f)

descr :: ([(FilePath, [C.Node (Lexeme Text)])] -> [Diagnostic CimplePos], (Text, Text))
descr :: ([(String, [Node (Lexeme Text)])] -> [Diagnostic CimplePos],
 (Text, Text))
descr = ([(String, [Node (Lexeme Text)])] -> [Diagnostic CimplePos]
analyse, (Text
"unbounded-growth", [Text] -> Text
Text.unlines
    [ Text
"Checks that every list or array that peers can grow by sending packets"
    , Text
"has a limit. A limit is a check like `count >= MAX` that returns before"
    , Text
"the list grows, in the same function or a caller. Growing at most once for"
    , Text
"each entry of a limited array also counts, and so does moving an entry"
    , Text
"from another list."
    , Text
""
    , Text
"**Reason:** otherwise a peer can make us use more and more memory by"
    , Text
"sending packets."
    ]))