{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
module Tokstyle.C.Linter.SilentFree (descr) where

import           Control.Monad                 (forM_, unless)
import qualified Data.List                     as List
import           Data.Map.Strict               (Map)
import qualified Data.Map.Strict               as Map
import           Data.Maybe                    (fromMaybe, mapMaybe)
import           Data.Set                      (Set)
import qualified Data.Set                      as Set
import           Data.Text                     (Text)
import qualified Data.Text                     as Text
import           Language.C.Analysis.SemRep    (CompType (..), CompTypeRef (..),
                                                DeclAttrs (..), EnumType (..),
                                                EnumTypeRef (..), FunDef (..),
                                                FunType (..), GlobalDecls (..),
                                                IdentDecl (..), Linkage (..),
                                                MemberDecl (..), ParamDecl (..),
                                                Storage (..), TagDef (..),
                                                Type (..), TypeDef (..),
                                                TypeName (..), VarDecl (..),
                                                VarName (..), declIdent,
                                                declType)
import           Language.C.Analysis.TravMonad (Trav, getUserState)
import           Language.C.Analysis.TypeUtils (canonicalType)
import           Language.C.Data.Ident         (Ident (..), SUERef (..))
import           Language.C.Data.Node          (NodeInfo)
import           Language.C.Syntax.AST
import           Language.C.Syntax.Constants   (getCInteger)
import           Language.Cimple.Diagnostics   (DiagnosticSpan (..))
import           Prettyprinter                 (pretty, (<+>))
import           Tokstyle.Analysis.Dataflow    (Dataflow (..), solve)
import           Tokstyle.C.Analysis.CFG       (CFG, EdgeType (..), Node (..),
                                                NodeKind (..), endsPath,
                                                fromFunDef)
import           Tokstyle.C.Analysis.Syntax    (exprChildren, initExprs, stats)
import           Tokstyle.C.Env                (DiagnosticLevel (..), Env,
                                                localsOf, posAndLen,
                                                recordRichError)
import           Tokstyle.C.TravUtils          (backticks)


-- | Functions that free the object their argument at this position points to.
freers :: [(String, Int)]
freers :: [(String, Int)]
freers = [(String
"free", Int
0), (String
"mem_delete", Int
1)]

allocators :: [String]
allocators :: [String]
allocators = [String
"malloc", String
"calloc", String
"realloc", String
"mem_alloc", String
"mem_balloc", String
"mem_valloc", String
"mem_vrealloc", String
"mem_brealloc"]

-- | Where an object gets freed: the calls it goes through, from the one in
-- the function at hand to the one that frees it.
type Site = [(NodeInfo, String)]

-- | What is known about the functions of the translation unit.
data Summary = Summary
    { Summary -> Map String (Set Int)
notifies :: Map String (Set Int)
    -- ^ The parameters each function passes to a callback on every path.
    , Summary -> Map String (Map Int Site)
frees    :: Map String (Map Int Site)
    -- ^ The parameters each function may free before passing them to a
    -- callback.
    } deriving (Summary -> Summary -> Bool
(Summary -> Summary -> Bool)
-> (Summary -> Summary -> Bool) -> Eq Summary
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Summary -> Summary -> Bool
== :: Summary -> Summary -> Bool
$c/= :: Summary -> Summary -> Bool
/= :: Summary -> Summary -> Bool
Eq)

data Effect
    = Notify String
    | Free String Site

name :: Ident -> String
name :: Ident -> String
name (Ident String
n Int
_ NodeInfo
_) = String
n

argVar :: CExpr -> Maybe String
argVar :: CExpr -> Maybe String
argVar = \case
    CVar Ident
i NodeInfo
_    -> String -> Maybe String
forall a. a -> Maybe a
Just (Ident -> String
name Ident
i)
    CCast CDeclaration NodeInfo
_ CExpr
e NodeInfo
_ -> CExpr -> Maybe String
argVar CExpr
e
    CExpr
_           -> Maybe String
forall a. Maybe a
Nothing

pointee :: Type -> Maybe String
pointee :: Type -> Maybe String
pointee Type
ty = case Type -> Type
canonicalType Type
ty of
    PtrType Type
t TypeQuals
_ Attributes
_ -> case Type -> Type
canonicalType Type
t of
        DirectType (TyComp (CompTypeRef (NamedRef Ident
i) CompTyKind
_ NodeInfo
_)) TypeQuals
_ Attributes
_ -> String -> Maybe String
forall a. a -> Maybe a
Just (Ident -> String
name Ident
i)
        Type
_                                                      -> Maybe String
forall a. Maybe a
Nothing
    Type
_ -> Maybe String
forall a. Maybe a
Nothing

structMembers :: GlobalDecls -> Map String [(String, Type)]
structMembers :: GlobalDecls -> Map String [(String, Type)]
structMembers (GlobalDecls Map Ident IdentDecl
_ Map SUERef TagDef
tags Map Ident TypeDef
_) = [(String, [(String, Type)])] -> Map String [(String, Type)]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Ident -> String
name Ident
i, [ (Ident -> String
name Ident
m, Type
t) | MemberDecl (VarDecl (VarName Ident
m Maybe AsmName
_) DeclAttrs
_ Type
t) Maybe CExpr
_ NodeInfo
_ <- [MemberDecl]
ms ])
    | (NamedRef Ident
i, CompDef (CompType SUERef
_ CompTyKind
_ [MemberDecl]
ms Attributes
_ NodeInfo
_)) <- Map SUERef TagDef -> [(SUERef, TagDef)]
forall k a. Map k a -> [(k, a)]
Map.toList Map SUERef TagDef
tags ]

-- | The structs that callbacks take pointers to and that have a @void *@
-- member pointing back to the object's owner. The owner may keep a pointer to
-- the object, so it must hear when the object goes.
exposedStructs :: GlobalDecls -> Set String
exposedStructs :: GlobalDecls -> Set String
exposedStructs decls :: GlobalDecls
decls@(GlobalDecls Map Ident IdentDecl
_ Map SUERef TagDef
_ Map Ident TypeDef
typedefs) =
    (String -> Bool) -> Set String -> Set String
forall a. (a -> Bool) -> Set a -> Set a
Set.filter String -> Bool
backRef (Set String -> Set String)
-> ([Type] -> Set String) -> [Type] -> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList ([String] -> Set String)
-> ([Type] -> [String]) -> [Type] -> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> [String]) -> [Type] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Type -> [String]
callbackParams ([Type] -> Set String) -> [Type] -> Set String
forall a b. (a -> b) -> a -> b
$ [Type]
memberTypes [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
typedefTypes
  where
    members :: Map String [(String, Type)]
members = GlobalDecls -> Map String [(String, Type)]
structMembers GlobalDecls
decls
    memberTypes :: [Type]
memberTypes = ([(String, Type)] -> [Type]) -> [[(String, Type)]] -> [Type]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((String, Type) -> Type) -> [(String, Type)] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (String, Type) -> Type
forall a b. (a, b) -> b
snd) (Map String [(String, Type)] -> [[(String, Type)]]
forall k a. Map k a -> [a]
Map.elems Map String [(String, Type)]
members)
    backRef :: String -> Bool
backRef String
s = ((String, Type) -> Bool) -> [(String, Type)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> Bool
isVoidPtr (Type -> Bool)
-> ((String, Type) -> Type) -> (String, Type) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Type) -> Type
forall a b. (a, b) -> b
snd) ([(String, Type)]
-> String -> Map String [(String, Type)] -> [(String, Type)]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] String
s Map String [(String, Type)]
members)
    isVoidPtr :: Type -> Bool
isVoidPtr Type
t = case Type -> Type
canonicalType Type
t of
        PtrType (DirectType TypeName
TyVoid TypeQuals
_ Attributes
_) TypeQuals
_ Attributes
_ -> Bool
True
        Type
_                                   -> Bool
False
    typedefTypes :: [Type]
typedefTypes = [ Type
t | TypeDef Ident
_ Type
t Attributes
_ NodeInfo
_ <- Map Ident TypeDef -> [TypeDef]
forall k a. Map k a -> [a]
Map.elems Map Ident TypeDef
typedefs ]
    -- 'canonicalType' takes a function type to a pointer to it.
    callbackParams :: Type -> [String]
callbackParams Type
t = case Type -> Type
canonicalType Type
t of
        PtrType (FunctionType (FunType Type
_ [ParamDecl]
ps Bool
_) Attributes
_) TypeQuals
_ Attributes
_ -> (Type -> Maybe String) -> [Type] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Type -> Maybe String
pointee [ Type
pt | ParamDecl (VarDecl VarName
_ DeclAttrs
_ Type
pt) NodeInfo
_ <- [ParamDecl]
ps ]
        Type
_                                             -> []

-- | The effects of an expression, in the order it has them. A callback only
-- counts where the expression always calls it.
exprEffects :: Summary -> Bool -> CExpr -> [Effect]
exprEffects :: Summary -> Bool -> CExpr -> [Effect]
exprEffects Summary
summary Bool
always = \case
    CCall CExpr
f [CExpr]
args NodeInfo
ni ->
        (CExpr -> [Effect]) -> [CExpr] -> [Effect]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Summary -> Bool -> CExpr -> [Effect]
exprEffects Summary
summary Bool
always) [CExpr]
args [Effect] -> [Effect] -> [Effect]
forall a. [a] -> [a] -> [a]
++ CExpr -> [CExpr] -> NodeInfo -> [Effect]
forall {a}. CExpression a -> [CExpr] -> NodeInfo -> [Effect]
callEffects CExpr
f [CExpr]
args NodeInfo
ni
    CCond CExpr
c Maybe CExpr
t CExpr
e NodeInfo
_ ->
        Summary -> Bool -> CExpr -> [Effect]
exprEffects Summary
summary Bool
always CExpr
c [Effect] -> [Effect] -> [Effect]
forall a. [a] -> [a] -> [a]
++ (CExpr -> [Effect]) -> [CExpr] -> [Effect]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Summary -> Bool -> CExpr -> [Effect]
exprEffects Summary
summary Bool
False) ([CExpr] -> (CExpr -> [CExpr]) -> Maybe CExpr -> [CExpr]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] CExpr -> [CExpr]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CExpr
t [CExpr] -> [CExpr] -> [CExpr]
forall a. [a] -> [a] -> [a]
++ [CExpr
e])
    CBinary CBinaryOp
op CExpr
l CExpr
r NodeInfo
_ | CBinaryOp
op CBinaryOp -> [CBinaryOp] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CBinaryOp
CLndOp, CBinaryOp
CLorOp] ->
        Summary -> Bool -> CExpr -> [Effect]
exprEffects Summary
summary Bool
always CExpr
l [Effect] -> [Effect] -> [Effect]
forall a. [a] -> [a] -> [a]
++ Summary -> Bool -> CExpr -> [Effect]
exprEffects Summary
summary Bool
False CExpr
r
    CAssign CAssignOp
CAssignOp CExpr
l CExpr
r NodeInfo
_ | Just String
v <- CExpr -> Maybe String
argVar CExpr
l, CExpr -> Bool
isFresh CExpr
r ->
        Summary -> Bool -> CExpr -> [Effect]
exprEffects Summary
summary Bool
always CExpr
r [Effect] -> [Effect] -> [Effect]
forall a. [a] -> [a] -> [a]
++ [String -> Effect
Notify String
v]
    CSizeofExpr{} -> []
    CExpr
e -> (CExpr -> [Effect]) -> [CExpr] -> [Effect]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Summary -> Bool -> CExpr -> [Effect]
exprEffects Summary
summary Bool
always) (CExpr -> [CExpr]
exprChildren CExpr
e)
  where
    callEffects :: CExpression a -> [CExpr] -> NodeInfo -> [Effect]
callEffects (CVar Ident
f a
_) [CExpr]
args NodeInfo
ni =
        let fn :: String
fn = Ident -> String
name Ident
f
            vars :: [(Int, Maybe String)]
vars = [Int] -> [Maybe String] -> [(Int, Maybe String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] ((CExpr -> Maybe String) -> [CExpr] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map CExpr -> Maybe String
argVar [CExpr]
args)
            freed :: [Effect]
freed = [ String -> Site -> Effect
Free String
v [(NodeInfo
ni, String
fn)] | Just Int
i <- [String -> [(String, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
fn [(String, Int)]
freers], Just (Just String
v) <- [Int -> [(Int, Maybe String)] -> Maybe (Maybe String)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
i [(Int, Maybe String)]
vars] ]
                 [Effect] -> [Effect] -> [Effect]
forall a. [a] -> [a] -> [a]
++ [ String -> Site -> Effect
Free String
v ((NodeInfo
ni, String
fn) (NodeInfo, String) -> Site -> Site
forall a. a -> [a] -> [a]
: Site
site)
                    | (Int
i, Site
site) <- Map Int Site -> [(Int, Site)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Int Site -> String -> Map String (Map Int Site) -> Map Int Site
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map Int Site
forall k a. Map k a
Map.empty String
fn (Summary -> Map String (Map Int Site)
frees Summary
summary))
                    , Just (Just String
v) <- [Int -> [(Int, Maybe String)] -> Maybe (Maybe String)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
i [(Int, Maybe String)]
vars] ]
            told :: [Effect]
told = [ String -> Effect
Notify String
v | Bool
always, Int
i <- Set Int -> [Int]
forall a. Set a -> [a]
Set.toList (Set Int -> String -> Map String (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 String
fn (Summary -> Map String (Set Int)
notifies Summary
summary)), Just (Just String
v) <- [Int -> [(Int, Maybe String)] -> Maybe (Maybe String)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
i [(Int, Maybe String)]
vars] ]
        in [Effect]
told [Effect] -> [Effect] -> [Effect]
forall a. [a] -> [a] -> [a]
++ [Effect]
freed
    -- A call through a pointer is a callback.
    callEffects CExpression a
_ [CExpr]
args NodeInfo
_ = [ String -> Effect
Notify String
v | Bool
always, Just String
v <- (CExpr -> Maybe String) -> [CExpr] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map CExpr -> Maybe String
argVar [CExpr]
args ]

-- | Whether an expression gets a new object, or none.
isFresh :: CExpr -> Bool
isFresh :: CExpr -> Bool
isFresh = \case
    CCall (CVar Ident
f NodeInfo
_) [CExpr]
_ NodeInfo
_   -> Ident -> String
name Ident
f String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
allocators
    CVar Ident
i NodeInfo
_               -> Ident -> String
name Ident
i String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"nullptr", String
"NULL"]
    CConst (CIntConst CInteger
i NodeInfo
_) -> CInteger -> Integer
getCInteger CInteger
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0
    CCast CDeclaration NodeInfo
_ CExpr
e NodeInfo
_            -> CExpr -> Bool
isFresh CExpr
e
    CExpr
_                      -> Bool
False

declItems :: CDecl -> [(String, Maybe CInit)]
declItems :: CDeclaration NodeInfo -> [(String, Maybe CInit)]
declItems = \case
    CDecl [CDeclarationSpecifier NodeInfo]
_ [(Maybe (CDeclarator NodeInfo), Maybe CInit, Maybe CExpr)]
ds NodeInfo
_ -> [ (Ident -> String
name Ident
i, Maybe CInit
ini) | (Just (CDeclr (Just Ident
i) [CDerivedDeclarator NodeInfo]
_ Maybe AsmName
_ [CAttribute NodeInfo]
_ NodeInfo
_), Maybe CInit
ini, Maybe CExpr
_) <- [(Maybe (CDeclarator NodeInfo), Maybe CInit, Maybe CExpr)]
ds ]
    CDeclaration NodeInfo
_            -> []

-- | A local made from a new object, or none, counts as passed to a callback:
-- nothing outside the function can know of it yet.
nodeEffects :: Summary -> Node -> [Effect]
nodeEffects :: Summary -> Node -> [Effect]
nodeEffects Summary
summary n :: Node
n@(Node Int
_ NodeKind
kind) = (CExpr -> [Effect]) -> [CExpr] -> [Effect]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Summary -> Bool -> CExpr -> [Effect]
exprEffects Summary
summary Bool
True) (Node -> [CExpr]
nodeExprs Node
n) [Effect] -> [Effect] -> [Effect]
forall a. [a] -> [a] -> [a]
++ case NodeKind
kind of
    DeclNode CDeclaration NodeInfo
d -> [ String -> Effect
Notify String
v | (String
v, Just (CInitExpr CExpr
e NodeInfo
_)) <- CDeclaration NodeInfo -> [(String, Maybe CInit)]
declItems CDeclaration NodeInfo
d, CExpr -> Bool
isFresh CExpr
e ]
    NodeKind
_          -> []

nodeExprs :: Node -> [CExpr]
nodeExprs :: Node -> [CExpr]
nodeExprs (Node Int
_ NodeKind
kind) = case NodeKind
kind of
    StatNode (CExpr Maybe CExpr
e NodeInfo
_)   -> [CExpr] -> (CExpr -> [CExpr]) -> Maybe CExpr -> [CExpr]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] CExpr -> [CExpr]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CExpr
e
    StatNode (CReturn Maybe CExpr
e NodeInfo
_) -> [CExpr] -> (CExpr -> [CExpr]) -> Maybe CExpr -> [CExpr]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] CExpr -> [CExpr]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CExpr
e
    ExprNode CExpr
e             -> [CExpr
e]
    BranchNode CExpr
e           -> [CExpr
e]
    DeclNode CDeclaration NodeInfo
d             -> ((String, Maybe CInit) -> [CExpr])
-> [(String, Maybe CInit)] -> [CExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([CExpr] -> (CInit -> [CExpr]) -> Maybe CInit -> [CExpr]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] CInit -> [CExpr]
initExprs (Maybe CInit -> [CExpr])
-> ((String, Maybe CInit) -> Maybe CInit)
-> (String, Maybe CInit)
-> [CExpr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Maybe CInit) -> Maybe CInit
forall a b. (a, b) -> b
snd) (CDeclaration NodeInfo -> [(String, Maybe CInit)]
declItems CDeclaration NodeInfo
d)
    NodeKind
_                      -> []

-- | What a function does to the pointers to exposed objects it has.
data Findings = Findings
    { Findings -> Set String
toldAtExit  :: Set String
    , Findings -> [(String, Site)]
freedUntold :: [(String, Site)]
    }

analyseFunction :: Summary -> Set NodeInfo -> Set String -> FunDef -> Findings
analyseFunction :: Summary -> Set NodeInfo -> Set String -> FunDef -> Findings
analyseFunction Summary
summary Set NodeInfo
exhaustive Set String
tracked FunDef
fd =
    Findings
        { toldAtExit :: Set String
toldAtExit = Set String -> Maybe (Set String) -> Set String
forall a. a -> Maybe a -> a
fromMaybe Set String
forall a. Set a
Set.empty (Maybe (Set String)
-> Node -> Map Node (Maybe (Set String)) -> Maybe (Set String)
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Maybe (Set String)
forall a. Maybe a
Nothing Node
exit Map Node (Maybe (Set String))
told)
        , freedUntold :: [(String, Site)]
freedUntold = [[(String, Site)]] -> [(String, Site)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ Set String -> [Effect] -> [(String, Site)]
untold Set String
s (Node -> [Effect]
effects Node
n)
            | (Node
n, Just Set String
s) <- Map Node (Maybe (Set String)) -> [(Node, Maybe (Set String))]
forall k a. Map k a -> [(k, a)]
Map.toList Map Node (Maybe (Set String))
told, Bool -> Bool
not (Node -> Bool
endsPath Node
n) ]
        }
  where
    (Node
entry, CFG
cfg) = FunDef -> (Node, CFG)
fromFunDef FunDef
fd
    nodes :: [Node]
nodes = Set Node -> [Node]
forall a. Set a -> [a]
Set.toList (Set Node -> [Node]) -> ([Node] -> Set Node) -> [Node] -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node] -> Set Node
forall a. Ord a => [a] -> Set a
Set.fromList ([Node] -> [Node]) -> [Node] -> [Node]
forall a b. (a -> b) -> a -> b
$ CFG -> [Node]
forall k a. Map k a -> [k]
Map.keys CFG
cfg [Node] -> [Node] -> [Node]
forall a. [a] -> [a] -> [a]
++ [ Node
n | [Edge]
es <- CFG -> [[Edge]]
forall k a. Map k a -> [a]
Map.elems CFG
cfg, (EdgeType
_, Node
n) <- [Edge]
es ]
    exit :: Node
exit = case [ Node
n | n :: Node
n@(Node Int
_ NodeKind
ExitNode) <- [Node]
nodes ] of
        (Node
n : [Node]
_) -> Node
n
        []      -> Node
entry
    effects :: Node -> [Effect]
effects Node
n = (Effect -> Bool) -> [Effect] -> [Effect]
forall a. (a -> Bool) -> [a] -> [a]
filter Effect -> Bool
relevant (Summary -> Node -> [Effect]
nodeEffects Summary
summary Node
n)
    relevant :: Effect -> Bool
relevant = \case
        Notify String
v -> String
v String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
tracked
        Free String
v Site
_ -> String
v String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
tracked
    -- The variables passed to a callback on every path to a node, or
    -- 'Nothing' where no path reaches it.
    told :: Map Node (Maybe (Set String))
    told :: Map Node (Maybe (Set String))
told = Node
-> CFG
-> Dataflow Node EdgeType (Maybe (Set String))
-> Map Node (Maybe (Set String))
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 :: CFG) Dataflow Node EdgeType (Maybe (Set String))
problem
    apply :: Set String -> Effect -> Set String
apply Set String
s = \case
        Notify String
v -> String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.insert String
v Set String
s
        Free String
_ Site
_ -> Set String
s
    problem :: Dataflow Node EdgeType (Maybe (Set String))
problem = Dataflow
        { transfer :: Node -> Maybe (Set String) -> Maybe (Set String)
transfer     = \Node
n Maybe (Set String)
s -> if Node -> Bool
endsPath Node
n then Maybe (Set String)
forall a. Maybe a
Nothing else (\Set String
t -> (Set String -> Effect -> Set String)
-> Set String -> [Effect] -> Set String
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 String -> Effect -> Set String
apply Set String
t (Node -> [Effect]
effects Node
n)) (Set String -> Set String)
-> Maybe (Set String) -> Maybe (Set String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Set String)
s
        , edgeTransfer :: Node -> EdgeType -> Maybe (Set String) -> Maybe (Set String)
edgeTransfer = \Node
n EdgeType
e Maybe (Set String)
s -> case (Node
n, EdgeType
e) of
            (Node Int
_ (BranchNode CExpr
c), EdgeType
DefaultBranch) | CExpr -> NodeInfo
forall a. CExpression a -> a
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation CExpr
c NodeInfo -> Set NodeInfo -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set NodeInfo
exhaustive -> Maybe (Set String)
forall a. Maybe a
Nothing
            (Node, EdgeType)
_ -> Maybe (Set String)
s
        , merge :: Maybe (Set String) -> Maybe (Set String) -> Maybe (Set String)
merge        = \Maybe (Set String)
a Maybe (Set String)
b -> case (Maybe (Set String)
a, Maybe (Set String)
b) of
            (Maybe (Set String)
Nothing, Maybe (Set String)
_)     -> Maybe (Set String)
b
            (Maybe (Set String)
_, Maybe (Set String)
Nothing)     -> Maybe (Set String)
a
            (Just Set String
x, Just Set String
y) -> Set String -> Maybe (Set String)
forall a. a -> Maybe a
Just (Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set String
x Set String
y)
        , initial :: Maybe (Set String)
initial      = Set String -> Maybe (Set String)
forall a. a -> Maybe a
Just Set String
forall a. Set a
Set.empty
        }
    untold :: Set String -> [Effect] -> [(String, Site)]
untold Set String
s0 = Set String -> [Effect] -> [(String, Site)]
go Set String
s0
      where
        go :: Set String -> [Effect] -> [(String, Site)]
go Set String
_ [] = []
        go Set String
s (Notify String
v : [Effect]
es) = Set String -> [Effect] -> [(String, Site)]
go (String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.insert String
v Set String
s) [Effect]
es
        go Set String
s (Free String
v Site
site : [Effect]
es)
            | String
v String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
s = Set String -> [Effect] -> [(String, Site)]
go Set String
s [Effect]
es
            | Bool
otherwise = (String
v, Site
site) (String, Site) -> [(String, Site)] -> [(String, Site)]
forall a. a -> [a] -> [a]
: Set String -> [Effect] -> [(String, Site)]
go Set String
s [Effect]
es

data Function = Function
    { Function -> String
fnName       :: String
    , Function -> FunDef
fnDef        :: FunDef
    , Function -> Bool
fnStatic     :: Bool
    , Function -> [String]
fnParams     :: [String]
    , Function -> Set String
fnTracked    :: Set String
    -- ^ Its pointers to exposed objects.
    , Function -> Set NodeInfo
fnExhaustive :: Set NodeInfo
    -- ^ The conditions of the switches without a @default@ that have a case
    -- for every value of their enum, so that leaving them unmatched is not a
    -- path.
    }

functionsOf :: Set String -> Map String [IdentDecl] -> GlobalDecls -> [Function]
functionsOf :: Set String -> Map String [IdentDecl] -> GlobalDecls -> [Function]
functionsOf Set String
exposed Map String [IdentDecl]
locals GlobalDecls
decls =
    [ String
-> FunDef
-> Bool
-> [String]
-> Set String
-> Set NodeInfo
-> Function
Function String
fn FunDef
fd (Storage -> Bool
isStatic Storage
storage) [String]
ps Set String
tracked (GlobalDecls
-> Map String Type -> CStatement NodeInfo -> Set NodeInfo
exhaustiveSwitches GlobalDecls
decls ([(String, Type)] -> Map String Type
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(String, Type)]
paramDecls [(String, Type)] -> [(String, Type)] -> [(String, Type)]
forall a. [a] -> [a] -> [a]
++ [(String, Type)]
localTys)) CStatement NodeInfo
body)
    | FunctionDef fd :: FunDef
fd@(FunDef (VarDecl (VarName Ident
i Maybe AsmName
_) (DeclAttrs FunctionAttrs
_ Storage
storage Attributes
_) Type
ty) CStatement NodeInfo
body NodeInfo
_) <- Map Ident IdentDecl -> [IdentDecl]
forall k a. Map k a -> [a]
Map.elems (GlobalDecls -> Map Ident IdentDecl
gObjs GlobalDecls
decls)
    , let fn :: String
fn = Ident -> String
name Ident
i
          paramDecls :: [(String, Type)]
paramDecls = case Type
ty of
              FunctionType (FunType Type
_ [ParamDecl]
pds Bool
_) Attributes
_ -> [ (Ident -> String
name Ident
pi', Type
pt) | ParamDecl (VarDecl (VarName Ident
pi' Maybe AsmName
_) DeclAttrs
_ Type
pt) NodeInfo
_ <- [ParamDecl]
pds ]
              Type
_ -> []
          ps :: [String]
ps = ((String, Type) -> String) -> [(String, Type)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Type) -> String
forall a b. (a, b) -> a
fst [(String, Type)]
paramDecls
          localTys :: [(String, Type)]
localTys = [ (Ident -> String
name (IdentDecl -> Ident
forall n. Declaration n => n -> Ident
declIdent IdentDecl
d), IdentDecl -> Type
forall n. Declaration n => n -> Type
declType IdentDecl
d) | IdentDecl
d <- [IdentDecl] -> String -> Map String [IdentDecl] -> [IdentDecl]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] String
fn Map String [IdentDecl]
locals ]
          tracked :: Set String
tracked = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [ String
v | (String
v, Type
t) <- [(String, Type)]
paramDecls [(String, Type)] -> [(String, Type)] -> [(String, Type)]
forall a. [a] -> [a] -> [a]
++ [(String, Type)]
localTys, Just String
s <- [Type -> Maybe String
pointee Type
t], String
s String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
exposed ]
    ]
  where
    isStatic :: Storage -> Bool
isStatic = \case
        FunLinkage Linkage
InternalLinkage -> Bool
True
        Static Linkage
InternalLinkage Bool
_   -> Bool
True
        Storage
_                          -> Bool
False

data Label = Case | Default
    deriving (Label -> Label -> Bool
(Label -> Label -> Bool) -> (Label -> Label -> Bool) -> Eq Label
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Label -> Label -> Bool
== :: Label -> Label -> Bool
$c/= :: Label -> Label -> Bool
/= :: Label -> Label -> Bool
Eq)

enumSizes :: GlobalDecls -> Map SUERef Int
enumSizes :: GlobalDecls -> Map SUERef Int
enumSizes (GlobalDecls Map Ident IdentDecl
_ Map SUERef TagDef
tags Map Ident TypeDef
_) = [(SUERef, Int)] -> Map SUERef Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (SUERef
r, [Enumerator] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Enumerator]
es) | (SUERef
r, EnumDef (EnumType SUERef
_ [Enumerator]
es Attributes
_ NodeInfo
_)) <- Map SUERef TagDef -> [(SUERef, TagDef)]
forall k a. Map k a -> [(k, a)]
Map.toList Map SUERef TagDef
tags ]

exhaustiveSwitches :: GlobalDecls -> Map String Type -> CStat -> Set NodeInfo
exhaustiveSwitches :: GlobalDecls
-> Map String Type -> CStatement NodeInfo -> Set NodeInfo
exhaustiveSwitches GlobalDecls
decls Map String Type
vars CStatement NodeInfo
body = [NodeInfo] -> Set NodeInfo
forall a. Ord a => [a] -> Set a
Set.fromList
    [ CExpr -> NodeInfo
forall a. CExpression a -> a
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation CExpr
c
    | CSwitch CExpr
c CStatement NodeInfo
s NodeInfo
_ <- CStatement NodeInfo -> [CStatement NodeInfo]
stats CStatement NodeInfo
body
    , Bool -> Bool
not (CStatement NodeInfo -> Bool
forall {a}. CStatement a -> Bool
hasDefault CStatement NodeInfo
s)
    , Just (DirectType (TyEnum (EnumTypeRef SUERef
r NodeInfo
_)) TypeQuals
_ Attributes
_) <- [Type -> Type
canonicalType (Type -> Type) -> Maybe Type -> Maybe Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CExpr -> Maybe Type
forall {a}. CExpression a -> Maybe Type
typeOf CExpr
c]
    , Just Int
n <- [SUERef -> Map SUERef Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SUERef
r (GlobalDecls -> Map SUERef Int
enumSizes GlobalDecls
decls)]
    , CStatement NodeInfo -> Int
forall {a}. CStatement a -> Int
caseCount CStatement NodeInfo
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n ]
  where
    members :: Map String [(String, Type)]
members = GlobalDecls -> Map String [(String, Type)]
structMembers GlobalDecls
decls
    typeOf :: CExpression a -> Maybe Type
typeOf = \case
        CVar Ident
i a
_ -> String -> Map String Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Ident -> String
name Ident
i) Map String Type
vars
        CMember CExpression a
e Ident
m Bool
arrow a
_ -> do
            Type
t <- CExpression a -> Maybe Type
typeOf CExpression a
e
            String
s <- if Bool
arrow then Type -> Maybe String
pointee Type
t else Type -> Maybe String
direct Type
t
            String -> [(String, Type)] -> Maybe Type
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Ident -> String
name Ident
m) ([(String, Type)] -> Maybe Type)
-> Maybe [(String, Type)] -> Maybe Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Map String [(String, Type)] -> Maybe [(String, Type)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
s Map String [(String, Type)]
members
        CExpression a
_ -> Maybe Type
forall a. Maybe a
Nothing
    direct :: Type -> Maybe String
direct Type
t = case Type -> Type
canonicalType Type
t of
        DirectType (TyComp (CompTypeRef (NamedRef Ident
i) CompTyKind
_ NodeInfo
_)) TypeQuals
_ Attributes
_ -> String -> Maybe String
forall a. a -> Maybe a
Just (Ident -> String
name Ident
i)
        Type
_                                                      -> Maybe String
forall a. Maybe a
Nothing
    -- The labels of a switch body, not counting those of nested switches.
    labels :: CStatement a -> [Label]
labels = \case
        CCase CExpression a
_ CStatement a
t a
_         -> Label
Case Label -> [Label] -> [Label]
forall a. a -> [a] -> [a]
: CStatement a -> [Label]
labels CStatement a
t
        CDefault CStatement a
t a
_        -> Label
Default Label -> [Label] -> [Label]
forall a. a -> [a] -> [a]
: CStatement a -> [Label]
labels CStatement a
t
        CLabel Ident
_ CStatement a
t [CAttribute a]
_ a
_      -> CStatement a -> [Label]
labels CStatement a
t
        CCompound [Ident]
_ [CCompoundBlockItem a]
items a
_ -> [[Label]] -> [Label]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ CStatement a -> [Label]
labels CStatement a
t | CBlockStmt CStatement a
t <- [CCompoundBlockItem a]
items ]
        CIf CExpression a
_ CStatement a
t Maybe (CStatement a)
e a
_         -> CStatement a -> [Label]
labels CStatement a
t [Label] -> [Label] -> [Label]
forall a. [a] -> [a] -> [a]
++ [Label]
-> (CStatement a -> [Label]) -> Maybe (CStatement a) -> [Label]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] CStatement a -> [Label]
labels Maybe (CStatement a)
e
        CWhile CExpression a
_ CStatement a
t Bool
_ a
_      -> CStatement a -> [Label]
labels CStatement a
t
        CFor Either (Maybe (CExpression a)) (CDeclaration a)
_ Maybe (CExpression a)
_ Maybe (CExpression a)
_ CStatement a
t a
_      -> CStatement a -> [Label]
labels CStatement a
t
        CStatement a
_                   -> []
    hasDefault :: CStatement a -> Bool
hasDefault = Label -> [Label] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Label
Default ([Label] -> Bool)
-> (CStatement a -> [Label]) -> CStatement a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CStatement a -> [Label]
forall {a}. CStatement a -> [Label]
labels
    caseCount :: CStatement a -> Int
caseCount = [Label] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Label] -> Int)
-> (CStatement a -> [Label]) -> CStatement a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CStatement a -> [Label]
forall {a}. CStatement a -> [Label]
labels

summarise :: [Function] -> Summary
summarise :: [Function] -> Summary
summarise [Function]
fns = Summary -> Int -> Summary
forall {t}. (Eq t, Num t) => Summary -> t -> Summary
go (Map String (Set Int) -> Map String (Map Int Site) -> Summary
Summary Map String (Set Int)
forall k a. Map k a
Map.empty Map String (Map Int Site)
forall k a. Map k a
Map.empty) ([Function] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Function]
fns Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2 :: Int)
  where
    go :: Summary -> t -> Summary
go Summary
s t
0 = Summary
s
    go Summary
s t
k =
        let s' :: Summary
s' = Summary
                { notifies :: Map String (Set Int)
notifies = [(String, Set Int)] -> Map String (Set Int)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                    [ (Function -> String
fnName Function
f, [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList [ Int
i | (Int
i, String
p) <- [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] (Function -> [String]
fnParams Function
f), String
p String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Findings -> Set String
toldAtExit Findings
r ])
                    | (Function
f, Findings
r) <- Summary -> [(Function, Findings)]
results Summary
s ]
                , frees :: Map String (Map Int Site)
frees = [(String, Map Int Site)] -> Map String (Map Int Site)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                    [ (Function -> String
fnName Function
f, [(Int, Site)] -> Map Int Site
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Int
i, Site
site) | (String
v, Site
site) <- [(String, Site)] -> [(String, Site)]
forall a. [a] -> [a]
reverse (Findings -> [(String, Site)]
freedUntold Findings
r), Just Int
i <- [String -> [String] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
List.elemIndex String
v (Function -> [String]
fnParams Function
f)] ])
                    | (Function
f, Findings
r) <- Summary -> [(Function, Findings)]
results Summary
s, Function -> Bool
fnStatic Function
f ]
                }
        in if Summary
s' Summary -> Summary -> Bool
forall a. Eq a => a -> a -> Bool
== Summary
s then Summary
s else Summary -> t -> Summary
go Summary
s' (t
k t -> t -> t
forall a. Num a => a -> a -> a
- t
1)
    results :: Summary -> [(Function, Findings)]
results Summary
s = [ (Function
f, Summary -> Set NodeInfo -> Set String -> FunDef -> Findings
analyseFunction Summary
s (Function -> Set NodeInfo
fnExhaustive Function
f) (Function -> Set String
fnTracked Function
f) (Function -> FunDef
fnDef Function
f)) | Function
f <- [Function]
fns ]

analyse :: GlobalDecls -> Trav Env ()
analyse :: GlobalDecls -> Trav Env ()
analyse GlobalDecls
decls = do
    Env
env <- Trav Env Env
forall s. Trav s s
getUserState
    let exposed :: Set String
exposed = GlobalDecls -> Set String
exposedStructs GlobalDecls
decls
        fns :: [Function]
fns = Set String -> Map String [IdentDecl] -> GlobalDecls -> [Function]
functionsOf Set String
exposed (Env -> Map String [IdentDecl]
localsOf Env
env) GlobalDecls
decls
        summary :: Summary
summary = [Function] -> Summary
summarise [Function]
fns
    Bool -> Trav Env () -> Trav Env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Set String -> Bool
forall a. Set a -> Bool
Set.null Set String
exposed) (Trav Env () -> Trav Env ()) -> Trav Env () -> Trav Env ()
forall a b. (a -> b) -> a -> b
$ [Function] -> (Function -> Trav Env ()) -> Trav Env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Function]
fns ((Function -> Trav Env ()) -> Trav Env ())
-> (Function -> Trav Env ()) -> Trav Env ()
forall a b. (a -> b) -> a -> b
$ \Function
f -> do
        let r :: Findings
r = Summary -> Set NodeInfo -> Set String -> FunDef -> Findings
analyseFunction Summary
summary (Function -> Set NodeInfo
fnExhaustive Function
f) (Function -> Set String
fnTracked Function
f) (Function -> FunDef
fnDef Function
f)
            -- A function that frees its own parameters is a destructor, and
            -- its caller knows they go.
            destructor :: Bool
destructor = ((String, Site) -> Bool) -> [(String, Site)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Function -> [String]
fnParams Function
f) (String -> Bool)
-> ((String, Site) -> String) -> (String, Site) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Site) -> String
forall a b. (a, b) -> a
fst)
                (Findings -> [(String, Site)]
freedUntold (Summary -> Set NodeInfo -> Set String -> FunDef -> Findings
analyseFunction Summary
summary (Function -> Set NodeInfo
fnExhaustive Function
f) ([String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList (Function -> [String]
fnParams Function
f)) (Function -> FunDef
fnDef Function
f)))
        Bool -> Trav Env () -> Trav Env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
destructor (Trav Env () -> Trav Env ()) -> Trav Env () -> Trav Env ()
forall a b. (a -> b) -> a -> b
$ [(String, Site)] -> ((String, Site) -> Trav Env ()) -> Trav Env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Findings -> [(String, Site)]
freedUntold Findings
r) (((String, Site) -> Trav Env ()) -> Trav Env ())
-> ((String, Site) -> Trav Env ()) -> Trav Env ()
forall a b. (a -> b) -> a -> b
$ \(String
v, Site
site) ->
            Bool -> Trav Env () -> Trav Env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (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]
fnParams Function
f) (Trav Env () -> Trav Env ()) -> Trav Env () -> Trav Env ()
forall a b. (a -> b) -> a -> b
$ String -> String -> Site -> Trav Env ()
report (Function -> String
fnName Function
f) String
v Site
site

report :: String -> String -> Site -> Trav Env ()
report :: String -> String -> Site -> Trav Env ()
report String
fn String
v = \case
    [] -> () -> Trav Env ()
forall a. a -> TravT Env Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (NodeInfo
at, String
callee) : Site
deeper ->
        NodeInfo
-> DiagnosticLevel
-> Doc AnsiStyle
-> [DiagnosticSpan Position]
-> [(DiagnosticLevel, Doc AnsiStyle)]
-> Trav Env ()
recordRichError NodeInfo
at DiagnosticLevel
ErrorLevel
            (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 through" 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 (String -> Doc AnsiStyle
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
callee) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"in" 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 (String -> Doc AnsiStyle
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
fn)
                Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"without first being passed to a callback")
            [ NodeInfo -> Doc AnsiStyle -> DiagnosticSpan Position
mkSpan NodeInfo
ni (Doc AnsiStyle
"then" 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 (String -> Doc AnsiStyle
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
c)) | (NodeInfo
ni, String
c) <- Site
deeper ]
            [(DiagnosticLevel
NoteLevel, Doc AnsiStyle
"callbacks take pointers to this object, and its owner may still hold one")]
  where
    mkSpan :: NodeInfo -> Doc AnsiStyle -> DiagnosticSpan Position
mkSpan NodeInfo
ni Doc AnsiStyle
label =
        let (Position
pos, Int
len) = NodeInfo -> (Position, Int)
posAndLen NodeInfo
ni
        in Position -> Int -> [Doc AnsiStyle] -> DiagnosticSpan Position
forall pos. pos -> Int -> [Doc AnsiStyle] -> DiagnosticSpan pos
DiagnosticSpan Position
pos Int
len [Doc AnsiStyle
label]


descr :: (GlobalDecls -> Trav Env (), (Text, Text))
descr :: (GlobalDecls -> Trav Env (), (Text, Text))
descr = (GlobalDecls -> Trav Env ()
analyse, (Text
"silent-free", [Text] -> Text
Text.unlines
    [ Text
"Checks that an object is passed to a callback before it is freed, if"
    , Text
"callbacks take pointers to its struct and the struct has a `void *` member"
    , Text
"pointing back to the object's owner. A function may still free an object it"
    , Text
"allocated itself or that its caller passed to it."
    , Text
""
    , Text
"**Reason:** the owner may keep a pointer to the object. When the object is"
    , Text
"freed without a callback telling the owner, as on an error path, the owner's"
    , Text
"pointer dangles, and its next use is a use after free."
    ]))