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

import           Control.Monad.State.Strict         (State)
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 (..),
                                                     HasDiagnosticInfo (..),
                                                     warnRich)
import           Language.Cimple.Pretty             (showNodePlain)
import           Prettyprinter                      (pretty, (<+>))
import           Tokstyle.Analysis.AccessPath       (AccessPath (..),
                                                     isPathPrefixOf)
import           Tokstyle.Analysis.Dataflow         (Dataflow (..), solve)
import           Tokstyle.Cimple.Analysis.CFG       (EdgeType (..), Node (..),
                                                     NodeKind (..),
                                                     fromFunction, getFuncName)
import           Tokstyle.Cimple.Analysis.Functions
import           Tokstyle.Common                    (backticks)


-- | Where a field was freed: the file, the freeing call, and the field's
-- access path at that call.
data Origin = Origin FilePath (Lexeme Text) AccessPath
    deriving (Origin -> Origin -> Bool
(Origin -> Origin -> Bool)
-> (Origin -> Origin -> Bool) -> Eq Origin
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Origin -> Origin -> Bool
== :: Origin -> Origin -> Bool
$c/= :: Origin -> Origin -> Bool
/= :: Origin -> Origin -> Bool
Eq, Eq Origin
Eq Origin =>
(Origin -> Origin -> Ordering)
-> (Origin -> Origin -> Bool)
-> (Origin -> Origin -> Bool)
-> (Origin -> Origin -> Bool)
-> (Origin -> Origin -> Bool)
-> (Origin -> Origin -> Origin)
-> (Origin -> Origin -> Origin)
-> Ord Origin
Origin -> Origin -> Bool
Origin -> Origin -> Ordering
Origin -> Origin -> Origin
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 :: Origin -> Origin -> Ordering
compare :: Origin -> Origin -> Ordering
$c< :: Origin -> Origin -> Bool
< :: Origin -> Origin -> Bool
$c<= :: Origin -> Origin -> Bool
<= :: Origin -> Origin -> Bool
$c> :: Origin -> Origin -> Bool
> :: Origin -> Origin -> Bool
$c>= :: Origin -> Origin -> Bool
>= :: Origin -> Origin -> Bool
$cmax :: Origin -> Origin -> Origin
max :: Origin -> Origin -> Origin
$cmin :: Origin -> Origin -> Origin
min :: Origin -> Origin -> Origin
Ord)

-- | One step of an access path relative to a parameter.
data Step = Field String | Index String | Deref
    deriving (Step -> Step -> Bool
(Step -> Step -> Bool) -> (Step -> Step -> Bool) -> Eq Step
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Step -> Step -> Bool
== :: Step -> Step -> Bool
$c/= :: Step -> Step -> Bool
/= :: Step -> Step -> Bool
Eq, Eq Step
Eq Step =>
(Step -> Step -> Ordering)
-> (Step -> Step -> Bool)
-> (Step -> Step -> Bool)
-> (Step -> Step -> Bool)
-> (Step -> Step -> Bool)
-> (Step -> Step -> Step)
-> (Step -> Step -> Step)
-> Ord Step
Step -> Step -> Bool
Step -> Step -> Ordering
Step -> Step -> Step
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 :: Step -> Step -> Ordering
compare :: Step -> Step -> Ordering
$c< :: Step -> Step -> Bool
< :: Step -> Step -> Bool
$c<= :: Step -> Step -> Bool
<= :: Step -> Step -> Bool
$c> :: Step -> Step -> Bool
> :: Step -> Step -> Bool
$c>= :: Step -> Step -> Bool
>= :: Step -> Step -> Bool
$cmax :: Step -> Step -> Step
max :: Step -> Step -> Step
$cmin :: Step -> Step -> Step
min :: Step -> Step -> Step
Ord)

-- | The effects of a call on its arguments for one outcome.
data Effects = Effects
    { Effects -> Set Int
effFrees  :: Set Int
    -- ^ Parameters the call frees.
    , Effects -> Map (Int, [Step]) Origin
effLeaves :: Map (Int, [Step]) Origin
    -- ^ Parameter fields the call leaves pointing at freed memory.
    } deriving (Effects -> Effects -> Bool
(Effects -> Effects -> Bool)
-> (Effects -> Effects -> Bool) -> Eq Effects
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Effects -> Effects -> Bool
== :: Effects -> Effects -> Bool
$c/= :: Effects -> Effects -> Bool
/= :: Effects -> Effects -> Bool
Eq)

instance Semigroup Effects where
    Effects Set Int
a Map (Int, [Step]) Origin
b <> :: Effects -> Effects -> Effects
<> Effects Set Int
c Map (Int, [Step]) Origin
d = Set Int -> Map (Int, [Step]) Origin -> Effects
Effects (Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Int
a Set Int
c) (Map (Int, [Step]) Origin
-> Map (Int, [Step]) Origin -> Map (Int, [Step]) Origin
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map (Int, [Step]) Origin
b Map (Int, [Step]) Origin
d)

instance Monoid Effects where
    mempty :: Effects
mempty = Set Int -> Map (Int, [Step]) Origin -> Effects
Effects Set Int
forall a. Set a
Set.empty Map (Int, [Step]) Origin
forall k a. Map k a
Map.empty

data Summary = Summary
    { Summary -> Map Text (Map Outcome Effects)
effects :: Map Text (Map Outcome Effects)
    , Summary -> Map Text Shape
shapes  :: Map Text Shape
    }

-- | Facts that hold on some path to a node.
data Facts = Facts
    { Facts -> Map AccessPath Origin
dangling :: Map AccessPath Origin
    -- ^ Fields still pointing at freed memory.
    , Facts -> Set String
freed    :: Set String
    -- ^ Variables pointing at freed memory.
    } 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 Map AccessPath Origin
a Set String
b) (Facts Map AccessPath Origin
c Set String
d) = Map AccessPath Origin -> Set String -> Facts
Facts (Map AccessPath Origin
-> Map AccessPath Origin -> Map AccessPath Origin
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map AccessPath Origin
a Map AccessPath Origin
c) (Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set String
b Set String
d)

-- | The enum constant each error-flag local holds.
type Flags = Map String Text

-- | Path-sensitive state: the facts for each combination of error-flag
-- values. An empty map means the node is unreachable.
type St = Map Flags Facts

data Context = Context
    { Context -> String
ctxFile    :: FilePath
    , Context -> [Text]
ctxParams  :: [Text]
    , Context -> Map String String
ctxAliases :: Map String String
    -- ^ Locals only ever holding another variable, mapped to that variable.
    , Context -> Set String
ctxFlags   :: Set String
    -- ^ Locals only ever holding enum constants.
    , Context -> Map String [Text]
ctxSlots   :: Map String [Text]
    -- ^ Locals assigned from a slot getter, mapped to the call's arguments.
    , Context -> Set Text
ctxGetters :: Set Text
    }

-- | Find slot getters: functions returning null or an element of what a
-- parameter points to, i.e. the element, its address, or a path under
-- another slot getter's result.
slotGetters :: [Function] -> Set Text
slotGetters :: [Function] -> Set Text
slotGetters [Function]
fns = Set Text -> Set Text
go Set Text
forall a. Set a
Set.empty
  where
    go :: Set Text -> Set Text
go Set Text
s = let s' :: Set Text
s' = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList [ Function -> Text
fnName Function
f | Function
f <- [Function]
fns, Set Text -> Function -> Bool
gets Set Text
s Function
f ] 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
go Set Text
s'
    gets :: Set Text -> Function -> Bool
gets Set Text
s Function
f = [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Function -> [Text]
fnParams Function
f) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 Bool -> Bool -> Bool
&& Bool -> Bool
not ([Fix (NodeF (Lexeme Text))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Function -> [Fix (NodeF (Lexeme Text))]
rets Function
f)) Bool -> Bool -> Bool
&& (Fix (NodeF (Lexeme Text)) -> Bool)
-> [Fix (NodeF (Lexeme Text))] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Set Text -> Function -> Fix (NodeF (Lexeme Text)) -> Bool
slot Set Text
s Function
f) (Function -> [Fix (NodeF (Lexeme Text))]
rets Function
f)
    rets :: Function -> [Fix (NodeF (Lexeme Text))]
rets Function
f = [ 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
f) ]
    slot :: Set Text -> Function -> Fix (NodeF (Lexeme Text)) -> Bool
slot Set Text
s Function
f Fix (NodeF (Lexeme Text))
e = case Fix (NodeF (Lexeme Text)) -> Fix (NodeF (Lexeme Text))
bare Fix (NodeF (Lexeme Text))
e of
        Fix (NodeF (Lexeme Text))
e' | Fix (NodeF (Lexeme Text)) -> Bool
isNullLit Fix (NodeF (Lexeme Text))
e'            -> Bool
True
        Fix (UnaryExpr UnaryOp
UopAddress Fix (NodeF (Lexeme Text))
x) -> Set Text -> Function -> Fix (NodeF (Lexeme Text)) -> Bool
under Set Text
s Function
f Fix (NodeF (Lexeme Text))
x
        Fix (NodeF (Lexeme Text))
x                            -> Set Text -> Function -> Fix (NodeF (Lexeme Text)) -> Bool
under Set Text
s Function
f Fix (NodeF (Lexeme Text))
x
    under :: Set Text -> Function -> Fix (NodeF (Lexeme Text)) -> Bool
under Set Text
s Function
f Fix (NodeF (Lexeme Text))
x = case Fix (NodeF (Lexeme Text)) -> Maybe AccessPath
accessPath Fix (NodeF (Lexeme Text))
x of
        Just AccessPath
p | Just String
r <- AccessPath -> Maybe String
rootOf AccessPath
p ->
            (String -> Text
Text.pack String
r Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Function -> [Text]
fnParams Function
f Bool -> Bool -> Bool
&& AccessPath -> Bool
indexed AccessPath
p)
            Bool -> Bool -> Bool
|| (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
fromGetter Set Text
s) [ Fix (NodeF (Lexeme Text))
ini | (String
v, Just Fix (NodeF (Lexeme Text))
ini) <- Fix (NodeF (Lexeme Text))
-> [(String, Maybe (Fix (NodeF (Lexeme Text))))]
localDecls (Function -> Fix (NodeF (Lexeme Text))
fnDefn Function
f), String
v String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
r ]
        Maybe AccessPath
_ -> Bool
False
    indexed :: AccessPath -> Bool
indexed = \case
        PathIndex{}   -> Bool
True
        PathField AccessPath
q String
_ -> AccessPath -> Bool
indexed AccessPath
q
        PathDeref AccessPath
q   -> AccessPath -> Bool
indexed AccessPath
q
        AccessPath
_             -> Bool
False
    fromGetter :: Set Text -> Fix (NodeF (Lexeme Text)) -> Bool
fromGetter Set Text
s Fix (NodeF (Lexeme Text))
ini = case Fix (NodeF (Lexeme Text)) -> Fix (NodeF (Lexeme Text))
bare Fix (NodeF (Lexeme Text))
ini 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
s
        Fix (NodeF (Lexeme Text))
_ -> Bool
False

contextOf :: Set Text -> Function -> Context
contextOf :: Set Text -> Function -> Context
contextOf Set Text
getters Function
fn = Context
    { ctxFile :: String
ctxFile = Function -> String
fnFile Function
fn
    , ctxParams :: [Text]
ctxParams = Function -> [Text]
fnParams Function
fn
    , ctxAliases :: Map String String
ctxAliases = [(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (String
v, String
x) | (String
v, Just Fix (NodeF (Lexeme Text))
ini) <- [(String, Maybe (Fix (NodeF (Lexeme Text))))]
decls, String -> Map String [Fix (NodeF (Lexeme Text))] -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember String
v Map String [Fix (NodeF (Lexeme Text))]
assigned, Just String
x <- [Fix (NodeF (Lexeme Text)) -> Maybe String
plainVar Fix (NodeF (Lexeme Text))
ini] ]
    , ctxFlags :: Set String
ctxFlags = [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 vs :: [Fix (NodeF (Lexeme Text))]
vs = String
-> Maybe (Fix (NodeF (Lexeme Text))) -> [Fix (NodeF (Lexeme Text))]
values String
v Maybe (Fix (NodeF (Lexeme Text)))
ini, 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))]
vs), (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))]
vs ]
    , ctxSlots :: Map String [Text]
ctxSlots = [(String, [Text])] -> Map String [Text]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (String
v, (Fix (NodeF (Lexeme Text)) -> Text)
-> [Fix (NodeF (Lexeme Text))] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Fix (NodeF (Lexeme Text)) -> Text
forall a. Pretty a => Node (Lexeme a) -> Text
showNodePlain [Fix (NodeF (Lexeme Text))]
args)
        | (String
v, Maybe (Fix (NodeF (Lexeme Text)))
ini) <- [(String, Maybe (Fix (NodeF (Lexeme Text))))]
decls, Fix (NodeF (Lexeme Text))
e <- String
-> Maybe (Fix (NodeF (Lexeme Text))) -> [Fix (NodeF (Lexeme Text))]
values String
v Maybe (Fix (NodeF (Lexeme Text)))
ini
        , Fix (FunctionCall Fix (NodeF (Lexeme Text))
callee [Fix (NodeF (Lexeme Text))]
args) <- [Fix (NodeF (Lexeme Text)) -> Fix (NodeF (Lexeme Text))
strip Fix (NodeF (Lexeme Text))
e], Just Text
name <- [Fix (NodeF (Lexeme Text)) -> Maybe Text
getFuncName Fix (NodeF (Lexeme Text))
callee]
        , Text
name Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
getters ]
    , ctxGetters :: Set Text
ctxGetters = Set Text
getters
    }
  where
    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)
    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)
    values :: String
-> Maybe (Fix (NodeF (Lexeme Text))) -> [Fix (NodeF (Lexeme Text))]
values String
v Maybe (Fix (NodeF (Lexeme Text)))
ini = [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
    plainVar :: Fix (NodeF (Lexeme Text)) -> Maybe String
plainVar Fix (NodeF (Lexeme Text))
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))
e) of
        VarExpr (L AlexPosn
_ LexemeClass
_ Text
x) -> String -> Maybe String
forall a. a -> Maybe a
Just (Text -> String
Text.unpack Text
x)
        CastExpr Fix (NodeF (Lexeme Text))
_ Fix (NodeF (Lexeme Text))
x      -> Fix (NodeF (Lexeme Text)) -> Maybe String
plainVar Fix (NodeF (Lexeme Text))
x
        NodeF (Lexeme Text) (Fix (NodeF (Lexeme Text)))
_                 -> Maybe String
forall a. Maybe a
Nothing

-- | Resolve a local to the variable it aliases.
canonical :: Context -> String -> String
canonical :: Context -> String -> String
canonical Context
ctx = Int -> String -> String
forall {t}. (Eq t, Num t) => t -> String -> String
go (Int
10 :: Int)
  where
    go :: t -> String -> String
go t
0 String
v = String
v
    go t
k String
v = String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
v (t -> String -> String
go (t
k t -> t -> t
forall a. Num a => a -> a -> a
- t
1)) (String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
v (Context -> Map String String
ctxAliases Context
ctx))

pathOf :: Context -> C.Node (Lexeme Text) -> Maybe AccessPath
pathOf :: Context -> Fix (NodeF (Lexeme Text)) -> Maybe AccessPath
pathOf Context
ctx Fix (NodeF (Lexeme Text))
e = (String -> String) -> AccessPath -> AccessPath
mapRoot (Context -> String -> String
canonical Context
ctx) (AccessPath -> AccessPath) -> Maybe AccessPath -> Maybe AccessPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Fix (NodeF (Lexeme Text)) -> Maybe AccessPath
accessPath Fix (NodeF (Lexeme Text))
e

-- | Get the steps of an access path, from its root.
stepsOf :: AccessPath -> [Step]
stepsOf :: AccessPath -> [Step]
stepsOf = [Step] -> [Step]
forall a. [a] -> [a]
reverse ([Step] -> [Step])
-> (AccessPath -> [Step]) -> AccessPath -> [Step]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AccessPath -> [Step]
go
  where
    go :: AccessPath -> [Step]
go = \case
        PathField AccessPath
p String
s -> String -> Step
Field String
s Step -> [Step] -> [Step]
forall a. a -> [a] -> [a]
: AccessPath -> [Step]
go AccessPath
p
        PathIndex AccessPath
p String
s -> String -> Step
Index String
s Step -> [Step] -> [Step]
forall a. a -> [a] -> [a]
: AccessPath -> [Step]
go AccessPath
p
        PathDeref AccessPath
p   -> Step
Deref Step -> [Step] -> [Step]
forall a. a -> [a] -> [a]
: AccessPath -> [Step]
go AccessPath
p
        AccessPath
_             -> []

extend :: AccessPath -> [Step] -> AccessPath
extend :: AccessPath -> [Step] -> AccessPath
extend = (AccessPath -> Step -> AccessPath)
-> AccessPath -> [Step] -> AccessPath
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ((AccessPath -> Step -> AccessPath)
 -> AccessPath -> [Step] -> AccessPath)
-> (AccessPath -> Step -> AccessPath)
-> AccessPath
-> [Step]
-> AccessPath
forall a b. (a -> b) -> a -> b
$ \AccessPath
p -> \case
    Field String
s -> AccessPath -> String -> AccessPath
PathField AccessPath
p String
s
    Index String
s -> AccessPath -> String -> AccessPath
PathIndex AccessPath
p String
s
    Step
Deref   -> AccessPath -> AccessPath
PathDeref AccessPath
p

forget :: AccessPath -> Facts -> Facts
forget :: AccessPath -> Facts -> Facts
forget AccessPath
p (Facts Map AccessPath Origin
d Set String
f) = Map AccessPath Origin -> Set String -> Facts
Facts ((AccessPath -> Origin -> Bool)
-> Map AccessPath Origin -> Map AccessPath Origin
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\AccessPath
k Origin
_ -> Bool -> Bool
not (AccessPath
p AccessPath -> AccessPath -> Bool
`isPathPrefixOf` AccessPath
k)) Map AccessPath Origin
d) (Set String -> (String -> Set String) -> Maybe String -> Set String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set String
f (String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
`Set.delete` Set String
f) (AccessPath -> Maybe String
varOf AccessPath
p))
  where
    varOf :: AccessPath -> Maybe String
varOf (PathVar String
v) = String -> Maybe String
forall a. a -> Maybe a
Just String
v
    varOf AccessPath
_           = Maybe String
forall a. Maybe a
Nothing

-- | Transfer function for an expression, given the outcome a call is known to
-- have reported on this path.
evalExpr :: Summary -> Context -> Maybe (Lexeme Text, Outcome) -> C.Node (Lexeme Text) -> (Flags, Facts) -> (Flags, Facts)
evalExpr :: Summary
-> Context
-> Maybe (Lexeme Text, Outcome)
-> Fix (NodeF (Lexeme Text))
-> (Flags, Facts)
-> (Flags, Facts)
evalExpr Summary
summary Context
ctx Maybe (Lexeme Text, Outcome)
known = Fix (NodeF (Lexeme Text)) -> (Flags, Facts) -> (Flags, Facts)
go
  where
    go :: Fix (NodeF (Lexeme Text)) -> (Flags, Facts) -> (Flags, Facts)
go (Fix NodeF (Lexeme Text) (Fix (NodeF (Lexeme Text)))
node) (Flags, Facts)
st = case NodeF (Lexeme Text) (Fix (NodeF (Lexeme Text)))
node of
        FunctionCall Fix (NodeF (Lexeme Text))
callee [Fix (NodeF (Lexeme Text))]
args ->
            let (Flags
flags', Facts
facts') = ((Flags, Facts) -> Fix (NodeF (Lexeme Text)) -> (Flags, Facts))
-> (Flags, Facts) -> [Fix (NodeF (Lexeme Text))] -> (Flags, Facts)
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)) -> (Flags, Facts) -> (Flags, Facts))
-> (Flags, Facts) -> Fix (NodeF (Lexeme Text)) -> (Flags, Facts)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Fix (NodeF (Lexeme Text)) -> (Flags, Facts) -> (Flags, Facts)
go) (Flags, Facts)
st [Fix (NodeF (Lexeme Text))]
args
            in (Flags
flags', Fix (NodeF (Lexeme Text))
-> [Fix (NodeF (Lexeme Text))] -> Facts -> Facts
call Fix (NodeF (Lexeme Text))
callee [Fix (NodeF (Lexeme Text))]
args Facts
facts')
        AssignExpr Fix (NodeF (Lexeme Text))
l AssignOp
_ Fix (NodeF (Lexeme Text))
r ->
            let (Flags
flags', Facts
facts') = Fix (NodeF (Lexeme Text)) -> (Flags, Facts) -> (Flags, Facts)
go Fix (NodeF (Lexeme Text))
r (Flags, Facts)
st
                assigned :: Facts
assigned = Facts -> (AccessPath -> Facts) -> Maybe AccessPath -> Facts
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Facts
facts' (AccessPath -> Facts -> Facts
`forget` Facts
facts') (Context -> Fix (NodeF (Lexeme Text)) -> Maybe AccessPath
pathOf Context
ctx Fix (NodeF (Lexeme Text))
l)
            in 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))
l), Fix (NodeF (Lexeme Text)) -> Maybe Text
constName Fix (NodeF (Lexeme Text))
r) of
                (VarExpr (L AlexPosn
_ LexemeClass
_ Text
v), Just Text
c) | Text -> String
Text.unpack Text
v String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Context -> Set String
ctxFlags Context
ctx ->
                    (String -> Text -> Flags -> Flags
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Text -> String
Text.unpack Text
v) Text
c Flags
flags', Facts
assigned)
                (NodeF (Lexeme Text) (Fix (NodeF (Lexeme Text))), Maybe Text)
_ -> (Flags
flags', Facts
assigned)
        NodeF (Lexeme Text) (Fix (NodeF (Lexeme Text)))
_ -> ((Flags, Facts) -> Fix (NodeF (Lexeme Text)) -> (Flags, Facts))
-> (Flags, Facts) -> [Fix (NodeF (Lexeme Text))] -> (Flags, Facts)
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)) -> (Flags, Facts) -> (Flags, Facts))
-> (Flags, Facts) -> Fix (NodeF (Lexeme Text)) -> (Flags, Facts)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Fix (NodeF (Lexeme Text)) -> (Flags, Facts) -> (Flags, Facts)
go) (Flags, Facts)
st ((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)

    call :: Fix (NodeF (Lexeme Text))
-> [Fix (NodeF (Lexeme Text))] -> Facts -> Facts
call Fix (NodeF (Lexeme Text))
callee [Fix (NodeF (Lexeme Text))]
args Facts
facts = case Fix (NodeF (Lexeme Text)) -> Maybe Text
getFuncName Fix (NodeF (Lexeme Text))
callee of
        Maybe Text
Nothing -> (Facts -> Fix (NodeF (Lexeme Text)) -> Facts)
-> Facts -> [Fix (NodeF (Lexeme Text))] -> Facts
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 -> Fix (NodeF (Lexeme Text)) -> Facts
passArg Facts
facts [Fix (NodeF (Lexeme Text))]
args
        Just Text
fn ->
            let direct :: Effects
direct = Set Int -> Map (Int, [Step]) Origin -> Effects
Effects (Set Int -> (Int -> Set Int) -> Maybe Int -> Set Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set Int
forall a. Set a
Set.empty Int -> Set Int
forall a. a -> Set a
Set.singleton (Text -> Map Text Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
fn Map Text Int
freers)) Map (Int, [Step]) Origin
forall k a. Map k a
Map.empty
                byOutcome :: Map Outcome Effects
byOutcome = Map Outcome Effects
-> Text -> Map Text (Map Outcome Effects) -> Map Outcome Effects
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map Outcome Effects
forall k a. Map k a
Map.empty Text
fn (Summary -> Map Text (Map Outcome Effects)
effects Summary
summary)
                outcomes :: [Outcome]
outcomes = case Maybe (Lexeme Text, Outcome)
known of
                    Just (Lexeme Text
l, Outcome
o) | Lexeme Text
l Lexeme Text -> Lexeme Text -> Bool
forall a. Eq a => a -> a -> Bool
== Fix (NodeF (Lexeme Text)) -> Lexeme Text
calleeLexeme Fix (NodeF (Lexeme Text))
callee -> [Outcome
o]
                    Maybe (Lexeme Text, Outcome)
_                                      -> [Outcome
forall a. Bounded a => a
minBound .. Outcome
forall a. Bounded a => a
maxBound]
                eff :: Effects
eff = Effects
direct Effects -> Effects -> Effects
forall a. Semigroup a => a -> a -> a
<> [Effects] -> Effects
forall a. Monoid a => [a] -> a
mconcat [ Effects -> Outcome -> Map Outcome Effects -> Effects
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Effects
forall a. Monoid a => a
mempty Outcome
o Map Outcome Effects
byOutcome | Outcome
o <- [Outcome]
outcomes ]
                handled :: Set Int
handled = Effects -> Set Int
effFrees Effects
eff Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList (((Int, [Step]) -> Int) -> [(Int, [Step])] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, [Step]) -> Int
forall a b. (a, b) -> a
fst (Map (Int, [Step]) Origin -> [(Int, [Step])]
forall k a. Map k a -> [k]
Map.keys (Effects -> Map (Int, [Step]) Origin
effLeaves Effects
eff)))
                arg :: Int -> Maybe AccessPath
arg Int
i = case Int -> [Fix (NodeF (Lexeme Text))] -> [Fix (NodeF (Lexeme Text))]
forall a. Int -> [a] -> [a]
drop Int
i [Fix (NodeF (Lexeme Text))]
args of
                    (Fix (NodeF (Lexeme Text))
a : [Fix (NodeF (Lexeme Text))]
_) -> Context -> Fix (NodeF (Lexeme Text)) -> Maybe AccessPath
pathOf Context
ctx Fix (NodeF (Lexeme Text))
a
                    []      -> Maybe AccessPath
forall a. Maybe a
Nothing
                freeArg :: Int -> Facts -> Facts
freeArg Int
i Facts
fs = case Int -> Maybe AccessPath
arg Int
i of
                    Just p :: AccessPath
p@(PathVar String
v) -> (AccessPath -> Facts -> Facts
forget AccessPath
p Facts
fs) { freed = Set.insert v (freed fs) }
                    Just AccessPath
p -> (AccessPath -> Facts -> Facts
forget AccessPath
p Facts
fs) { dangling = Map.insert p (Origin (ctxFile ctx) (calleeLexeme callee) p) (dangling (forget p fs)) }
                    Maybe AccessPath
Nothing -> Facts
fs
                leaveArg :: Facts -> ((Int, [Step]), Origin) -> Facts
leaveArg Facts
fs ((Int
i, [Step]
steps), Origin
origin) = case Int -> Maybe AccessPath
arg Int
i of
                    Just AccessPath
p  -> Facts
fs { dangling = Map.insert (extend p steps) origin (dangling fs) }
                    Maybe AccessPath
Nothing -> Facts
fs
                others :: [Fix (NodeF (Lexeme Text))]
others = [ Fix (NodeF (Lexeme Text))
a | (Int
i, Fix (NodeF (Lexeme Text))
a) <- [Int]
-> [Fix (NodeF (Lexeme Text))]
-> [(Int, Fix (NodeF (Lexeme Text)))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [Fix (NodeF (Lexeme Text))]
args, Int
i Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Int
handled ]
                slotsTouched :: [AccessPath]
slotsTouched = [ String -> AccessPath
PathVar String
v | (String
v, [Text]
key) <- Map String [Text] -> [(String, [Text])]
forall k a. Map k a -> [(k, a)]
Map.toList (Context -> Map String [Text]
ctxSlots Context
ctx), Text
fn Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Context -> Set Text
ctxGetters Context
ctx
                                           , (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Fix (NodeF (Lexeme Text)) -> Text)
-> [Fix (NodeF (Lexeme Text))] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Fix (NodeF (Lexeme Text)) -> Text
forall a. Pretty a => Node (Lexeme a) -> Text
showNodePlain [Fix (NodeF (Lexeme Text))]
args) [Text]
key ]
                afterFree :: Facts
afterFree = (Facts -> Int -> Facts) -> Facts -> [Int] -> Facts
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ((Int -> Facts -> Facts) -> Facts -> Int -> Facts
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Facts -> Facts
freeArg) Facts
facts (Set Int -> [Int]
forall a. Set a -> [a]
Set.toList (Effects -> Set Int
effFrees Effects
eff))
                afterLeave :: Facts
afterLeave = (Facts -> ((Int, [Step]), Origin) -> Facts)
-> Facts -> [((Int, [Step]), Origin)] -> Facts
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 -> ((Int, [Step]), Origin) -> Facts
leaveArg Facts
afterFree (Map (Int, [Step]) Origin -> [((Int, [Step]), Origin)]
forall k a. Map k a -> [(k, a)]
Map.toList (Effects -> Map (Int, [Step]) Origin
effLeaves Effects
eff))
            in (Facts -> AccessPath -> Facts) -> Facts -> [AccessPath] -> Facts
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ((AccessPath -> Facts -> Facts) -> Facts -> AccessPath -> Facts
forall a b c. (a -> b -> c) -> b -> a -> c
flip AccessPath -> Facts -> Facts
forget) ((Facts -> Fix (NodeF (Lexeme Text)) -> Facts)
-> Facts -> [Fix (NodeF (Lexeme Text))] -> Facts
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 -> Fix (NodeF (Lexeme Text)) -> Facts
passArg Facts
afterLeave [Fix (NodeF (Lexeme Text))]
others) [AccessPath]
slotsTouched

    -- A callee given a variable or an address may reset the fields under it.
    passArg :: Facts -> Fix (NodeF (Lexeme Text)) -> Facts
passArg Facts
facts Fix (NodeF (Lexeme Text))
a = 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))
a) of
        UnaryExpr UnaryOp
UopAddress Fix (NodeF (Lexeme Text))
x | Just AccessPath
p <- Context -> Fix (NodeF (Lexeme Text)) -> Maybe AccessPath
pathOf Context
ctx Fix (NodeF (Lexeme Text))
x -> AccessPath -> Facts -> Facts
forget AccessPath
p Facts
facts
        NodeF (Lexeme Text) (Fix (NodeF (Lexeme Text)))
_ -> case Context -> Fix (NodeF (Lexeme Text)) -> Maybe AccessPath
pathOf Context
ctx Fix (NodeF (Lexeme Text))
a of
            Just p :: AccessPath
p@(PathVar String
_) -> AccessPath -> Facts -> Facts
forget AccessPath
p Facts
facts
            Maybe AccessPath
_                  -> Facts
facts

joinSt :: St -> St -> St
joinSt :: St -> St -> St
joinSt = (Facts -> Facts -> Facts) -> St -> St -> St
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Facts -> Facts -> Facts
joinFacts

mapSt :: ((Flags, Facts) -> (Flags, Facts)) -> St -> St
mapSt :: ((Flags, Facts) -> (Flags, Facts)) -> St -> St
mapSt (Flags, Facts) -> (Flags, Facts)
f = (Facts -> Facts -> Facts) -> [(Flags, Facts)] -> St
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Facts -> Facts -> Facts
joinFacts ([(Flags, Facts)] -> St) -> (St -> [(Flags, Facts)]) -> St -> St
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Flags, Facts) -> (Flags, Facts))
-> [(Flags, Facts)] -> [(Flags, Facts)]
forall a b. (a -> b) -> [a] -> [b]
map (Flags, Facts) -> (Flags, Facts)
f ([(Flags, Facts)] -> [(Flags, Facts)])
-> (St -> [(Flags, Facts)]) -> St -> [(Flags, Facts)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. St -> [(Flags, Facts)]
forall k a. Map k a -> [(k, a)]
Map.toList

-- | Get the facts at each exit of a function, with the outcomes reported
-- there.
atReturns :: Summary -> Set Text -> Function -> [([Outcome], Facts)]
atReturns :: Summary -> Set Text -> Function -> [([Outcome], Facts)]
atReturns Summary
summary Set Text
getters Function
fn =
    [ ([Outcome]
outcomes, Facts
facts)
    | (Node
n, [Edge]
edges) <- Map Node [Edge] -> [(Node, [Edge])]
forall k a. Map k a -> [(k, a)]
Map.toList Map Node [Edge]
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 St
st <- [Node -> Map Node St -> Maybe St
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Node
n Map Node St
result]
    , let ([Outcome]
outcomes, St
st') = 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 -> St -> St
step Node
n St
st)
              Node
_                                  -> ([Outcome
Success], Node -> St -> St
step Node
n St
st)
    , Facts
facts <- St -> [Facts]
forall k a. Map k a -> [a]
Map.elems St
st'
    ]
  where
    ctx :: Context
ctx = Set Text -> Function -> Context
contextOf Set Text
getters Function
fn
    (Node
entry, Map Node [Edge]
cfg) = Fix (NodeF (Lexeme Text)) -> (Node, Map Node [Edge])
fromFunction (Function -> Fix (NodeF (Lexeme Text))
fnDefn Function
fn)
    isExit :: Node -> Bool
isExit (Node Int
_ NodeKind
ExitNode) = Bool
True
    isExit Node
_                 = Bool
False
    declare :: Node -> St -> St
declare Node
n St
st = 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 name :: String
name = Text -> String
Text.unpack Text
v
                setFlag :: Flags -> Flags
setFlag Flags
flags = case 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 of
                    Just Text
c | String
name String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Context -> Set String
ctxFlags Context
ctx -> String -> Text -> Flags -> Flags
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
name Text
c Flags
flags
                    Maybe Text
_                                       -> String -> Flags -> Flags
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete String
name Flags
flags
            in ((Flags, Facts) -> (Flags, Facts)) -> St -> St
mapSt (\(Flags
flags, Facts
facts) -> (Flags -> Flags
setFlag Flags
flags, AccessPath -> Facts -> Facts
forget (String -> AccessPath
PathVar String
name) Facts
facts)) St
st
        Node
_ -> St
st
    step :: Node -> St -> St
step Node
n St
st = case Node
n of
        Node Int
_ BranchNode{} -> St
st
        Node
_ -> Node -> St -> St
declare Node
n ((St -> Fix (NodeF (Lexeme Text)) -> St)
-> St -> [Fix (NodeF (Lexeme Text))] -> St
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (\St
s Fix (NodeF (Lexeme Text))
e -> ((Flags, Facts) -> (Flags, Facts)) -> St -> St
mapSt (Summary
-> Context
-> Maybe (Lexeme Text, Outcome)
-> Fix (NodeF (Lexeme Text))
-> (Flags, Facts)
-> (Flags, Facts)
evalExpr Summary
summary Context
ctx Maybe (Lexeme Text, Outcome)
forall a. Maybe a
Nothing Fix (NodeF (Lexeme Text))
e) St
s) St
st (Node -> [Fix (NodeF (Lexeme Text))]
nodeExprs Node
n))
    edge :: Node -> EdgeType -> St -> St
edge Node
n EdgeType
e St
st = case Node
n of
        Node Int
_ (BranchNode Fix (NodeF (Lexeme Text))
cond) ->
            let known :: Maybe (Lexeme Text, Outcome)
known = case (Map Text Shape
-> Fix (NodeF (Lexeme Text)) -> Maybe (Lexeme Text, Outcome)
branchOn (Summary -> Map Text Shape
shapes Summary
summary) Fix (NodeF (Lexeme Text))
cond, EdgeType
e) of
                    (Just (Lexeme Text
l, Outcome
o), EdgeType
TrueBranch)  -> (Lexeme Text, Outcome) -> Maybe (Lexeme Text, Outcome)
forall a. a -> Maybe a
Just (Lexeme Text
l, Outcome
o)
                    (Just (Lexeme Text
l, Outcome
o), EdgeType
FalseBranch) -> (Lexeme Text, Outcome) -> Maybe (Lexeme Text, Outcome)
forall a. a -> Maybe a
Just (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)
_                          -> Maybe (Lexeme Text, Outcome)
forall a. Maybe a
Nothing
            in (Facts -> Facts) -> St -> St
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Fix (NodeF (Lexeme Text)) -> EdgeType -> Facts -> Facts
dropNull Fix (NodeF (Lexeme Text))
cond EdgeType
e)
                (St -> St) -> (St -> St) -> St -> St
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Flags -> Facts -> Bool) -> St -> St
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\Flags
flags Facts
_ -> Flags -> Fix (NodeF (Lexeme Text)) -> EdgeType -> Bool
flagHolds Flags
flags Fix (NodeF (Lexeme Text))
cond EdgeType
e)
                (St -> St) -> St -> St
forall a b. (a -> b) -> a -> b
$ ((Flags, Facts) -> (Flags, Facts)) -> St -> St
mapSt (Summary
-> Context
-> Maybe (Lexeme Text, Outcome)
-> Fix (NodeF (Lexeme Text))
-> (Flags, Facts)
-> (Flags, Facts)
evalExpr Summary
summary Context
ctx Maybe (Lexeme Text, Outcome)
known Fix (NodeF (Lexeme Text))
cond) St
st
        Node
_ -> St
st
    -- Nothing under a pointer dangles on the branch where it is null.
    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)
-> Fix (NodeF (Lexeme Text)) -> Maybe (AccessPath, EdgeType)
forall a.
(Fix (NodeF (Lexeme Text)) -> Maybe a)
-> Fix (NodeF (Lexeme Text)) -> Maybe (a, EdgeType)
nullTest (Context -> Fix (NodeF (Lexeme Text)) -> Maybe AccessPath
pathOf Context
ctx) Fix (NodeF (Lexeme Text))
cond, EdgeType
e) of
        (Just (AccessPath
p, EdgeType
TrueBranch), EdgeType
TrueBranch)   -> AccessPath -> Facts -> Facts
forgetUnder AccessPath
p Facts
facts
        (Just (AccessPath
p, EdgeType
FalseBranch), EdgeType
FalseBranch) -> AccessPath -> Facts -> Facts
forgetUnder AccessPath
p Facts
facts
        (Maybe (AccessPath, EdgeType), EdgeType)
_                                    -> Facts
facts
    forgetUnder :: AccessPath -> Facts -> Facts
forgetUnder AccessPath
p Facts
facts = Facts
facts { dangling = Map.filterWithKey (\AccessPath
k Origin
_ -> Bool -> Bool
not (AccessPath
p AccessPath -> AccessPath -> Bool
`isPathPrefixOf` AccessPath
k)) (dangling facts) }
    result :: Map Node St
result = Node -> Map Node [Edge] -> Dataflow Node EdgeType St -> Map Node St
forall node state edge.
(Ord node, Eq state) =>
node
-> Map node [(edge, node)]
-> Dataflow node edge state
-> Map node state
solve Node
entry Map Node [Edge]
cfg Dataflow
        { transfer :: Node -> St -> St
transfer     = Node -> St -> St
step
        , edgeTransfer :: Node -> EdgeType -> St -> St
edgeTransfer = Node -> EdgeType -> St -> St
edge
        , merge :: St -> St -> St
merge        = St -> St -> St
joinSt
        , initial :: St
initial      = Flags -> Facts -> St
forall k a. k -> a -> Map k a
Map.singleton Flags
forall k a. Map k a
Map.empty (Map AccessPath Origin -> Set String -> Facts
Facts Map AccessPath Origin
forall k a. Map k a
Map.empty Set String
forall a. Set a
Set.empty)
        }

effectsOf :: Summary -> Set Text -> Function -> Map Outcome Effects
effectsOf :: Summary -> Set Text -> Function -> Map Outcome Effects
effectsOf Summary
summary Set Text
getters Function
fn = (Effects -> Effects -> Effects)
-> [(Outcome, Effects)] -> Map Outcome Effects
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Effects -> Effects -> Effects
forall a. Semigroup a => a -> a -> a
(<>)
    [ (Outcome
o, Set Int -> Map (Int, [Step]) Origin -> Effects
Effects
        ([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
freed Facts
facts), Just Int
i <- [String -> Maybe Int
paramIndex String
v] ])
        ([((Int, [Step]), Origin)] -> Map (Int, [Step]) Origin
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ ((Int
i, AccessPath -> [Step]
stepsOf AccessPath
p), Origin
origin) | (AccessPath
p, Origin
origin) <- Map AccessPath Origin -> [(AccessPath, Origin)]
forall k a. Map k a -> [(k, a)]
Map.toList (Facts -> Map AccessPath Origin
dangling Facts
facts), Just String
r <- [AccessPath -> Maybe String
rootOf AccessPath
p], Just Int
i <- [String -> Maybe Int
paramIndex String
r] ]))
    | ([Outcome]
outcomes, Facts
facts) <- Summary -> Set Text -> Function -> [([Outcome], Facts)]
atReturns Summary
summary Set Text
getters Function
fn, Outcome
o <- [Outcome]
outcomes ]
  where
    paramIndex :: String -> Maybe Int
paramIndex String
v = 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)

summarise :: Set Text -> [Function] -> Summary
summarise :: Set Text -> [Function] -> Summary
summarise Set Text
getters [Function]
fns = (Function -> [Text])
-> (Summary -> Function -> Summary)
-> (Summary -> Function -> Maybe (Map Outcome Effects))
-> [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 Effects)
look [Function]
fns (Map Text (Map Outcome Effects) -> Map Text Shape -> Summary
Summary Map Text (Map Outcome Effects)
forall k a. Map k a
Map.empty Map Text Shape
shapeMap)
  where
    shapeMap :: Map Text Shape
shapeMap = [(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 = Summary
s { effects = Map.insertWith (Map.unionWith (<>)) (fnName f) (effectsOf s getters f) (effects s) }
    look :: Summary -> Function -> Maybe (Map Outcome Effects)
look Summary
s Function
f = Text
-> Map Text (Map Outcome Effects) -> Maybe (Map Outcome Effects)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Function -> Text
fnName Function
f) (Summary -> Map Text (Map Outcome Effects)
effects Summary
s)

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]
forall s a. State s a -> s -> s
State.execState (((Origin, [(Text, AccessPath)]) -> State [Diagnostic CimplePos] ())
-> [(Origin, [(Text, AccessPath)])]
-> State [Diagnostic CimplePos] ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Origin, [(Text, AccessPath)]) -> State [Diagnostic CimplePos] ()
report (Map Origin [(Text, AccessPath)] -> [(Origin, [(Text, AccessPath)])]
forall k a. Map k a -> [(k, a)]
Map.toList Map Origin [(Text, AccessPath)]
reports)) []
  where
    fns :: [Function]
fns = [(String, [Fix (NodeF (Lexeme Text))])] -> [Function]
definitions [(String, [Fix (NodeF (Lexeme Text))])]
tus
    getters :: Set Text
getters = [Function] -> Set Text
slotGetters [Function]
fns
    summary :: Summary
summary = Set Text -> [Function] -> Summary
summarise Set Text
getters [Function]
fns
    reports :: Map Origin [(Text, AccessPath)]
reports = ([(Text, AccessPath)]
 -> [(Text, AccessPath)] -> [(Text, AccessPath)])
-> [(Origin, [(Text, AccessPath)])]
-> Map Origin [(Text, AccessPath)]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [(Text, AccessPath)]
-> [(Text, AccessPath)] -> [(Text, AccessPath)]
forall a. [a] -> [a] -> [a]
(++)
        [ (Origin
o, [(Function -> Text
fnName Function
f, AccessPath
p)])
        | Function
f <- [Function]
fns
        , ([Outcome]
_, Facts
facts) <- Summary -> Set Text -> Function -> [([Outcome], Facts)]
atReturns Summary
summary Set Text
getters Function
f
        , (AccessPath
p, Origin
o) <- Map AccessPath Origin -> [(AccessPath, Origin)]
forall k a. Map k a -> [(k, a)]
Map.toList (Facts -> Map AccessPath Origin
dangling Facts
facts)
        , AccessPath -> Bool
throughPointer AccessPath
p
        , Just String
r <- [AccessPath -> Maybe String
rootOf AccessPath
p]
        , String -> Text
Text.pack String
r Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Function -> [Text]
fnParams Function
f ]

report :: (Origin, [(Text, AccessPath)]) -> State [Diagnostic CimplePos] ()
report :: (Origin, [(Text, AccessPath)]) -> State [Diagnostic CimplePos] ()
report (Origin String
file Lexeme Text
at AccessPath
freedPath, [(Text, AccessPath)]
sites) = case [(Text, AccessPath)] -> [(Text, AccessPath)]
forall a. Ord a => [a] -> [a]
List.sort [(Text, AccessPath)]
sites of
    [] -> () -> State [Diagnostic CimplePos] ()
forall a. a -> StateT [Diagnostic CimplePos] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (Text
fn, AccessPath
p) : [(Text, AccessPath)]
_ -> do
        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
at
        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 -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
backticks (AccessPath -> Doc AnsiStyle
forall ann. AccessPath -> Doc ann
render AccessPath
freedPath) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"is freed here, and" 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
p)
                Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"still points at it when" 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
fn) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"returns")
            Maybe Text
forall a. Maybe a
Nothing [] []

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
"dangling-field", [Text] -> Text
Text.unlines
    [ Text
"Checks that a struct field whose object gets freed is set to something else"
    , Text
"before the struct is used again."
    , Text
""
    , Text
"**Reason:** the struct outlives the function, and the next code that reads"
    , Text
"the field uses freed memory."
    ]))