{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
-- | What functions allocate, free and store, followed through their bodies:
-- memory a function loses, and memory it frees while it is still stored.
module Tokstyle.Linter.MemoryLifetime (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.Set                           (Set)
import qualified Data.Set                           as Set
import           Data.Text                          (Text)
import qualified Data.Text                          as Text
import           Language.Cimple                    (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 (..),
                                                     isPathPrefixOf)
import           Tokstyle.Analysis.Dataflow         (Dataflow (..), solve,
                                                     solveBackward)
import           Tokstyle.Cimple.Analysis.CFG       (EdgeType (..), Node (..),
                                                     NodeKind (..),
                                                     fromFunction)
import           Tokstyle.Cimple.Analysis.Functions
import           Tokstyle.Common                    (backticks)


data Summary = Summary
    { Summary -> Map Text (Map Outcome (Set Int))
sumFrees   :: Map Text (Map Outcome (Set Int))
    -- ^ The arguments each function frees, by the outcome it reports.
    , Summary -> Set Text
sumFresh   :: Set Text
    -- ^ The functions that may return memory they allocated.
    , Summary -> Map Text Shape
sumShapes  :: Map Text Shape
    , Summary -> Set Text
sumKept    :: Set Text
    -- ^ The functions that may return memory they also stored somewhere.
    , Summary -> Map Text (Set Int)
sumUnlinks :: Map Text (Set Int)
    -- ^ The arguments each function may remove from where they are stored,
    -- by writing through a pointer other than the argument.
    , Summary -> Map Text (Map Outcome (Set Int))
sumKeeps   :: Map Text (Map Outcome (Set Int))
    -- ^ The arguments each function may store somewhere, by the outcome it
    -- reports.
    }

keptBy :: Summary -> Text -> [Outcome] -> [Int]
keptBy :: Summary -> Text -> [Outcome] -> [Int]
keptBy Summary
summary Text
g [Outcome]
outcomes = Set Int -> [Int]
forall a. Set a -> [a]
Set.toList (Set Int -> [Int]) -> ([Set Int] -> Set Int) -> [Set Int] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Set Int] -> Set Int
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set Int] -> [Int]) -> [Set Int] -> [Int]
forall a b. (a -> b) -> a -> b
$
    [ Set Int -> Outcome -> Map Outcome (Set Int) -> Set Int
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Set Int
forall a. Set a
Set.empty Outcome
o Map Outcome (Set Int)
byOutcome
    | Just Map Outcome (Set Int)
byOutcome <- [Text
-> Map Text (Map Outcome (Set Int))
-> Maybe (Map Outcome (Set Int))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
g (Summary -> Map Text (Map Outcome (Set Int))
sumKeeps Summary
summary)], Outcome
o <- [Outcome]
outcomes ]

freedBy :: Summary -> Text -> [Outcome] -> [Int]
freedBy :: Summary -> Text -> [Outcome] -> [Int]
freedBy Summary
summary Text
g [Outcome]
outcomes = case Text -> Map Text Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
g Map Text Int
freers of
    Just Int
i  -> [Int
i]
    Maybe Int
Nothing -> Set Int -> [Int]
forall a. Set a -> [a]
Set.toList (Set Int -> [Int]) -> ([Set Int] -> Set Int) -> [Set Int] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Set Int] -> Set Int
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set Int] -> [Int]) -> [Set Int] -> [Int]
forall a b. (a -> b) -> a -> b
$
        [ Set Int -> Outcome -> Map Outcome (Set Int) -> Set Int
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Set Int
forall a. Set a
Set.empty Outcome
o Map Outcome (Set Int)
byOutcome
        | Just Map Outcome (Set Int)
byOutcome <- [Text
-> Map Text (Map Outcome (Set Int))
-> Maybe (Map Outcome (Set Int))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
g (Summary -> Map Text (Map Outcome (Set Int))
sumFrees Summary
summary)], Outcome
o <- [Outcome]
outcomes ]

summarise :: [Function] -> Summary
summarise :: [Function] -> Summary
summarise [Function]
fns = Summary -> Summary
withUnlinks ((Function -> [Text])
-> (Summary -> Function -> Summary)
-> (Summary
    -> Function
    -> (Maybe (Map Outcome (Set Int)), Maybe (Map Outcome (Set Int)),
        Bool))
-> [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
-> (Maybe (Map Outcome (Set Int)), Maybe (Map Outcome (Set Int)),
    Bool)
look [Function]
fns (Map Text (Map Outcome (Set Int))
-> Set Text
-> Map Text Shape
-> Set Text
-> Map Text (Set Int)
-> Map Text (Map Outcome (Set Int))
-> Summary
Summary Map Text (Map Outcome (Set Int))
forall k a. Map k a
Map.empty Set Text
fresh Map Text Shape
shapes Set Text
forall a. Set a
Set.empty Map Text (Set Int)
forall k a. Map k a
Map.empty Map Text (Map Outcome (Set Int))
forall k a. Map k a
Map.empty))
  where
    withUnlinks :: Summary -> Summary
withUnlinks Summary
s0 = Summary
s0 { sumUnlinks = unlinksFix Map.empty }
    unlinksFix :: Map Text (Set a) -> Map Text (Set a)
unlinksFix Map Text (Set a)
u = let u' :: Map Text (Set a)
u' = (Map Text (Set a) -> Function -> Map Text (Set a))
-> Map Text (Set a) -> [Function] -> Map Text (Set a)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Map Text (Set a) -> Function -> Map Text (Set a)
forall {a}.
(Ord a, Num a, Enum a) =>
Map Text (Set a) -> Function -> Map Text (Set a)
unlinkStep Map Text (Set a)
u [Function]
fns in if Map Text (Set a)
u' Map Text (Set a) -> Map Text (Set a) -> Bool
forall a. Eq a => a -> a -> Bool
== Map Text (Set a)
u then Map Text (Set a)
u else Map Text (Set a) -> Map Text (Set a)
unlinksFix Map Text (Set a)
u'
    unlinkStep :: Map Text (Set a) -> Function -> Map Text (Set a)
unlinkStep Map Text (Set a)
u Function
fn = case [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList [ a
i | (a
i, Text
param) <- [a] -> [Text] -> [(a, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a
0 ..] (Function -> [Text]
fnParams Function
fn), Map Text (Set a) -> Function -> String -> Bool
forall {a}. Map Text a -> Function -> String -> Bool
unlinks Map Text (Set a)
u Function
fn (Text -> String
Text.unpack Text
param) ] of
        Set a
is | Set a -> Bool
forall a. Set a -> Bool
Set.null Set a
is -> Map Text (Set a)
u
           | Bool
otherwise   -> Text -> Set a -> Map Text (Set a) -> Map Text (Set a)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Function -> Text
fnName Function
fn) Set a
is Map Text (Set a)
u
    -- A write through a pointer not rooted at the argument, here or in a
    -- function that removes one of its own arguments.
    unlinks :: Map Text a -> Function -> String -> Bool
unlinks Map Text a
u Function
fn String
param = (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Map Text a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map Text a
u) (Function -> [Text]
callees Function
fn) Bool -> Bool -> Bool
|| [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
        [ Bool
True
        | Fix (AssignExpr Fix (NodeF (Lexeme Text))
l AssignOp
_ Fix (NodeF (Lexeme Text))
_) <- Fix (NodeF (Lexeme Text)) -> [Fix (NodeF (Lexeme Text))]
universe (Function -> Fix (NodeF (Lexeme Text))
fnDefn Function
fn), Just AccessPath
p <- [Fix (NodeF (Lexeme Text)) -> Maybe AccessPath
accessPath Fix (NodeF (Lexeme Text))
l], AccessPath -> Bool
throughPointer AccessPath
p
        , Just String
root <- [AccessPath -> Maybe String
rootOf AccessPath
p], String
root String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
param ]
    shapes :: Map Text Shape
shapes = [(Text, Shape)] -> Map Text Shape
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Function -> Text
fnName Function
f, Function -> Shape
fnShape Function
f) | Function
f <- [Function]
fns ]
    add :: Summary -> Function -> Summary
add Summary
s Function
f =
        let ([Finding]
_, Map Outcome (Set Int)
frees, Map Outcome (Set Int)
keepsArgs, Bool
keepsResult) = Summary
-> Function
-> ([Finding], Map Outcome (Set Int), Map Outcome (Set Int), Bool)
analyseFunction Summary
s Function
f
        in Summary
s { sumFrees = insertNonEmpty (fnName f) frees (sumFrees s)
             , sumKeeps = insertNonEmpty (fnName f) keepsArgs (sumKeeps s)
             , sumKept = if keepsResult then Set.insert (fnName f) (sumKept s) else sumKept s }
    insertNonEmpty :: k -> Map k a -> Map k (Map k a) -> Map k (Map k a)
insertNonEmpty k
k Map k a
v Map k (Map k a)
m
        | Map k a -> Bool
forall k a. Map k a -> Bool
Map.null Map k a
v = Map k (Map k a)
m
        | Bool
otherwise  = k -> Map k a -> Map k (Map k a) -> Map k (Map k a)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
k Map k a
v Map k (Map k a)
m
    look :: Summary
-> Function
-> (Maybe (Map Outcome (Set Int)), Maybe (Map Outcome (Set Int)),
    Bool)
look Summary
s Function
f = (Text
-> Map Text (Map Outcome (Set Int))
-> Maybe (Map Outcome (Set Int))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Function -> Text
fnName Function
f) (Summary -> Map Text (Map Outcome (Set Int))
sumFrees Summary
s), Text
-> Map Text (Map Outcome (Set Int))
-> Maybe (Map Outcome (Set Int))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Function -> Text
fnName Function
f) (Summary -> Map Text (Map Outcome (Set Int))
sumKeeps Summary
s), Function -> Text
fnName Function
f Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Summary -> Set Text
sumKept Summary
s)

    fresh :: Set Text
fresh = Set Text -> Set Text
fixpoint (Map Text Int -> Set Text
forall k a. Map k a -> Set k
Map.keysSet Map Text Int
allocators)
    fixpoint :: Set Text -> Set Text
fixpoint Set Text
s = let s' :: Set Text
s' = (Set Text -> Function -> Set Text)
-> Set Text -> [Function] -> Set Text
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Set Text -> Function -> Set Text
freshStep Set Text
s [Function]
fns in if Set Text
s' Set Text -> Set Text -> Bool
forall a. Eq a => a -> a -> Bool
== Set Text
s then Set Text
s else Set Text -> Set Text
fixpoint Set Text
s'
    freshStep :: Set Text -> Function -> Set Text
freshStep Set Text
s Function
fn
        | (Fix (NodeF (Lexeme Text)) -> Bool)
-> [Fix (NodeF (Lexeme Text))] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Set Text -> Fix (NodeF (Lexeme Text)) -> Bool
callsOneOf Set Text
s) (Function -> [Fix (NodeF (Lexeme Text))]
returned Function
fn) = Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
Set.insert (Function -> Text
fnName Function
fn) Set Text
s
        | Bool
otherwise = Set Text
s
    returned :: Function -> [Fix (NodeF (Lexeme Text))]
returned Function
fn = [[Fix (NodeF (Lexeme Text))]] -> [Fix (NodeF (Lexeme Text))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ case Fix (NodeF (Lexeme Text)) -> Fix (NodeF (Lexeme Text))
bare Fix (NodeF (Lexeme Text))
e of
            Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
v)) -> Function -> String -> [Fix (NodeF (Lexeme Text))]
givenTo Function
fn (Text -> String
Text.unpack Text
v)
            Fix (NodeF (Lexeme Text))
e'                      -> [Fix (NodeF (Lexeme Text))
e']
        | Fix (Return (Just Fix (NodeF (Lexeme Text))
e)) <- Fix (NodeF (Lexeme Text)) -> [Fix (NodeF (Lexeme Text))]
universe (Function -> Fix (NodeF (Lexeme Text))
fnDefn Function
fn) ]
    -- A local the function also stores somewhere holds memory that is not
    -- the caller's alone.
    givenTo :: Function -> String -> [Fix (NodeF (Lexeme Text))]
givenTo Function
fn String
v
        | String
v String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Function -> [String]
stored Function
fn = []
        | Bool
otherwise = [ Fix (NodeF (Lexeme Text))
r | (String
v', Just Fix (NodeF (Lexeme Text))
r) <- Fix (NodeF (Lexeme Text))
-> [(String, Maybe (Fix (NodeF (Lexeme Text))))]
localDecls (Function -> Fix (NodeF (Lexeme Text))
fnDefn Function
fn), String
v' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
v ]
            [Fix (NodeF (Lexeme Text))]
-> [Fix (NodeF (Lexeme Text))] -> [Fix (NodeF (Lexeme Text))]
forall a. [a] -> [a] -> [a]
++ [Fix (NodeF (Lexeme Text))]
-> String
-> Map String [Fix (NodeF (Lexeme Text))]
-> [Fix (NodeF (Lexeme Text))]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] String
v (Fix (NodeF (Lexeme Text)) -> Map String [Fix (NodeF (Lexeme Text))]
assignments (Function -> Fix (NodeF (Lexeme Text))
fnDefn Function
fn))
    stored :: Function -> [String]
stored Function
fn = [ String
v | Fix (AssignExpr Fix (NodeF (Lexeme Text))
l AssignOp
_ Fix (NodeF (Lexeme Text))
r) <- Fix (NodeF (Lexeme Text)) -> [Fix (NodeF (Lexeme Text))]
universe (Function -> Fix (NodeF (Lexeme Text))
fnDefn Function
fn), Bool -> Bool
not (Fix (NodeF (Lexeme Text)) -> Bool
forall {lexeme}. Fix (NodeF lexeme) -> Bool
isVar Fix (NodeF (Lexeme Text))
l), String
v <- Fix (NodeF (Lexeme Text)) -> [String]
passed Fix (NodeF (Lexeme Text))
r ]
    isVar :: Fix (NodeF lexeme) -> Bool
isVar = \case
        Fix (VarExpr{}) -> Bool
True
        Fix (NodeF lexeme)
_               -> Bool
False

callsOneOf :: Set Text -> C.Node (Lexeme Text) -> Bool
callsOneOf :: Set Text -> Fix (NodeF (Lexeme Text)) -> Bool
callsOneOf Set Text
fns Fix (NodeF (Lexeme Text))
e = case Fix (NodeF (Lexeme Text)) -> Fix (NodeF (Lexeme Text))
bare Fix (NodeF (Lexeme Text))
e of
    Fix (FunctionCall Fix (NodeF (Lexeme Text))
callee [Fix (NodeF (Lexeme Text))]
_) | L AlexPosn
_ LexemeClass
_ Text
g <- Fix (NodeF (Lexeme Text)) -> Lexeme Text
calleeLexeme Fix (NodeF (Lexeme Text))
callee -> Text
g Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
fns
    Fix (NodeF (Lexeme Text))
_                                                            -> Bool
False

data Facts = Facts
    { Facts -> Set AccessPath
freed      :: Set AccessPath
    , Facts -> Map AccessPath (Lexeme Text)
owned      :: Map AccessPath (Lexeme Text)
    -- ^ Fields the function allocated that may still hold that memory, and
    -- where it allocated it.
    , Facts -> Map String (Lexeme Text)
held       :: Map String (Lexeme Text)
    -- ^ Locals that may hold memory the function must free, and where they
    -- got it.
    , Facts -> Map String (Lexeme Text)
shared     :: Map String (Lexeme Text)
    -- ^ Locals that may hold memory a call also stored, and that call.
    , Facts -> Set String
keptParams :: Set String
    -- ^ Parameters the function may have stored somewhere lasting.
    , Facts -> Set String
keptLocals :: Set String
    -- ^ Locals the function may have stored somewhere lasting itself.
    } deriving (Facts -> Facts -> Bool
(Facts -> Facts -> Bool) -> (Facts -> Facts -> Bool) -> Eq Facts
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Facts -> Facts -> Bool
== :: Facts -> Facts -> Bool
$c/= :: Facts -> Facts -> Bool
/= :: Facts -> Facts -> Bool
Eq)

joinFacts :: Facts -> Facts -> Facts
joinFacts :: Facts -> Facts -> Facts
joinFacts (Facts Set AccessPath
a Map AccessPath (Lexeme Text)
b Map String (Lexeme Text)
c Map String (Lexeme Text)
d Set String
e Set String
f) (Facts Set AccessPath
g Map AccessPath (Lexeme Text)
h Map String (Lexeme Text)
i Map String (Lexeme Text)
j Set String
k Set String
l) =
    Set AccessPath
-> Map AccessPath (Lexeme Text)
-> Map String (Lexeme Text)
-> Map String (Lexeme Text)
-> Set String
-> Set String
-> Facts
Facts (Set AccessPath -> Set AccessPath -> Set AccessPath
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set AccessPath
a Set AccessPath
g) (Map AccessPath (Lexeme Text)
-> Map AccessPath (Lexeme Text) -> Map AccessPath (Lexeme Text)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map AccessPath (Lexeme Text)
b Map AccessPath (Lexeme Text)
h) (Map String (Lexeme Text)
-> Map String (Lexeme Text) -> Map String (Lexeme Text)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map String (Lexeme Text)
c Map String (Lexeme Text)
i) (Map String (Lexeme Text)
-> Map String (Lexeme Text) -> Map String (Lexeme Text)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map String (Lexeme Text)
d Map String (Lexeme Text)
j) (Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set String
e Set String
k) (Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set String
f Set String
l)

data Finding
    = LeakedField (Lexeme Text) AccessPath AccessPath (Lexeme Text)
    -- ^ A free, what it frees, a field of that still holding memory, and
    -- where it got it.
    | LeakedLocal (Lexeme Text) String (Maybe (Lexeme Text))
    -- ^ Where a local got memory, the local, and the return that leaves it
    -- unfreed, if it has an expression.
    | FreedWhileStored (Lexeme Text) String (Lexeme Text)
    -- ^ A free, the local it frees, and the call that gave it memory it also
    -- stored.
    deriving (Finding -> Finding -> Bool
(Finding -> Finding -> Bool)
-> (Finding -> Finding -> Bool) -> Eq Finding
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Finding -> Finding -> Bool
== :: Finding -> Finding -> Bool
$c/= :: Finding -> Finding -> Bool
/= :: Finding -> Finding -> Bool
Eq, Eq Finding
Eq Finding =>
(Finding -> Finding -> Ordering)
-> (Finding -> Finding -> Bool)
-> (Finding -> Finding -> Bool)
-> (Finding -> Finding -> Bool)
-> (Finding -> Finding -> Bool)
-> (Finding -> Finding -> Finding)
-> (Finding -> Finding -> Finding)
-> Ord Finding
Finding -> Finding -> Bool
Finding -> Finding -> Ordering
Finding -> Finding -> Finding
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 :: Finding -> Finding -> Ordering
compare :: Finding -> Finding -> Ordering
$c< :: Finding -> Finding -> Bool
< :: Finding -> Finding -> Bool
$c<= :: Finding -> Finding -> Bool
<= :: Finding -> Finding -> Bool
$c> :: Finding -> Finding -> Bool
> :: Finding -> Finding -> Bool
$c>= :: Finding -> Finding -> Bool
>= :: Finding -> Finding -> Bool
$cmax :: Finding -> Finding -> Finding
max :: Finding -> Finding -> Finding
$cmin :: Finding -> Finding -> Finding
min :: Finding -> Finding -> Finding
Ord)

-- | Forget what is known about a path and everything under it, and for a
-- variable, the elements it indexes.
forget :: AccessPath -> Facts -> Facts
forget :: AccessPath -> Facts -> Facts
forget AccessPath
p (Facts Set AccessPath
f Map AccessPath (Lexeme Text)
o Map String (Lexeme Text)
h Map String (Lexeme Text)
s Set String
ps Set String
ls) = Set AccessPath
-> Map AccessPath (Lexeme Text)
-> Map String (Lexeme Text)
-> Map String (Lexeme Text)
-> Set String
-> Set String
-> Facts
Facts ((AccessPath -> Bool) -> Set AccessPath -> Set AccessPath
forall a. (a -> Bool) -> Set a -> Set a
Set.filter AccessPath -> Bool
keep Set AccessPath
f) ((AccessPath -> Lexeme Text -> Bool)
-> Map AccessPath (Lexeme Text) -> Map AccessPath (Lexeme Text)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (Bool -> Lexeme Text -> Bool
forall a b. a -> b -> a
const (Bool -> Lexeme Text -> Bool)
-> (AccessPath -> Bool) -> AccessPath -> Lexeme Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AccessPath -> Bool
keep) Map AccessPath (Lexeme Text)
o) (Map String (Lexeme Text) -> Map String (Lexeme Text)
forall {a}. Map String a -> Map String a
dropV Map String (Lexeme Text)
h) (Map String (Lexeme Text) -> Map String (Lexeme Text)
forall {a}. Map String a -> Map String a
dropV Map String (Lexeme Text)
s) Set String
ps Set String
ls'
  where
    dropV :: Map String a -> Map String a
dropV Map String a
m = case AccessPath
p of
        PathVar String
v -> String -> Map String a -> Map String a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete String
v Map String a
m
        AccessPath
_         -> Map String a
m
    ls' :: Set String
ls' = case AccessPath
p of
        PathVar String
v -> String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.delete String
v Set String
ls
        AccessPath
_         -> Set String
ls
    keep :: AccessPath -> Bool
keep AccessPath
k = Bool -> Bool
not (AccessPath
p AccessPath -> AccessPath -> Bool
`isPathPrefixOf` AccessPath
k) Bool -> Bool -> Bool
&& Bool -> Bool
not (AccessPath -> Bool
indexedBy AccessPath
k)
    indexedBy :: AccessPath -> Bool
indexedBy AccessPath
k = case AccessPath
p of
        PathVar String
v -> (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (String -> Text
Text.pack String
v) ([Text] -> Bool) -> (String -> [Text]) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
Text.split (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isIdent) (Text -> [Text]) -> (String -> Text) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack) (AccessPath -> [String]
indices AccessPath
k)
        AccessPath
_         -> Bool
False
    isIdent :: Char -> Bool
isIdent Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'a'..Char
'z'] Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'A'..Char
'Z'] Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'0'..Char
'9']
    indices :: AccessPath -> [String]
indices = \case
        PathIndex AccessPath
q String
i -> String
i String -> [String] -> [String]
forall a. a -> [a] -> [a]
: AccessPath -> [String]
indices AccessPath
q
        PathField AccessPath
q String
_ -> AccessPath -> [String]
indices AccessPath
q
        PathDeref AccessPath
q   -> AccessPath -> [String]
indices AccessPath
q
        AccessPath
_             -> []

-- | The locals an expression's value is, or points into.
passed :: C.Node (Lexeme Text) -> [String]
passed :: Fix (NodeF (Lexeme Text)) -> [String]
passed Fix (NodeF (Lexeme Text))
e = case Fix (NodeF (Lexeme Text)) -> Fix (NodeF (Lexeme Text))
bare Fix (NodeF (Lexeme Text))
e of
    Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
v)) -> [Text -> String
Text.unpack Text
v]
    Fix (BinaryExpr Fix (NodeF (Lexeme Text))
l BinaryOp
op Fix (NodeF (Lexeme Text))
r) | 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
BopPlus, BinaryOp
BopMinus] -> Fix (NodeF (Lexeme Text)) -> [String]
passed Fix (NodeF (Lexeme Text))
l [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Fix (NodeF (Lexeme Text)) -> [String]
passed Fix (NodeF (Lexeme Text))
r
    Fix (TernaryExpr Fix (NodeF (Lexeme Text))
_ Fix (NodeF (Lexeme Text))
a Fix (NodeF (Lexeme Text))
b) -> Fix (NodeF (Lexeme Text)) -> [String]
passed Fix (NodeF (Lexeme Text))
a [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Fix (NodeF (Lexeme Text)) -> [String]
passed Fix (NodeF (Lexeme Text))
b
    Fix (NodeF (Lexeme Text))
_ -> []

-- | Whether a call fills a variable through its address, as a status the
-- caller must check before it trusts the result.
fillsLocal :: C.Node (Lexeme Text) -> Bool
fillsLocal :: Fix (NodeF (Lexeme Text)) -> Bool
fillsLocal Fix (NodeF (Lexeme Text))
e = case Fix (NodeF (Lexeme Text)) -> Fix (NodeF (Lexeme Text))
bare Fix (NodeF (Lexeme Text))
e of
    Fix (FunctionCall Fix (NodeF (Lexeme Text))
_ [Fix (NodeF (Lexeme Text))]
args) -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Bool
True | Fix (NodeF (Lexeme Text))
a <- [Fix (NodeF (Lexeme Text))]
args, Fix (UnaryExpr UnaryOp
UopAddress (Fix VarExpr{})) <- [Fix (NodeF (Lexeme Text)) -> Fix (NodeF (Lexeme Text))
bare Fix (NodeF (Lexeme Text))
a] ]
    Fix (NodeF (Lexeme Text))
_                         -> Bool
False

-- | Hand memory in these locals on, unless the function frees them later
-- anyway, which shows it still owns them.
handOff :: Set String -> [String] -> Facts -> Facts
handOff :: Set String -> [String] -> Facts -> Facts
handOff Set String
later [String]
vs Facts
facts = Facts
facts { held = List.foldl' drop' (held facts) vs }
  where
    drop' :: Map String a -> String -> Map String a
drop' Map String a
h String
v
        | String
v String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
later = Map String a
h
        | Bool
otherwise = String -> Map String a -> Map String a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete String
v Map String a
h

data Env = Env
    { Env -> Set String
envLocals   :: Set String
    , Env -> Set String
envParams   :: Set String
    , Env -> Set String
envPointers :: Set String
    , Env -> Map String [String]
envContains :: Map String [String]
    -- ^ For a local struct, the variables whose memory its fields hold.
    }

-- | How an expression changes the facts, given the call outcomes known on
-- this path and the locals the function may free after it.
evalExpr :: Summary -> [(Lexeme Text, Outcome)] -> Env -> Set String -> C.Node (Lexeme Text) -> (Facts, [Finding]) -> (Facts, [Finding])
evalExpr :: Summary
-> [(Lexeme Text, Outcome)]
-> Env
-> Set String
-> Fix (NodeF (Lexeme Text))
-> (Facts, [Finding])
-> (Facts, [Finding])
evalExpr Summary
summary [(Lexeme Text, Outcome)]
known Env
env Set String
later = Fix (NodeF (Lexeme Text))
-> (Facts, [Finding]) -> (Facts, [Finding])
go
  where
    locals :: Set String
locals = Env -> Set String
envLocals Env
env
    params :: Set String
params = Env -> Set String
envParams Env
env
    go :: Fix (NodeF (Lexeme Text))
-> (Facts, [Finding]) -> (Facts, [Finding])
go (Fix NodeF (Lexeme Text) (Fix (NodeF (Lexeme Text)))
node) (Facts, [Finding])
acc = case NodeF (Lexeme Text) (Fix (NodeF (Lexeme Text)))
node of
        AssignExpr Fix (NodeF (Lexeme Text))
l AssignOp
_ Fix (NodeF (Lexeme Text))
r ->
            let (Facts
facts, [Finding]
found) = Fix (NodeF (Lexeme Text))
-> (Facts, [Finding]) -> (Facts, [Finding])
go Fix (NodeF (Lexeme Text))
r (Facts, [Finding])
acc
                kept :: [String]
kept = if Fix (NodeF (Lexeme Text)) -> Bool
lasting Fix (NodeF (Lexeme Text))
l then Fix (NodeF (Lexeme Text)) -> [String]
contents Fix (NodeF (Lexeme Text))
r else []
                facts' :: Facts
facts' = [String] -> Facts -> Facts
keepVars [String]
kept (Set String -> [String] -> Facts -> Facts
handOff Set String
later (Fix (NodeF (Lexeme Text)) -> [String]
passed Fix (NodeF (Lexeme Text))
r) Facts
facts)
            in (Facts -> (AccessPath -> Facts) -> Maybe AccessPath -> Facts
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Facts
facts' (\AccessPath
p -> AccessPath -> Fix (NodeF (Lexeme Text)) -> Facts -> Facts
assign AccessPath
p Fix (NodeF (Lexeme Text))
r Facts
facts') (Fix (NodeF (Lexeme Text)) -> Maybe AccessPath
accessPath Fix (NodeF (Lexeme Text))
l), [Finding]
found)
        UnaryExpr UnaryOp
op Fix (NodeF (Lexeme Text))
x | UnaryOp
op UnaryOp -> [UnaryOp] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UnaryOp
UopIncr, UnaryOp
UopDecr], Just AccessPath
p <- Fix (NodeF (Lexeme Text)) -> Maybe AccessPath
accessPath Fix (NodeF (Lexeme Text))
x ->
            let (Facts
facts, [Finding]
found) = Fix (NodeF (Lexeme Text))
-> (Facts, [Finding]) -> (Facts, [Finding])
go Fix (NodeF (Lexeme Text))
x (Facts, [Finding])
acc in (AccessPath -> Facts -> Facts
forget AccessPath
p Facts
facts, [Finding]
found)
        -- What has its address taken may be changed through it.
        UnaryExpr UnaryOp
UopAddress Fix (NodeF (Lexeme Text))
x | Just AccessPath
p <- Fix (NodeF (Lexeme Text)) -> Maybe AccessPath
accessPath Fix (NodeF (Lexeme Text))
x ->
            let (Facts
facts, [Finding]
found) = Fix (NodeF (Lexeme Text))
-> (Facts, [Finding]) -> (Facts, [Finding])
go Fix (NodeF (Lexeme Text))
x (Facts, [Finding])
acc in (AccessPath -> Facts -> Facts
forget AccessPath
p Facts
facts, [Finding]
found)
        FunctionCall Fix (NodeF (Lexeme Text))
callee [Fix (NodeF (Lexeme Text))]
args ->
            Fix (NodeF (Lexeme Text))
-> [Fix (NodeF (Lexeme Text))]
-> (Facts, [Finding])
-> (Facts, [Finding])
call Fix (NodeF (Lexeme Text))
callee [Fix (NodeF (Lexeme Text))]
args (((Facts, [Finding])
 -> Fix (NodeF (Lexeme Text)) -> (Facts, [Finding]))
-> (Facts, [Finding])
-> [Fix (NodeF (Lexeme Text))]
-> (Facts, [Finding])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ((Fix (NodeF (Lexeme Text))
 -> (Facts, [Finding]) -> (Facts, [Finding]))
-> (Facts, [Finding])
-> Fix (NodeF (Lexeme Text))
-> (Facts, [Finding])
forall a b c. (a -> b -> c) -> b -> a -> c
flip Fix (NodeF (Lexeme Text))
-> (Facts, [Finding]) -> (Facts, [Finding])
go) (Facts, [Finding])
acc [Fix (NodeF (Lexeme Text))]
args)
        NodeF (Lexeme Text) (Fix (NodeF (Lexeme Text)))
_ -> ((Facts, [Finding])
 -> Fix (NodeF (Lexeme Text)) -> (Facts, [Finding]))
-> (Facts, [Finding])
-> [Fix (NodeF (Lexeme Text))]
-> (Facts, [Finding])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ((Fix (NodeF (Lexeme Text))
 -> (Facts, [Finding]) -> (Facts, [Finding]))
-> (Facts, [Finding])
-> Fix (NodeF (Lexeme Text))
-> (Facts, [Finding])
forall a b c. (a -> b -> c) -> b -> a -> c
flip Fix (NodeF (Lexeme Text))
-> (Facts, [Finding]) -> (Facts, [Finding])
go) (Facts, [Finding])
acc ((Fix (NodeF (Lexeme Text))
 -> [Fix (NodeF (Lexeme Text))] -> [Fix (NodeF (Lexeme Text))])
-> [Fix (NodeF (Lexeme Text))]
-> NodeF (Lexeme Text) (Fix (NodeF (Lexeme Text)))
-> [Fix (NodeF (Lexeme Text))]
forall a b. (a -> b -> b) -> b -> NodeF (Lexeme Text) a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (:) [] NodeF (Lexeme Text) (Fix (NodeF (Lexeme Text)))
node)

    assign :: AccessPath -> Fix (NodeF (Lexeme Text)) -> Facts -> Facts
assign AccessPath
p Fix (NodeF (Lexeme Text))
r Facts
facts =
        let facts' :: Facts
facts' = AccessPath -> Facts -> Facts
forget AccessPath
p Facts
facts
            -- Memory stored somewhere else belongs to that place now.
            moved :: Facts
moved = case Fix (NodeF (Lexeme Text)) -> Maybe AccessPath
accessPath (Fix (NodeF (Lexeme Text)) -> Fix (NodeF (Lexeme Text))
bare Fix (NodeF (Lexeme Text))
r) of
                Just AccessPath
q  -> Facts
facts' { owned = Map.delete q (owned facts') }
                Maybe AccessPath
Nothing -> Facts
facts'
        in case (Fix (NodeF (Lexeme Text)) -> Fix (NodeF (Lexeme Text))
bare Fix (NodeF (Lexeme Text))
r, AccessPath
p) of
            (Fix (FunctionCall Fix (NodeF (Lexeme Text))
callee [Fix (NodeF (Lexeme Text))]
_), AccessPath
_) | Set Text -> Fix (NodeF (Lexeme Text)) -> Bool
callsOneOf (Summary -> Set Text
sumFresh Summary
summary) Fix (NodeF (Lexeme Text))
r, AccessPath -> Bool
isField AccessPath
p ->
                Facts
moved { owned = Map.insert p (calleeLexeme callee) (owned moved) }
            (Fix (FunctionCall Fix (NodeF (Lexeme Text))
callee [Fix (NodeF (Lexeme Text))]
_), PathVar String
v) | Set Text -> Fix (NodeF (Lexeme Text)) -> Bool
callsOneOf (Summary -> Set Text
sumFresh Summary
summary) Fix (NodeF (Lexeme Text))
r, String
v String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
locals, Bool -> Bool
not (Fix (NodeF (Lexeme Text)) -> Bool
fillsLocal Fix (NodeF (Lexeme Text))
r) ->
                Facts
moved { held = Map.insert v (calleeLexeme callee) (held moved) }
            (Fix (FunctionCall Fix (NodeF (Lexeme Text))
callee [Fix (NodeF (Lexeme Text))]
_), PathVar String
v) | Set Text -> Fix (NodeF (Lexeme Text)) -> Bool
callsOneOf (Summary -> Set Text
sumKept Summary
summary) Fix (NodeF (Lexeme Text))
r, String
v String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
locals ->
                Facts
moved { shared = Map.insert v (calleeLexeme callee) (shared moved) }
            (Fix (NodeF (Lexeme Text)), AccessPath)
_ -> Facts
moved
    keepVars :: [String] -> Facts -> Facts
keepVars [String]
vs Facts
facts = Facts
facts
        { keptParams = Set.union (keptParams facts) (Set.fromList (filter (`Set.member` params) vs))
        , keptLocals = Set.union (keptLocals facts) (Set.fromList (filter (`Set.member` locals) vs))
        }
    -- A place that outlives the function: through a pointer, or not a local.
    lasting :: Fix (NodeF (Lexeme Text)) -> Bool
lasting Fix (NodeF (Lexeme Text))
l = case Fix (NodeF (Lexeme Text)) -> Maybe AccessPath
accessPath Fix (NodeF (Lexeme Text))
l of
        Just AccessPath
p  -> AccessPath -> Bool
throughPointer AccessPath
p Bool -> Bool -> Bool
|| Bool -> (String -> Bool) -> Maybe String -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set String
locals) (AccessPath -> Maybe String
rootOf AccessPath
p)
        Maybe AccessPath
Nothing -> Bool
True
    -- An argument a call can store into that outlives the function, other
    -- than memory under the kept variable itself.
    lastingFor :: String -> Fix (NodeF (Lexeme Text)) -> Bool
lastingFor String
v Fix (NodeF (Lexeme Text))
b = case Fix (NodeF (Lexeme Text)) -> Fix (NodeF (Lexeme Text))
bare Fix (NodeF (Lexeme Text))
b of
        Fix (UnaryExpr UnaryOp
UopAddress Fix (NodeF (Lexeme Text))
x) -> case Fix (NodeF (Lexeme Text)) -> Maybe AccessPath
accessPath Fix (NodeF (Lexeme Text))
x Maybe AccessPath -> (AccessPath -> 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
>>= AccessPath -> Maybe String
rootOf of
            Just String
root -> String
root String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set String
locals Bool -> Bool -> Bool
&& String
root String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
v
            Maybe String
Nothing   -> Bool
False
        Fix (NodeF (Lexeme Text))
_ -> case Fix (NodeF (Lexeme Text)) -> Maybe AccessPath
accessPath Fix (NodeF (Lexeme Text))
b Maybe AccessPath -> (AccessPath -> 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
>>= AccessPath -> Maybe String
rootOf of
            Just String
root -> String
root String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
v Bool -> Bool -> Bool
&& String
root String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Env -> Set String
envPointers Env
env
            Maybe String
Nothing   -> Bool
False
    -- The variables an argument hands a call, with what a local struct
    -- passed by address holds.
    expand :: Fix (NodeF (Lexeme Text)) -> [String]
expand Fix (NodeF (Lexeme Text))
a = Fix (NodeF (Lexeme Text)) -> [String]
passed Fix (NodeF (Lexeme Text))
a [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ case Fix (NodeF (Lexeme Text)) -> Fix (NodeF (Lexeme Text))
bare Fix (NodeF (Lexeme Text))
a of
        Fix (UnaryExpr UnaryOp
UopAddress Fix (NodeF (Lexeme Text))
x) | Just (PathVar String
l) <- Fix (NodeF (Lexeme Text)) -> Maybe AccessPath
accessPath Fix (NodeF (Lexeme Text))
x -> [String] -> String -> Map String [String] -> [String]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] String
l (Env -> Map String [String]
envContains Env
env)
        Fix (NodeF (Lexeme Text))
_ -> []
    -- The variables whose memory an expression's value points into or copies.
    contents :: Fix (NodeF (Lexeme Text)) -> [String]
contents Fix (NodeF (Lexeme Text))
r = Fix (NodeF (Lexeme Text)) -> [String]
passed Fix (NodeF (Lexeme Text))
r [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ case Fix (NodeF (Lexeme Text)) -> Fix (NodeF (Lexeme Text))
bare Fix (NodeF (Lexeme Text))
r of
        Fix (UnaryExpr UnaryOp
UopDeref Fix (NodeF (Lexeme Text))
x) -> Fix (NodeF (Lexeme Text)) -> [String]
passed Fix (NodeF (Lexeme Text))
x
        Fix (NodeF (Lexeme Text))
_                          -> []
    isField :: AccessPath -> Bool
isField = \case
        PathField AccessPath
q String
_ -> AccessPath -> Bool
throughPointer AccessPath
q Bool -> Bool -> Bool
|| AccessPath -> Bool
isDeref AccessPath
q
        AccessPath
_             -> Bool
False
    isDeref :: AccessPath -> Bool
isDeref = \case
        PathDeref{} -> Bool
True
        AccessPath
_           -> Bool
False

    call :: Fix (NodeF (Lexeme Text))
-> [Fix (NodeF (Lexeme Text))]
-> (Facts, [Finding])
-> (Facts, [Finding])
call Fix (NodeF (Lexeme Text))
callee [Fix (NodeF (Lexeme Text))]
args (Facts
facts, [Finding]
found) =
        let here :: Lexeme Text
here@(L AlexPosn
_ LexemeClass
_ Text
g) = Fix (NodeF (Lexeme Text)) -> Lexeme Text
calleeLexeme Fix (NodeF (Lexeme Text))
callee
            outcomes :: [Outcome]
outcomes = case Lexeme Text -> [(Lexeme Text, Outcome)] -> Maybe Outcome
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Lexeme Text
here [(Lexeme Text, Outcome)]
known of
                Just Outcome
o  -> [Outcome
o]
                Maybe Outcome
Nothing -> [Outcome
forall a. Bounded a => a
minBound .. Outcome
forall a. Bounded a => a
maxBound]
            freedArgs :: [AccessPath]
freedArgs = [ AccessPath
p | Int
i <- Summary -> Text -> [Outcome] -> [Int]
freedBy Summary
summary Text
g [Outcome]
outcomes, (Fix (NodeF (Lexeme Text))
a : [Fix (NodeF (Lexeme Text))]
_) <- [Int -> [Fix (NodeF (Lexeme Text))] -> [Fix (NodeF (Lexeme Text))]
forall a. Int -> [a] -> [a]
drop Int
i [Fix (NodeF (Lexeme Text))]
args], Just AccessPath
p <- [Fix (NodeF (Lexeme Text)) -> Maybe AccessPath
accessPath Fix (NodeF (Lexeme Text))
a] ]
            unlinksOf :: [Int]
unlinksOf = Set Int -> [Int]
forall a. Set a -> [a]
Set.toList (Set Int -> Text -> Map Text (Set Int) -> Set Int
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Set Int
forall a. Set a
Set.empty Text
g (Summary -> Map Text (Set Int)
sumUnlinks Summary
summary))
            unlinkedArgs :: [AccessPath]
unlinkedArgs = [ AccessPath
p | Int
i <- [Int]
unlinksOf, (Fix (NodeF (Lexeme Text))
a : [Fix (NodeF (Lexeme Text))]
_) <- [Int -> [Fix (NodeF (Lexeme Text))] -> [Fix (NodeF (Lexeme Text))]
forall a. Int -> [a] -> [a]
drop Int
i [Fix (NodeF (Lexeme Text))]
args], Just AccessPath
p <- [Fix (NodeF (Lexeme Text)) -> Maybe AccessPath
accessPath Fix (NodeF (Lexeme Text))
a] ]
            free :: (Facts, [Finding]) -> AccessPath -> (Facts, [Finding])
free (Facts
fs, [Finding]
found') AccessPath
p =
                let -- Only a function that frees no more than the memory it
                    -- is given leaves the fields of that memory behind.
                    leaks :: [Finding]
leaks = [ Lexeme Text -> AccessPath -> AccessPath -> Lexeme Text -> Finding
LeakedField Lexeme Text
here AccessPath
p AccessPath
q Lexeme Text
at
                            | Text
g Text -> Map Text Int -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map Text Int
freers
                            , (AccessPath
q, Lexeme Text
at) <- Map AccessPath (Lexeme Text) -> [(AccessPath, Lexeme Text)]
forall k a. Map k a -> [(k, a)]
Map.toList (Facts -> Map AccessPath (Lexeme Text)
owned Facts
fs), AccessPath
q AccessPath -> AccessPath -> Bool
forall a. Eq a => a -> a -> Bool
/= AccessPath
p, AccessPath
p AccessPath -> AccessPath -> Bool
`isPathPrefixOf` AccessPath
q ]
                    stillStored :: [Finding]
stillStored = [ Lexeme Text -> String -> Lexeme Text -> Finding
FreedWhileStored Lexeme Text
here String
v Lexeme Text
at
                                  | AccessPath
p AccessPath -> [AccessPath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [AccessPath]
unlinkedArgs
                                  , PathVar String
v <- [AccessPath
p], Just Lexeme Text
at <- [String -> Map String (Lexeme Text) -> Maybe (Lexeme Text)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
v (Facts -> Map String (Lexeme Text)
shared Facts
fs)] ]
                    fs' :: Facts
fs' = AccessPath -> Facts -> Facts
forget AccessPath
p Facts
fs
                in (Facts
fs' { freed = Set.insert p (freed fs') }, [Finding]
found' [Finding] -> [Finding] -> [Finding]
forall a. [a] -> [a] -> [a]
++ [Finding]
leaks [Finding] -> [Finding] -> [Finding]
forall a. [a] -> [a] -> [a]
++ [Finding]
stillStored)
            (Facts
afterFree, [Finding]
found'') = ((Facts, [Finding]) -> AccessPath -> (Facts, [Finding]))
-> (Facts, [Finding]) -> [AccessPath] -> (Facts, [Finding])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (Facts, [Finding]) -> AccessPath -> (Facts, [Finding])
free (Facts
facts, [Finding]
found) [AccessPath]
freedArgs
            -- Memory passed to a call is handed on, except where the call's
            -- result shows it failed.
            given :: [String]
given = (Fix (NodeF (Lexeme Text)) -> [String])
-> [Fix (NodeF (Lexeme Text))] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Fix (NodeF (Lexeme Text)) -> [String]
passed [Fix (NodeF (Lexeme Text))]
args
            handed0 :: Facts
handed0 = case Lexeme Text -> [(Lexeme Text, Outcome)] -> Maybe Outcome
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Lexeme Text
here [(Lexeme Text, Outcome)]
known of
                Just Outcome
Failure -> Facts
afterFree
                Maybe Outcome
_            -> Set String -> [String] -> Facts -> Facts
handOff Set String
later [String]
given Facts
afterFree
            keptArgs :: [String]
keptArgs = [ String
v | Int
j <- Summary -> Text -> [Outcome] -> [Int]
keptBy Summary
summary Text
g [Outcome]
outcomes, (Fix (NodeF (Lexeme Text))
a : [Fix (NodeF (Lexeme Text))]
_) <- [Int -> [Fix (NodeF (Lexeme Text))] -> [Fix (NodeF (Lexeme Text))]
forall a. Int -> [a] -> [a]
drop Int
j [Fix (NodeF (Lexeme Text))]
args], String
v <- Fix (NodeF (Lexeme Text)) -> [String]
expand Fix (NodeF (Lexeme Text))
a
                           , [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ String -> Fix (NodeF (Lexeme Text)) -> Bool
lastingFor String
v Fix (NodeF (Lexeme Text))
b | (Int
k, Fix (NodeF (Lexeme Text))
b) <- [Int]
-> [Fix (NodeF (Lexeme Text))]
-> [(Int, Fix (NodeF (Lexeme Text)))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [Fix (NodeF (Lexeme Text))]
args, Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
j ] ]
            -- A call removing an argument from where it is stored ends that.
            unstored :: Map String (Lexeme Text)
unstored = (Map String (Lexeme Text) -> String -> Map String (Lexeme Text))
-> Map String (Lexeme Text) -> [String] -> Map String (Lexeme Text)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ((String -> Map String (Lexeme Text) -> Map String (Lexeme Text))
-> Map String (Lexeme Text) -> String -> Map String (Lexeme Text)
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> Map String (Lexeme Text) -> Map String (Lexeme Text)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete) (Facts -> Map String (Lexeme Text)
shared Facts
handed0)
                [ String
v | Int
i <- [Int]
unlinksOf, (Fix (NodeF (Lexeme Text))
a : [Fix (NodeF (Lexeme Text))]
_) <- [Int -> [Fix (NodeF (Lexeme Text))] -> [Fix (NodeF (Lexeme Text))]
forall a. Int -> [a] -> [a]
drop Int
i [Fix (NodeF (Lexeme Text))]
args], String
v <- Fix (NodeF (Lexeme Text)) -> [String]
passed Fix (NodeF (Lexeme Text))
a, String
v String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
keptArgs ]
            handed :: Facts
handed = Facts
handed0
                { shared = List.foldl' (\Map String (Lexeme Text)
m String
v -> String
-> Lexeme Text
-> Map String (Lexeme Text)
-> Map String (Lexeme Text)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
v Lexeme Text
here Map String (Lexeme Text)
m) unstored (filter (`Set.member` locals) keptArgs)
                , keptParams = Set.union (keptParams handed0) (Set.fromList (filter (`Set.member` params) keptArgs))
                }
            -- A local filled through its address holds memory the function
            -- owns when it frees it later.
            filled :: [String]
filled = [ String
v | Fix (NodeF (Lexeme Text))
a <- [Fix (NodeF (Lexeme Text))]
args, Fix (UnaryExpr UnaryOp
UopAddress Fix (NodeF (Lexeme Text))
x) <- [Fix (NodeF (Lexeme Text)) -> Fix (NodeF (Lexeme Text))
bare Fix (NodeF (Lexeme Text))
a], Just (PathVar String
v) <- [Fix (NodeF (Lexeme Text)) -> Maybe AccessPath
accessPath Fix (NodeF (Lexeme Text))
x]
                         , String
v String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
locals, String
v String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
later ]
        in (Facts
handed { held = List.foldl' (\Map String (Lexeme Text)
h String
v -> String
-> Lexeme Text
-> Map String (Lexeme Text)
-> Map String (Lexeme Text)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
v Lexeme Text
here Map String (Lexeme Text)
h) (held handed) filled }, [Finding]
found'')

-- | The findings in a function, the arguments it frees and the ones it
-- stores by the outcome it reports, and whether it may return memory it also
-- stored.
analyseFunction :: Summary -> Function -> ([Finding], Map Outcome (Set Int), Map Outcome (Set Int), Bool)
analyseFunction :: Summary
-> Function
-> ([Finding], Map Outcome (Set Int), Map Outcome (Set Int), Bool)
analyseFunction Summary
summary Function
fn = ([Finding]
reported, Map Outcome (Set Int)
frees, Map Outcome (Set Int)
keepsArgs, Bool
keepsResult)
  where
    (Node
entry, CFG
cfg) = Fix (NodeF (Lexeme Text)) -> (Node, CFG)
fromFunction (Function -> Fix (NodeF (Lexeme Text))
fnDefn Function
fn)
    decls :: [(String, Maybe (Fix (NodeF (Lexeme Text))))]
decls = Fix (NodeF (Lexeme Text))
-> [(String, Maybe (Fix (NodeF (Lexeme Text))))]
localDecls (Function -> Fix (NodeF (Lexeme Text))
fnDefn Function
fn)
    locals :: Set String
locals = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList (((String, Maybe (Fix (NodeF (Lexeme Text)))) -> String)
-> [(String, Maybe (Fix (NodeF (Lexeme Text))))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Maybe (Fix (NodeF (Lexeme Text)))) -> String
forall a b. (a, b) -> a
fst [(String, Maybe (Fix (NodeF (Lexeme Text))))]
decls)
    env :: Env
env = Env
        { envLocals :: Set String
envLocals = Set String
locals
        , envParams :: Set String
envParams = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList ((Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
Text.unpack (Function -> [Text]
fnParams Function
fn))
        , envPointers :: Set String
envPointers = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList ([String]
paramPointers [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
localPointers)
        , envContains :: Map String [String]
envContains = ([String] -> [String] -> [String])
-> [(String, [String])] -> Map String [String]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
(++)
            [ (String
root, Fix (NodeF (Lexeme Text)) -> [String]
passed Fix (NodeF (Lexeme Text))
r)
            | Fix (AssignExpr Fix (NodeF (Lexeme Text))
l AssignOp
_ Fix (NodeF (Lexeme Text))
r) <- Fix (NodeF (Lexeme Text)) -> [Fix (NodeF (Lexeme Text))]
universe (Function -> Fix (NodeF (Lexeme Text))
fnDefn Function
fn), Just AccessPath
p <- [Fix (NodeF (Lexeme Text)) -> Maybe AccessPath
accessPath Fix (NodeF (Lexeme Text))
l]
            , Bool -> Bool
not (AccessPath -> Bool
throughPointer AccessPath
p), Just String
root <- [AccessPath -> Maybe String
rootOf AccessPath
p], String
root String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
locals, AccessPath
p AccessPath -> AccessPath -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> AccessPath
PathVar String
root ]
        }
    paramPointers :: [String]
paramPointers = case Function -> Fix (NodeF (Lexeme Text))
fnDefn Function
fn of
        Fix (FunctionDefn Scope
_ (Fix (FunctionPrototype Fix (NodeF (Lexeme Text))
_ Lexeme Text
_ [Fix (NodeF (Lexeme Text))]
ps)) Fix (NodeF (Lexeme Text))
_) ->
            [ Text -> String
Text.unpack Text
v | Fix (NodeF (Lexeme Text))
pd <- [Fix (NodeF (Lexeme Text))]
ps, Fix (VarDecl Fix (NodeF (Lexeme Text))
ty (L AlexPosn
_ LexemeClass
_ Text
v) [Fix (NodeF (Lexeme Text))]
arrs) <- [Fix (NodeF (Lexeme Text)) -> Fix (NodeF (Lexeme Text))
forall {lexeme}. Fix (NodeF lexeme) -> Fix (NodeF lexeme)
unParam Fix (NodeF (Lexeme Text))
pd], Fix (NodeF (Lexeme Text)) -> Bool
isPointerType Fix (NodeF (Lexeme Text))
ty Bool -> Bool -> Bool
|| Bool -> Bool
not ([Fix (NodeF (Lexeme Text))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Fix (NodeF (Lexeme Text))]
arrs) ]
        Fix (NodeF (Lexeme Text))
_ -> []
    localPointers :: [String]
localPointers = [ Text -> String
Text.unpack Text
v | Fix (VarDeclStmt (Fix (VarDecl Fix (NodeF (Lexeme Text))
ty (L AlexPosn
_ LexemeClass
_ Text
v) [])) Maybe (Fix (NodeF (Lexeme Text)))
_) <- Fix (NodeF (Lexeme Text)) -> [Fix (NodeF (Lexeme Text))]
universe (Function -> Fix (NodeF (Lexeme Text))
fnDefn Function
fn), Fix (NodeF (Lexeme Text)) -> Bool
isPointerType Fix (NodeF (Lexeme Text))
ty ]
    unParam :: Fix (NodeF lexeme) -> Fix (NodeF lexeme)
unParam = \case
        Fix (NonNullParam Fix (NodeF lexeme)
x)  -> Fix (NodeF lexeme) -> Fix (NodeF lexeme)
unParam Fix (NodeF lexeme)
x
        Fix (NullableParam Fix (NodeF lexeme)
x) -> Fix (NodeF lexeme) -> Fix (NodeF lexeme)
unParam Fix (NodeF lexeme)
x
        Fix (NodeF lexeme)
x                     -> Fix (NodeF lexeme)
x
    isPointerType :: Fix (NodeF (Lexeme Text)) -> Bool
isPointerType Fix (NodeF (Lexeme Text))
ty = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Bool
True | Fix TyPointer{} <- Fix (NodeF (Lexeme Text)) -> [Fix (NodeF (Lexeme Text))]
universe Fix (NodeF (Lexeme Text))
ty ]

    -- The locals the function may free after each point, before it gives
    -- them other memory.
    laterOut :: Map Node (Set String)
laterOut = [Node]
-> CFG
-> Dataflow Node EdgeType (Set String)
-> Map Node (Set String)
forall node state edge.
(Ord node, Eq state) =>
[node]
-> Map node [(edge, node)]
-> Dataflow node edge state
-> Map node state
solveBackward [Node]
exits CFG
cfg Dataflow
        { transfer :: Node -> Set String -> Set String
transfer     = Node -> Set String -> Set String
laterBefore
        , edgeTransfer :: Node -> EdgeType -> Set String -> Set String
edgeTransfer = \Node
_ EdgeType
_ Set String
s -> Set String
s
        , merge :: Set String -> Set String -> Set String
merge        = Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
Set.union
        , initial :: Set String
initial      = Set String
forall a. Set a
Set.empty
        }
    exits :: [Node]
exits = [ Node
n | n :: Node
n@(Node Int
_ NodeKind
ExitNode) <- CFG -> [Node]
forall k a. Map k a -> [k]
Map.keys CFG
cfg [Node] -> [Node] -> [Node]
forall a. [a] -> [a] -> [a]
++ [ Node
v | [Edge]
es <- CFG -> [[Edge]]
forall k a. Map k a -> [a]
Map.elems CFG
cfg, (EdgeType
_, Node
v) <- [Edge]
es ] ]
    laterBefore :: Node -> Set String -> Set String
laterBefore Node
n Set String
out = Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Node -> Set String
freesIn Node
n) (Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set String
out (Node -> Set String
setsIn Node
n))
    laterAfter :: Node -> Set String
laterAfter Node
n = Set String -> Node -> Map Node (Set String) -> Set String
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Set String
forall a. Set a
Set.empty Node
n Map Node (Set String)
laterOut
    laterOn :: Node -> EdgeType -> Set String
laterOn Node
n EdgeType
e = [Set String] -> Set String
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [ Node -> Set String -> Set String
laterBefore Node
v (Node -> Set String
laterAfter Node
v) |(EdgeType
e', Node
v) <- [Edge] -> Node -> CFG -> [Edge]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] Node
n CFG
cfg, EdgeType
e' EdgeType -> EdgeType -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeType
e ]
    -- Undoing work on the way to a failure return does not show that the
    -- function kept what it frees there.
    freesIn :: Node -> Set String
freesIn Node
n | Bool -> Bool
not (Node
n Node -> Set Node -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Node
toSuccess) = Set String
forall a. Set a
Set.empty
    freesIn Node
n = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList
        [ String
v | Fix (NodeF (Lexeme Text))
x <- Node -> [Fix (NodeF (Lexeme Text))]
nodeExprs Node
n, Fix (FunctionCall Fix (NodeF (Lexeme Text))
callee [Fix (NodeF (Lexeme Text))]
args) <- Fix (NodeF (Lexeme Text)) -> [Fix (NodeF (Lexeme Text))]
universe Fix (NodeF (Lexeme Text))
x
            , let L AlexPosn
_ LexemeClass
_ Text
g = Fix (NodeF (Lexeme Text)) -> Lexeme Text
calleeLexeme Fix (NodeF (Lexeme Text))
callee
            , Int
i <- Summary -> Text -> [Outcome] -> [Int]
freedBy Summary
summary Text
g [Outcome
forall a. Bounded a => a
minBound .. Outcome
forall a. Bounded a => a
maxBound], (Fix (NodeF (Lexeme Text))
a : [Fix (NodeF (Lexeme Text))]
_) <- [Int -> [Fix (NodeF (Lexeme Text))] -> [Fix (NodeF (Lexeme Text))]
forall a. Int -> [a] -> [a]
drop Int
i [Fix (NodeF (Lexeme Text))]
args]
            , Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
v')) <- [Fix (NodeF (Lexeme Text)) -> Fix (NodeF (Lexeme Text))
bare Fix (NodeF (Lexeme Text))
a], let v :: String
v = Text -> String
Text.unpack Text
v', String
v String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
locals ]
    toSuccess :: Set Node
toSuccess = Set Node -> Set Node
reach ([Node] -> Set Node
forall a. Ord a => [a] -> Set a
Set.fromList [ Node
n | (Node
n, [Edge]
es) <- CFG -> [(Node, [Edge])]
forall k a. Map k a -> [(k, a)]
Map.toList CFG
cfg, (Edge -> Bool) -> [Edge] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Node -> Bool
isExit (Node -> Bool) -> (Edge -> Node) -> Edge -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Edge -> Node
forall a b. (a, b) -> b
snd) [Edge]
es, Outcome
Success Outcome -> [Outcome] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Node -> [Outcome]
outcomesAt Node
n ])
    outcomesAt :: Node -> [Outcome]
outcomesAt = \case
        Node Int
_ (StmtNode (Fix (Return Maybe (Fix (NodeF (Lexeme Text)))
e))) -> Shape -> Maybe (Fix (NodeF (Lexeme Text))) -> [Outcome]
returnOutcomes (Function -> Shape
fnShape Function
fn) Maybe (Fix (NodeF (Lexeme Text)))
e
        Node
_                                  -> [Outcome
Success]
    preds :: Map Node [Node]
preds = ([Node] -> [Node] -> [Node]) -> [(Node, [Node])] -> Map Node [Node]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [Node] -> [Node] -> [Node]
forall a. [a] -> [a] -> [a]
(++) [ (Node
v, [Node
u]) | (Node
u, [Edge]
es) <- CFG -> [(Node, [Edge])]
forall k a. Map k a -> [(k, a)]
Map.toList CFG
cfg, (EdgeType
_, Node
v) <- [Edge]
es ]
    reach :: Set Node -> Set Node
reach Set Node
s = let s' :: Set Node
s' = Set Node -> Set Node -> Set Node
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Node
s ([Node] -> Set Node
forall a. Ord a => [a] -> Set a
Set.fromList [ Node
p | Node
n <- Set Node -> [Node]
forall a. Set a -> [a]
Set.toList Set Node
s, Node
p <- [Node] -> Node -> Map Node [Node] -> [Node]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] Node
n Map Node [Node]
preds ])
              in if Set Node -> Int
forall a. Set a -> Int
Set.size Set Node
s' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Set Node -> Int
forall a. Set a -> Int
Set.size Set Node
s then Set Node
s else Set Node -> Set Node
reach Set Node
s'
    setsIn :: Node -> Set String
setsIn Node
n = [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
$ case Node
n of
        Node Int
_ (StmtNode (Fix (VarDeclStmt (Fix (VarDecl Fix (NodeF (Lexeme Text))
_ (L AlexPosn
_ LexemeClass
_ Text
v) [Fix (NodeF (Lexeme Text))]
_)) Maybe (Fix (NodeF (Lexeme Text)))
_))) -> [Text -> String
Text.unpack Text
v]
        Node
_ -> [ Text -> String
Text.unpack Text
v | Fix (NodeF (Lexeme Text))
x <- Node -> [Fix (NodeF (Lexeme Text))]
nodeExprs Node
n, Fix (AssignExpr (Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
v))) AssignOp
_ Fix (NodeF (Lexeme Text))
_) <- Fix (NodeF (Lexeme Text)) -> [Fix (NodeF (Lexeme Text))]
universe Fix (NodeF (Lexeme Text))
x ]
          [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ Text -> String
Text.unpack Text
v | Fix (NodeF (Lexeme Text))
x <- Node -> [Fix (NodeF (Lexeme Text))]
nodeExprs Node
n, Fix (UnaryExpr UnaryOp
UopAddress (Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
v)))) <- Fix (NodeF (Lexeme Text)) -> [Fix (NodeF (Lexeme Text))]
universe Fix (NodeF (Lexeme Text))
x ]
    assigned :: Map String [Fix (NodeF (Lexeme Text))]
assigned = Fix (NodeF (Lexeme Text)) -> Map String [Fix (NodeF (Lexeme Text))]
assignments (Function -> Fix (NodeF (Lexeme Text))
fnDefn Function
fn)
    -- The locals that only hold enum constants, whose values are followed.
    flagVars :: Set String
flagVars = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList
        [ String
v | (String
v, Maybe (Fix (NodeF (Lexeme Text)))
ini) <- [(String, Maybe (Fix (NodeF (Lexeme Text))))]
decls
            , let given :: [Fix (NodeF (Lexeme Text))]
given = [Fix (NodeF (Lexeme Text))]
-> (Fix (NodeF (Lexeme Text)) -> [Fix (NodeF (Lexeme Text))])
-> Maybe (Fix (NodeF (Lexeme Text)))
-> [Fix (NodeF (Lexeme Text))]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Fix (NodeF (Lexeme Text)) -> [Fix (NodeF (Lexeme Text))]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Fix (NodeF (Lexeme Text)))
ini [Fix (NodeF (Lexeme Text))]
-> [Fix (NodeF (Lexeme Text))] -> [Fix (NodeF (Lexeme Text))]
forall a. [a] -> [a] -> [a]
++ [Fix (NodeF (Lexeme Text))]
-> String
-> Map String [Fix (NodeF (Lexeme Text))]
-> [Fix (NodeF (Lexeme Text))]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] String
v Map String [Fix (NodeF (Lexeme Text))]
assigned
            , Bool -> Bool
not ([Fix (NodeF (Lexeme Text))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Fix (NodeF (Lexeme Text))]
given), (Fix (NodeF (Lexeme Text)) -> Bool)
-> [Fix (NodeF (Lexeme Text))] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> (Text -> Bool) -> Maybe Text -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Text -> Bool
isEnumConst (Maybe Text -> Bool)
-> (Fix (NodeF (Lexeme Text)) -> Maybe Text)
-> Fix (NodeF (Lexeme Text))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix (NodeF (Lexeme Text)) -> Maybe Text
constName) [Fix (NodeF (Lexeme Text))]
given ]

    -- A branch's condition is evaluated on each edge out of it, knowing the
    -- outcomes it implies there.
    run :: Node -> Facts -> (Facts, [Finding])
run Node
n Facts
facts = case Node
n of
        Node Int
_ BranchNode{} -> (Facts
facts, [])
        Node
_ -> Node -> (Facts, [Finding]) -> (Facts, [Finding])
forall {b}. Node -> (Facts, b) -> (Facts, b)
returned Node
n (((Facts, [Finding])
 -> Fix (NodeF (Lexeme Text)) -> (Facts, [Finding]))
-> (Facts, [Finding])
-> [Fix (NodeF (Lexeme Text))]
-> (Facts, [Finding])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ((Fix (NodeF (Lexeme Text))
 -> (Facts, [Finding]) -> (Facts, [Finding]))
-> (Facts, [Finding])
-> Fix (NodeF (Lexeme Text))
-> (Facts, [Finding])
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Summary
-> [(Lexeme Text, Outcome)]
-> Env
-> Set String
-> Fix (NodeF (Lexeme Text))
-> (Facts, [Finding])
-> (Facts, [Finding])
evalExpr Summary
summary [] Env
env (Node -> Set String
laterAfter Node
n))) (Node -> Facts -> Facts
declare Node
n Facts
facts, []) (Node -> [Fix (NodeF (Lexeme Text))]
nodeExprs Node
n))
    -- What a function returns is the caller's to free.
    returned :: Node -> (Facts, b) -> (Facts, b)
returned Node
n (Facts
facts, b
found) = case Node
n of
        Node Int
_ (StmtNode (Fix (Return (Just Fix (NodeF (Lexeme Text))
e)))) -> (Facts
facts { held = List.foldl' (flip Map.delete) (held facts) (passed e) }, b
found)
        Node
_ -> (Facts
facts, b
found)
    declare :: Node -> Facts -> Facts
declare Node
n Facts
facts = case Node
n of
        Node Int
_ (StmtNode (Fix (VarDeclStmt (Fix (VarDecl Fix (NodeF (Lexeme Text))
_ (L AlexPosn
_ LexemeClass
_ Text
v) [Fix (NodeF (Lexeme Text))]
_)) Maybe (Fix (NodeF (Lexeme Text)))
ini))) ->
            let forgot :: Facts
forgot = AccessPath -> Facts -> Facts
forget (String -> AccessPath
PathVar (Text -> String
Text.unpack Text
v)) Facts
facts
            in case Maybe (Fix (NodeF (Lexeme Text)))
ini of
                Just Fix (NodeF (Lexeme Text))
r | Fix (FunctionCall Fix (NodeF (Lexeme Text))
callee [Fix (NodeF (Lexeme Text))]
_) <- Fix (NodeF (Lexeme Text)) -> Fix (NodeF (Lexeme Text))
bare Fix (NodeF (Lexeme Text))
r, Set Text -> Fix (NodeF (Lexeme Text)) -> Bool
callsOneOf (Summary -> Set Text
sumFresh Summary
summary) Fix (NodeF (Lexeme Text))
r, Bool -> Bool
not (Fix (NodeF (Lexeme Text)) -> Bool
fillsLocal Fix (NodeF (Lexeme Text))
r) ->
                    Facts
forgot { held = Map.insert (Text.unpack v) (calleeLexeme callee) (held forgot) }
                Just Fix (NodeF (Lexeme Text))
r | Fix (FunctionCall Fix (NodeF (Lexeme Text))
callee [Fix (NodeF (Lexeme Text))]
_) <- Fix (NodeF (Lexeme Text)) -> Fix (NodeF (Lexeme Text))
bare Fix (NodeF (Lexeme Text))
r, Set Text -> Fix (NodeF (Lexeme Text)) -> Bool
callsOneOf (Summary -> Set Text
sumKept Summary
summary) Fix (NodeF (Lexeme Text))
r ->
                    Facts
forgot { shared = Map.insert (Text.unpack v) (calleeLexeme callee) (shared forgot) }
                Maybe (Fix (NodeF (Lexeme Text)))
_ -> Facts
forgot
        Node
_ -> Facts
facts
    onEdge :: Node
-> Fix (NodeF (Lexeme Text))
-> EdgeType
-> Facts
-> (Facts, [Finding])
onEdge Node
n Fix (NodeF (Lexeme Text))
cond EdgeType
e Facts
facts = Summary
-> [(Lexeme Text, Outcome)]
-> Env
-> Set String
-> Fix (NodeF (Lexeme Text))
-> (Facts, [Finding])
-> (Facts, [Finding])
evalExpr Summary
summary (Fix (NodeF (Lexeme Text)) -> EdgeType -> [(Lexeme Text, Outcome)]
knownOn Fix (NodeF (Lexeme Text))
cond EdgeType
e) Env
env (Node -> EdgeType -> Set String
laterOn Node
n EdgeType
e) Fix (NodeF (Lexeme Text))
cond (Facts
facts, [])

    setFlags :: Node -> Map String Text -> Map String Text
setFlags Node
n Map String Text
flags = (Map String Text
 -> (Text, Maybe (Fix (NodeF (Lexeme Text)))) -> Map String Text)
-> Map String Text
-> [(Text, Maybe (Fix (NodeF (Lexeme Text))))]
-> Map String Text
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Map String Text
-> (Text, Maybe (Fix (NodeF (Lexeme Text)))) -> Map String Text
setFlag Map String Text
flags ([(Text, Maybe (Fix (NodeF (Lexeme Text))))] -> Map String Text)
-> [(Text, Maybe (Fix (NodeF (Lexeme Text))))] -> Map String Text
forall a b. (a -> b) -> a -> b
$ case Node
n of
        Node Int
_ (StmtNode (Fix (VarDeclStmt (Fix (VarDecl Fix (NodeF (Lexeme Text))
_ (L AlexPosn
_ LexemeClass
_ Text
v) [Fix (NodeF (Lexeme Text))]
_)) Maybe (Fix (NodeF (Lexeme Text)))
ini))) -> [(Text
v, Maybe (Fix (NodeF (Lexeme Text)))
ini)]
        Node
_ -> [ (Text
v, Fix (NodeF (Lexeme Text)) -> Maybe (Fix (NodeF (Lexeme Text)))
forall a. a -> Maybe a
Just Fix (NodeF (Lexeme Text))
r) | Fix (NodeF (Lexeme Text))
e <- Node -> [Fix (NodeF (Lexeme Text))]
nodeExprs Node
n, Fix (AssignExpr (Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
v))) AssignOp
_ Fix (NodeF (Lexeme Text))
r) <- Fix (NodeF (Lexeme Text)) -> [Fix (NodeF (Lexeme Text))]
universe Fix (NodeF (Lexeme Text))
e ]
    setFlag :: Map String Text
-> (Text, Maybe (Fix (NodeF (Lexeme Text)))) -> Map String Text
setFlag Map String Text
flags (Text
v, Maybe (Fix (NodeF (Lexeme Text)))
ini)
        | String
name String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
flagVars, Just Text
c <- Maybe (Fix (NodeF (Lexeme Text)))
ini Maybe (Fix (NodeF (Lexeme Text)))
-> (Fix (NodeF (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
>>= Fix (NodeF (Lexeme Text)) -> Maybe Text
constName = String -> Text -> Map String Text -> Map String Text
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
name Text
c Map String Text
flags
        | Bool
otherwise = String -> Map String Text -> Map String Text
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete String
name Map String Text
flags
      where name :: String
name = Text -> String
Text.unpack Text
v

    -- The facts on the paths to a point are kept by the values the flags
    -- have on them. No entries means no path gets there.
    step :: Node -> Map (Map String Text) Facts -> Map (Map String Text) Facts
step Node
n Map (Map String Text) Facts
st = (Facts -> Facts -> Facts)
-> [(Map String Text, Facts)] -> Map (Map String Text) Facts
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Facts -> Facts -> Facts
joinFacts
        [ (Node -> Map String Text -> Map String Text
setFlags Node
n Map String Text
flags, (Facts, [Finding]) -> Facts
forall a b. (a, b) -> a
fst (Node -> Facts -> (Facts, [Finding])
run Node
n Facts
facts)) | (Map String Text
flags, Facts
facts) <- Map (Map String Text) Facts -> [(Map String Text, Facts)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (Map String Text) Facts
st ]

    edge :: Node
-> EdgeType
-> Map (Map String Text) Facts
-> Map (Map String Text) Facts
edge Node
n EdgeType
e Map (Map String Text) Facts
st = case Node
n of
        Node Int
_ (BranchNode Fix (NodeF (Lexeme Text))
cond) ->
            (Facts -> Facts)
-> Map (Map String Text) Facts -> Map (Map String Text) Facts
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Fix (NodeF (Lexeme Text)) -> EdgeType -> Facts -> Facts
dropFailed Fix (NodeF (Lexeme Text))
cond EdgeType
e (Facts -> Facts) -> (Facts -> Facts) -> Facts -> Facts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix (NodeF (Lexeme Text)) -> EdgeType -> Facts -> Facts
dropNull Fix (NodeF (Lexeme Text))
cond EdgeType
e (Facts -> Facts) -> (Facts -> Facts) -> Facts -> Facts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Facts, [Finding]) -> Facts
forall a b. (a, b) -> a
fst ((Facts, [Finding]) -> Facts)
-> (Facts -> (Facts, [Finding])) -> Facts -> Facts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node
-> Fix (NodeF (Lexeme Text))
-> EdgeType
-> Facts
-> (Facts, [Finding])
onEdge Node
n Fix (NodeF (Lexeme Text))
cond EdgeType
e) ((Map String Text -> Facts -> Bool)
-> Map (Map String Text) Facts -> Map (Map String Text) Facts
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\Map String Text
flags Facts
_ -> Map String Text -> Fix (NodeF (Lexeme Text)) -> EdgeType -> Bool
flagHolds Map String Text
flags Fix (NodeF (Lexeme Text))
cond EdgeType
e) Map (Map String Text) Facts
st)
        Node
_ -> Map (Map String Text) Facts
st
    knownOn :: Fix (NodeF (Lexeme Text)) -> EdgeType -> [(Lexeme Text, Outcome)]
knownOn Fix (NodeF (Lexeme Text))
cond EdgeType
e = case (Fix (NodeF (Lexeme Text))
-> NodeF (Lexeme Text) (Fix (NodeF (Lexeme Text)))
unFix' (Fix (NodeF (Lexeme Text)) -> Fix (NodeF (Lexeme Text))
strip Fix (NodeF (Lexeme Text))
cond), EdgeType
e) of
        (BinaryExpr Fix (NodeF (Lexeme Text))
l BinaryOp
BopAnd Fix (NodeF (Lexeme Text))
r, EdgeType
TrueBranch) -> Fix (NodeF (Lexeme Text)) -> EdgeType -> [(Lexeme Text, Outcome)]
knownOn Fix (NodeF (Lexeme Text))
l EdgeType
e [(Lexeme Text, Outcome)]
-> [(Lexeme Text, Outcome)] -> [(Lexeme Text, Outcome)]
forall a. [a] -> [a] -> [a]
++ Fix (NodeF (Lexeme Text)) -> EdgeType -> [(Lexeme Text, Outcome)]
knownOn Fix (NodeF (Lexeme Text))
r EdgeType
e
        (BinaryExpr Fix (NodeF (Lexeme Text))
l BinaryOp
BopOr Fix (NodeF (Lexeme Text))
r, EdgeType
FalseBranch) -> Fix (NodeF (Lexeme Text)) -> EdgeType -> [(Lexeme Text, Outcome)]
knownOn Fix (NodeF (Lexeme Text))
l EdgeType
e [(Lexeme Text, Outcome)]
-> [(Lexeme Text, Outcome)] -> [(Lexeme Text, Outcome)]
forall a. [a] -> [a] -> [a]
++ Fix (NodeF (Lexeme Text)) -> EdgeType -> [(Lexeme Text, Outcome)]
knownOn Fix (NodeF (Lexeme Text))
r EdgeType
e
        (NodeF (Lexeme Text) (Fix (NodeF (Lexeme Text))), EdgeType)
_ -> case (Map Text Shape
-> Fix (NodeF (Lexeme Text)) -> Maybe (Lexeme Text, Outcome)
branchOn (Summary -> Map Text Shape
sumShapes Summary
summary) (Fix (NodeF (Lexeme Text)) -> Fix (NodeF (Lexeme Text))
resolve Fix (NodeF (Lexeme Text))
cond), EdgeType
e) of
            (Just (Lexeme Text
l, Outcome
o), EdgeType
TrueBranch)  -> [(Lexeme Text
l, Outcome
o)]
            (Just (Lexeme Text
l, Outcome
o), EdgeType
FalseBranch) -> [(Lexeme Text
l, if Outcome
o Outcome -> Outcome -> Bool
forall a. Eq a => a -> a -> Bool
== Outcome
Success then Outcome
Failure else Outcome
Success)]
            (Maybe (Lexeme Text, Outcome), EdgeType)
_                          -> []
    -- A local given only a call's result stands for the call in a branch.
    resultOf :: Map String (Fix (NodeF (Lexeme Text)))
resultOf = [(String, Fix (NodeF (Lexeme Text)))]
-> Map String (Fix (NodeF (Lexeme Text)))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (String
v, Fix (NodeF (Lexeme Text))
c) | (String
v, Maybe (Fix (NodeF (Lexeme Text)))
ini) <- [(String, Maybe (Fix (NodeF (Lexeme Text))))]
decls
                 , [c :: Fix (NodeF (Lexeme Text))
c@(Fix FunctionCall{})] <- [(Fix (NodeF (Lexeme Text)) -> Fix (NodeF (Lexeme Text)))
-> [Fix (NodeF (Lexeme Text))] -> [Fix (NodeF (Lexeme Text))]
forall a b. (a -> b) -> [a] -> [b]
map Fix (NodeF (Lexeme Text)) -> Fix (NodeF (Lexeme Text))
bare ([Fix (NodeF (Lexeme Text))]
-> (Fix (NodeF (Lexeme Text)) -> [Fix (NodeF (Lexeme Text))])
-> Maybe (Fix (NodeF (Lexeme Text)))
-> [Fix (NodeF (Lexeme Text))]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Fix (NodeF (Lexeme Text)) -> [Fix (NodeF (Lexeme Text))]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Fix (NodeF (Lexeme Text)))
ini [Fix (NodeF (Lexeme Text))]
-> [Fix (NodeF (Lexeme Text))] -> [Fix (NodeF (Lexeme Text))]
forall a. [a] -> [a] -> [a]
++ [Fix (NodeF (Lexeme Text))]
-> String
-> Map String [Fix (NodeF (Lexeme Text))]
-> [Fix (NodeF (Lexeme Text))]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] String
v Map String [Fix (NodeF (Lexeme Text))]
assigned)] ]
    resolve :: Fix (NodeF (Lexeme Text)) -> Fix (NodeF (Lexeme Text))
resolve (Fix NodeF (Lexeme Text) (Fix (NodeF (Lexeme Text)))
n) = case NodeF (Lexeme Text) (Fix (NodeF (Lexeme Text)))
n of
        VarExpr (L AlexPosn
_ LexemeClass
_ Text
v) | Just Fix (NodeF (Lexeme Text))
c <- String
-> Map String (Fix (NodeF (Lexeme Text)))
-> Maybe (Fix (NodeF (Lexeme Text)))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> String
Text.unpack Text
v) Map String (Fix (NodeF (Lexeme Text)))
resultOf -> Fix (NodeF (Lexeme Text))
c
        NodeF (Lexeme Text) (Fix (NodeF (Lexeme Text)))
_ -> NodeF (Lexeme Text) (Fix (NodeF (Lexeme Text)))
-> Fix (NodeF (Lexeme Text))
forall (f :: * -> *). f (Fix f) -> Fix f
Fix ((Fix (NodeF (Lexeme Text)) -> Fix (NodeF (Lexeme Text)))
-> NodeF (Lexeme Text) (Fix (NodeF (Lexeme Text)))
-> NodeF (Lexeme Text) (Fix (NodeF (Lexeme Text)))
forall a b.
(a -> b) -> NodeF (Lexeme Text) a -> NodeF (Lexeme Text) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Fix (NodeF (Lexeme Text)) -> Fix (NodeF (Lexeme Text))
resolve NodeF (Lexeme Text) (Fix (NodeF (Lexeme Text)))
n)
    -- Where a call failed, it filled and kept nothing.
    dropFailed :: Fix (NodeF (Lexeme Text)) -> EdgeType -> Facts -> Facts
dropFailed Fix (NodeF (Lexeme Text))
cond EdgeType
e Facts
facts = Facts
facts { held = Map.filter (`notElem` failed) (held facts), shared = Map.filter (`notElem` failed) (shared facts) }
      where failed :: [Lexeme Text]
failed = [ Lexeme Text
l | (Lexeme Text
l, Outcome
Failure) <- Fix (NodeF (Lexeme Text)) -> EdgeType -> [(Lexeme Text, Outcome)]
knownOn Fix (NodeF (Lexeme Text))
cond EdgeType
e ]
    -- Where a pointer is null, it holds no memory.
    dropNull :: Fix (NodeF (Lexeme Text)) -> EdgeType -> Facts -> Facts
dropNull Fix (NodeF (Lexeme Text))
cond EdgeType
e Facts
facts = case Fix (NodeF (Lexeme Text)) -> Maybe (AccessPath, EdgeType)
nullOn Fix (NodeF (Lexeme Text))
cond of
        Just (AccessPath
p, EdgeType
on) | EdgeType
on EdgeType -> EdgeType -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeType
e -> Facts
facts { owned = Map.delete p (owned facts), held = dropVar p (held facts) }
        Maybe (AccessPath, EdgeType)
_                      -> Facts
facts
    dropVar :: AccessPath -> Map String a -> Map String a
dropVar AccessPath
p Map String a
h = case AccessPath
p of
        PathVar String
v -> String -> Map String a -> Map String a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete String
v Map String a
h
        AccessPath
_         -> Map String a
h
    nullOn :: Fix (NodeF (Lexeme Text)) -> Maybe (AccessPath, EdgeType)
nullOn = (Fix (NodeF (Lexeme Text)) -> Maybe AccessPath)
-> Fix (NodeF (Lexeme Text)) -> Maybe (AccessPath, EdgeType)
forall a.
(Fix (NodeF (Lexeme Text)) -> Maybe a)
-> Fix (NodeF (Lexeme Text)) -> Maybe (a, EdgeType)
nullTest Fix (NodeF (Lexeme Text)) -> Maybe AccessPath
accessPath

    result :: Map Node (Map (Map String Text) Facts)
result = Node
-> CFG
-> Dataflow Node EdgeType (Map (Map String Text) Facts)
-> Map Node (Map (Map String Text) Facts)
forall node state edge.
(Ord node, Eq state) =>
node
-> Map node [(edge, node)]
-> Dataflow node edge state
-> Map node state
solve Node
entry CFG
cfg Dataflow
        { transfer :: Node -> Map (Map String Text) Facts -> Map (Map String Text) Facts
transfer     = Node -> Map (Map String Text) Facts -> Map (Map String Text) Facts
step
        , edgeTransfer :: Node
-> EdgeType
-> Map (Map String Text) Facts
-> Map (Map String Text) Facts
edgeTransfer = Node
-> EdgeType
-> Map (Map String Text) Facts
-> Map (Map String Text) Facts
edge
        , merge :: Map (Map String Text) Facts
-> Map (Map String Text) Facts -> Map (Map String Text) Facts
merge        = (Facts -> Facts -> Facts)
-> Map (Map String Text) Facts
-> Map (Map String Text) Facts
-> Map (Map String Text) Facts
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Facts -> Facts -> Facts
joinFacts
        , initial :: Map (Map String Text) Facts
initial      = Map String Text -> Facts -> Map (Map String Text) Facts
forall k a. k -> a -> Map k a
Map.singleton Map String Text
forall k a. Map k a
Map.empty (Set AccessPath
-> Map AccessPath (Lexeme Text)
-> Map String (Lexeme Text)
-> Map String (Lexeme Text)
-> Set String
-> Set String
-> Facts
Facts Set AccessPath
forall a. Set a
Set.empty Map AccessPath (Lexeme Text)
forall k a. Map k a
Map.empty Map String (Lexeme Text)
forall k a. Map k a
Map.empty Map String (Lexeme Text)
forall k a. Map k a
Map.empty Set String
forall a. Set a
Set.empty Set String
forall a. Set a
Set.empty)
        }

    reported :: [Finding]
reported = Set Finding -> [Finding]
forall a. Set a -> [a]
Set.toList (Set Finding -> [Finding])
-> ([Finding] -> Set Finding) -> [Finding] -> [Finding]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Finding] -> Set Finding
forall a. Ord a => [a] -> Set a
Set.fromList ([Finding] -> [Finding]) -> [Finding] -> [Finding]
forall a b. (a -> b) -> a -> b
$ [[Finding]] -> [Finding]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Finding]
found
        | (Node
n, Map (Map String Text) Facts
st) <- Map Node (Map (Map String Text) Facts)
-> [(Node, Map (Map String Text) Facts)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Node (Map (Map String Text) Facts)
result
        , (Map String Text
flags, Facts
facts) <- Map (Map String Text) Facts -> [(Map String Text, Facts)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (Map String Text) Facts
st
        , [Finding]
found <- case Node
n of
            Node Int
_ (BranchNode Fix (NodeF (Lexeme Text))
cond) ->
                [ (Facts, [Finding]) -> [Finding]
forall a b. (a, b) -> b
snd (Node
-> Fix (NodeF (Lexeme Text))
-> EdgeType
-> Facts
-> (Facts, [Finding])
onEdge Node
n Fix (NodeF (Lexeme Text))
cond EdgeType
e Facts
facts) | (EdgeType
e, Node
_) <- [Edge] -> Node -> CFG -> [Edge]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] Node
n CFG
cfg, Map String Text -> Fix (NodeF (Lexeme Text)) -> EdgeType -> Bool
flagHolds Map String Text
flags Fix (NodeF (Lexeme Text))
cond EdgeType
e ]
            Node
_ -> [(Facts, [Finding]) -> [Finding]
forall a b. (a, b) -> b
snd (Node -> Facts -> (Facts, [Finding])
run Node
n Facts
facts)]
        ] [Finding] -> [Finding] -> [Finding]
forall a. [a] -> [a] -> [a]
++
        [ Lexeme Text -> String -> Maybe (Lexeme Text) -> Finding
LeakedLocal Lexeme Text
at String
v (Node -> Maybe (Lexeme Text)
exitLexeme Node
n)
        | (Node
n, [Edge]
edges) <- CFG -> [(Node, [Edge])]
forall k a. Map k a -> [(k, a)]
Map.toList CFG
cfg
        , (Edge -> Bool) -> [Edge] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Node -> Bool
isExit (Node -> Bool) -> (Edge -> Node) -> Edge -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Edge -> Node
forall a b. (a, b) -> b
snd) [Edge]
edges
        , Bool -> Bool
not (Node -> Bool
aborts Node
n)
        , Just Map (Map String Text) Facts
st <- [Node
-> Map Node (Map (Map String Text) Facts)
-> Maybe (Map (Map String Text) Facts)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Node
n Map Node (Map (Map String Text) Facts)
result]
        , (Map String Text
flags, Facts
facts) <- Map (Map String Text) Facts -> [(Map String Text, Facts)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (Map String Text) Facts
st
        , Facts
after <- case Node
n of
            Node Int
_ (BranchNode Fix (NodeF (Lexeme Text))
cond) ->
                [ Fix (NodeF (Lexeme Text)) -> EdgeType -> Facts -> Facts
dropFailed Fix (NodeF (Lexeme Text))
cond EdgeType
e (Fix (NodeF (Lexeme Text)) -> EdgeType -> Facts -> Facts
dropNull Fix (NodeF (Lexeme Text))
cond EdgeType
e ((Facts, [Finding]) -> Facts
forall a b. (a, b) -> a
fst (Node
-> Fix (NodeF (Lexeme Text))
-> EdgeType
-> Facts
-> (Facts, [Finding])
onEdge Node
n Fix (NodeF (Lexeme Text))
cond EdgeType
e Facts
facts))) | (EdgeType
e, Node
v') <- [Edge]
edges, Node -> Bool
isExit Node
v', Map String Text -> Fix (NodeF (Lexeme Text)) -> EdgeType -> Bool
flagHolds Map String Text
flags Fix (NodeF (Lexeme Text))
cond EdgeType
e ]
            Node
_ -> [(Facts, [Finding]) -> Facts
forall a b. (a, b) -> a
fst (Node -> Facts -> (Facts, [Finding])
run Node
n Facts
facts)]
        , (String
v, Lexeme Text
at) <- Map String (Lexeme Text) -> [(String, Lexeme Text)]
forall k a. Map k a -> [(k, a)]
Map.toList (Facts -> Map String (Lexeme Text)
held Facts
after)
        ]
    -- Memory is not lost where the program stops.
    aborts :: Node -> Bool
aborts Node
n = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Bool
True | Fix (NodeF (Lexeme Text))
x <- Node -> [Fix (NodeF (Lexeme Text))]
nodeExprs Node
n, Fix (FunctionCall Fix (NodeF (Lexeme Text))
callee [Fix (NodeF (Lexeme Text))]
_) <- Fix (NodeF (Lexeme Text)) -> [Fix (NodeF (Lexeme Text))]
universe Fix (NodeF (Lexeme Text))
x
                         , let L AlexPosn
_ LexemeClass
_ Text
g = Fix (NodeF (Lexeme Text)) -> Lexeme Text
calleeLexeme Fix (NodeF (Lexeme Text))
callee, Text
g Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"abort", Text
"exit", Text
"LOGGER_FATAL"] ]
    exitLexeme :: Node -> Maybe (Lexeme Text)
exitLexeme = \case
        Node Int
_ (StmtNode (Fix (Return (Just Fix (NodeF (Lexeme Text))
e)))) -> Fix (NodeF (Lexeme Text)) -> Maybe (Lexeme Text)
firstLexeme Fix (NodeF (Lexeme Text))
e
        Node
_                                         -> Maybe (Lexeme Text)
forall a. Maybe a
Nothing

    keepsResult :: Bool
keepsResult = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
        [ Bool
True
        | (Facts
after, Fix (NodeF (Lexeme Text))
ret) <- [(Facts, Fix (NodeF (Lexeme Text)))]
returnedAt
        , Set Text -> Fix (NodeF (Lexeme Text)) -> Bool
callsOneOf (Summary -> Set Text
sumKept Summary
summary) Fix (NodeF (Lexeme Text))
ret
          Bool -> Bool -> Bool
|| (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\String
v -> String
v String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Facts -> Set String
keptLocals Facts
after Bool -> Bool -> Bool
|| String
v String -> Map String (Lexeme Text) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Facts -> Map String (Lexeme Text)
shared Facts
after) (Fix (NodeF (Lexeme Text)) -> [String]
passed Fix (NodeF (Lexeme Text))
ret) ]
    returnedAt :: [(Facts, Fix (NodeF (Lexeme Text)))]
returnedAt =
        [ ((Facts, [Finding]) -> Facts
forall a b. (a, b) -> a
fst (Node -> Facts -> (Facts, [Finding])
run Node
n Facts
facts), Fix (NodeF (Lexeme Text))
e)
        | (n :: Node
n@(Node Int
_ (StmtNode (Fix (Return (Just Fix (NodeF (Lexeme Text))
e))))), [Edge]
_) <- CFG -> [(Node, [Edge])]
forall k a. Map k a -> [(k, a)]
Map.toList CFG
cfg
        , Just Map (Map String Text) Facts
st <- [Node
-> Map Node (Map (Map String Text) Facts)
-> Maybe (Map (Map String Text) Facts)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Node
n Map Node (Map (Map String Text) Facts)
result], Facts
facts <- Map (Map String Text) Facts -> [Facts]
forall k a. Map k a -> [a]
Map.elems Map (Map String Text) Facts
st ]
    keepsArgs :: Map Outcome (Set Int)
keepsArgs = (Set Int -> Set Int -> Set Int)
-> [(Outcome, Set Int)] -> Map Outcome (Set Int)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
Set.union
        [ (Outcome
o, [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList [ Int
i | String
v <- Set String -> [String]
forall a. Set a -> [a]
Set.toList (Facts -> Set String
keptParams Facts
after), Just Int
i <- [Text -> [Text] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
List.elemIndex (String -> Text
Text.pack String
v) (Function -> [Text]
fnParams Function
fn)] ])
        | (Facts
after, Outcome
o) <- [(Facts, Outcome)]
atExits ]
    frees :: Map Outcome (Set Int)
frees = (Set Int -> Set Int -> Set Int)
-> [(Outcome, Set Int)] -> Map Outcome (Set Int)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
Set.union
        [ (Outcome
o, [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList [ Int
i | PathVar String
v <- Set AccessPath -> [AccessPath]
forall a. Set a -> [a]
Set.toList (Facts -> Set AccessPath
freed Facts
after), Just Int
i <- [Text -> [Text] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
List.elemIndex (String -> Text
Text.pack String
v) (Function -> [Text]
fnParams Function
fn)] ])
        | (Facts
after, Outcome
o) <- [(Facts, Outcome)]
atExits ]
    atExits :: [(Facts, Outcome)]
atExits =
        [ (Facts
after, Outcome
o)
        | (Node
n, [Edge]
edges) <- CFG -> [(Node, [Edge])]
forall k a. Map k a -> [(k, a)]
Map.toList CFG
cfg
        , (Edge -> Bool) -> [Edge] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Node -> Bool
isExit (Node -> Bool) -> (Edge -> Node) -> Edge -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Edge -> Node
forall a b. (a, b) -> b
snd) [Edge]
edges
        , Just Map (Map String Text) Facts
st <- [Node
-> Map Node (Map (Map String Text) Facts)
-> Maybe (Map (Map String Text) Facts)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Node
n Map Node (Map (Map String Text) Facts)
result]
        , Facts
facts <- Map (Map String Text) Facts -> [Facts]
forall k a. Map k a -> [a]
Map.elems Map (Map String Text) Facts
st
        , let after :: Facts
after = (Facts, [Finding]) -> Facts
forall a b. (a, b) -> a
fst (Node -> Facts -> (Facts, [Finding])
run Node
n Facts
facts)
        , Outcome
o <- case Node
n of
            Node Int
_ (StmtNode (Fix (Return Maybe (Fix (NodeF (Lexeme Text)))
e))) -> Shape -> Maybe (Fix (NodeF (Lexeme Text))) -> [Outcome]
returnOutcomes (Function -> Shape
fnShape Function
fn) Maybe (Fix (NodeF (Lexeme Text)))
e
            Node
_                                  -> [Outcome
Success]
        ]
    isExit :: Node -> Bool
isExit (Node Int
_ NodeKind
ExitNode) = Bool
True
    isExit Node
_                 = Bool
False

firstLexeme :: C.Node (Lexeme Text) -> Maybe (Lexeme Text)
firstLexeme :: Fix (NodeF (Lexeme Text)) -> Maybe (Lexeme Text)
firstLexeme Fix (NodeF (Lexeme Text))
e = case [ Lexeme Text
l | Fix NodeF (Lexeme Text) (Fix (NodeF (Lexeme Text)))
n <- Fix (NodeF (Lexeme Text)) -> [Fix (NodeF (Lexeme Text))]
universe Fix (NodeF (Lexeme Text))
e, Lexeme Text
l <- case NodeF (Lexeme Text) (Fix (NodeF (Lexeme Text)))
n of
                            VarExpr Lexeme Text
l       -> [Lexeme Text
l]
                            LiteralExpr LiteralType
_ Lexeme Text
l -> [Lexeme Text
l]
                            NodeF (Lexeme Text) (Fix (NodeF (Lexeme Text)))
_               -> [] ] of
    Lexeme Text
l : [Lexeme Text]
_ -> Lexeme Text -> Maybe (Lexeme Text)
forall a. a -> Maybe a
Just Lexeme Text
l
    []    -> Maybe (Lexeme Text)
forall a. Maybe a
Nothing

findings :: [(FilePath, [C.Node (Lexeme Text)])] -> [(FilePath, Finding)]
findings :: [(String, [Fix (NodeF (Lexeme Text))])] -> [(String, Finding)]
findings [(String, [Fix (NodeF (Lexeme Text))])]
tus = [ (Function -> String
fnFile Function
f, Finding
x) | Function
f <- [Function]
fns, let ([Finding]
found, Map Outcome (Set Int)
_, Map Outcome (Set Int)
_, Bool
_) = Summary
-> Function
-> ([Finding], Map Outcome (Set Int), Map Outcome (Set Int), Bool)
analyseFunction Summary
summary Function
f, Finding
x <- [Finding]
found ]
  where
    fns :: [Function]
fns = [(String, [Fix (NodeF (Lexeme Text))])] -> [Function]
definitions [(String, [Fix (NodeF (Lexeme Text))])]
tus
    summary :: Summary
summary = [Function] -> Summary
summarise [Function]
fns

analyse :: [(FilePath, [C.Node (Lexeme Text)])] -> [Diagnostic CimplePos]
analyse :: [(String, [Fix (NodeF (Lexeme Text))])] -> [Diagnostic CimplePos]
analyse [(String, [Fix (NodeF (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
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
label] DiagnosticSpan CimplePos
-> [DiagnosticSpan CimplePos] -> [DiagnosticSpan CimplePos]
forall a. a -> [a] -> [a]
: [DiagnosticSpan CimplePos]
others) []
    | (String
file, Finding
finding) <- [(String, [Fix (NodeF (Lexeme Text))])] -> [(String, Finding)]
findings [(String, [Fix (NodeF (Lexeme Text))])]
tus
    , let span' :: p -> Doc AnsiStyle -> DiagnosticSpan pos
span' p
l Doc AnsiStyle
note = let (pos
p, Int
n) = String -> p -> (pos, Int)
forall at pos.
HasDiagnosticInfo at pos =>
String -> at -> (pos, Int)
getDiagnosticInfo String
file p
l in pos -> Int -> [Doc AnsiStyle] -> DiagnosticSpan pos
forall pos. pos -> Int -> [Doc AnsiStyle] -> DiagnosticSpan pos
DiagnosticSpan pos
p Int
n [Doc AnsiStyle
note]
    , (Lexeme Text
here, Doc AnsiStyle
msg, Doc AnsiStyle
label, [DiagnosticSpan CimplePos]
others) <- case Finding
finding of
        LeakedField Lexeme Text
at AccessPath
p AccessPath
q Lexeme Text
got ->
            [ ( Lexeme Text
at
              , Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
backticks (AccessPath -> Doc AnsiStyle
forall ann. AccessPath -> Doc ann
render AccessPath
p) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"is freed while" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
backticks (AccessPath -> Doc AnsiStyle
forall ann. AccessPath -> Doc ann
render AccessPath
q) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"may still hold memory"
              , Doc AnsiStyle
"freed here"
              , [Lexeme Text -> Doc AnsiStyle -> DiagnosticSpan CimplePos
forall {p} {pos}.
HasDiagnosticInfo p pos =>
p -> Doc AnsiStyle -> DiagnosticSpan pos
span' Lexeme Text
got Doc AnsiStyle
"memory stored here"] ) ]
        LeakedLocal Lexeme Text
got String
v Maybe (Lexeme Text)
ret ->
            [ ( Lexeme Text
got
              , Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
backticks (String -> Doc AnsiStyle
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
v) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"may still hold memory when the function returns"
              , Doc AnsiStyle
"memory from here"
              , [ Lexeme Text -> Doc AnsiStyle -> DiagnosticSpan CimplePos
forall {p} {pos}.
HasDiagnosticInfo p pos =>
p -> Doc AnsiStyle -> DiagnosticSpan pos
span' Lexeme Text
r Doc AnsiStyle
"returns here without freeing it" | Just Lexeme Text
r <- [Maybe (Lexeme Text)
ret] ] ) ]
        FreedWhileStored Lexeme Text
at String
v by :: Lexeme Text
by@(L AlexPosn
_ LexemeClass
_ Text
name) ->
            [ ( Lexeme Text
at
              , Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
backticks (String -> Doc AnsiStyle
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
v) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"is freed while" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
backticks (Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
name) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"may still have it stored"
              , Doc AnsiStyle
"freed here"
              , [Lexeme Text -> Doc AnsiStyle -> DiagnosticSpan CimplePos
forall {p} {pos}.
HasDiagnosticInfo p pos =>
p -> Doc AnsiStyle -> DiagnosticSpan pos
span' Lexeme Text
by Doc AnsiStyle
"stored by this call"] ) ]
    , let (CimplePos
pos, Int
len) = String -> Lexeme Text -> (CimplePos, Int)
forall at pos.
HasDiagnosticInfo at pos =>
String -> at -> (pos, Int)
getDiagnosticInfo String
file Lexeme Text
here
    ]

descr :: ([(FilePath, [C.Node (Lexeme Text)])] -> [Diagnostic CimplePos], (Text, Text))
descr :: ([(String, [Fix (NodeF (Lexeme Text))])] -> [Diagnostic CimplePos],
 (Text, Text))
descr = ([(String, [Fix (NodeF (Lexeme Text))])] -> [Diagnostic CimplePos]
analyse, (Text
"memory-lifetime", [Text] -> Text
Text.unlines
    [ Text
"Checks that memory a function gets is freed, returned or handed on before"
    , Text
"it returns, that a field's memory is freed before its struct, and that"
    , Text
"memory is not freed while a call has stored it somewhere that outlives"
    , Text
"the caller."
    , Text
""
    , Text
"**Reason:** memory nothing points to is never freed, as on an error path"
    , Text
"that returns early, and memory freed while still stored is then used or"
    , Text
"freed again through the stored pointer."
    ]))