{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
module Tokstyle.Linter.PartialFailure (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.Maybe                           (mapMaybe)
import           Data.Set                             (Set)
import qualified Data.Set                             as Set
import           Data.Text                            (Text)
import qualified Data.Text                            as Text
import           Language.Cimple                      (AssignOp (..),
                                                       BinaryOp (..),
                                                       Lexeme (..), NodeF (..),
                                                       UnaryOp (..))
import qualified Language.Cimple                      as C
import           Language.Cimple.Diagnostics          (CimplePos,
                                                       Diagnostic (..),
                                                       DiagnosticLevel (..),
                                                       DiagnosticSpan (..),
                                                       HasDiagnosticInfo (..),
                                                       IsPosition (..),
                                                       warnRich)
import           Prettyprinter                        (pretty, (<+>))
import           Tokstyle.Analysis.AccessPath         (AccessPath (..),
                                                       isPathPrefixOf)
import           Tokstyle.Analysis.Dataflow           (Dataflow (..), solve)
import           Tokstyle.Cimple.Analysis.CFG         (EdgeType (..), Node (..),
                                                       NodeKind (..),
                                                       fromFunction)
import           Tokstyle.Cimple.Analysis.Destructors
import           Tokstyle.Cimple.Analysis.Functions
import           Tokstyle.Common                      (backticks)


-- | Allocation and reallocation functions, with the position of their
-- element count or size argument.
sizedAllocators :: [(Text, Int)]
sizedAllocators :: [(Text, Int)]
sizedAllocators = Map Text Int -> [(Text, Int)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text Int
allocators [(Text, Int)] -> [(Text, Int)] -> [(Text, Int)]
forall a. [a] -> [a] -> [a]
++ [(Text
"realloc", Int
1), (Text
"mem_vrealloc", Int
2), (Text
"mem_brealloc", Int
2)]

-- | Find the fields used as array lengths: those in the size argument of an
-- allocation, directly or through a parameter of the function allocating.
lengthFields :: [Function] -> Set Text
lengthFields :: [Function] -> Set Text
lengthFields [Function]
fns = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ((Node (Lexeme Text) -> [Text]) -> [Node (Lexeme Text)] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Node (Lexeme Text) -> [Text]
fieldsIn ([Node (Lexeme Text)]
direct [Node (Lexeme Text)]
-> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall a. [a] -> [a] -> [a]
++ [Node (Lexeme Text)]
throughWrappers))
  where
    calls :: [(Function, Text, [Node (Lexeme Text)])]
calls = [ (Function
f, Text
name, [Node (Lexeme Text)]
args) | Function
f <- [Function]
fns, Fix (FunctionCall Node (Lexeme Text)
callee [Node (Lexeme Text)]
args) <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe (Function -> Node (Lexeme Text)
fnDefn Function
f), L AlexPosn
_ LexemeClass
_ Text
name <- [Node (Lexeme Text) -> Lexeme Text
calleeLexeme Node (Lexeme Text)
callee] ]
    sizeArg :: [(a, Int)] -> a -> [a] -> [a]
sizeArg [(a, Int)]
table a
name [a]
args = [ a
a | Just Int
i <- [a -> [(a, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
name [(a, Int)]
table], (a
a : [a]
_) <- [Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
i [a]
args] ]
    direct :: [Node (Lexeme Text)]
direct = [[Node (Lexeme Text)]] -> [Node (Lexeme Text)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [(Text, Int)]
-> Text -> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall {a} {a}. Eq a => [(a, Int)] -> a -> [a] -> [a]
sizeArg [(Text, Int)]
sizedAllocators Text
name [Node (Lexeme Text)]
args | (Function
_, Text
name, [Node (Lexeme Text)]
args) <- [(Function, Text, [Node (Lexeme Text)])]
calls ]
    -- The parameters of each function that flow into an allocation size.
    wrappers :: Map Text [Int]
wrappers = ([Int] -> [Int] -> [Int]) -> [(Text, [Int])] -> Map Text [Int]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
(++)
        [ (Function -> Text
fnName Function
f, [Int
i])
        | (Function
f, Text
name, [Node (Lexeme Text)]
args) <- [(Function, Text, [Node (Lexeme Text)])]
calls, Node (Lexeme Text)
a <- [(Text, Int)]
-> Text -> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall {a} {a}. Eq a => [(a, Int)] -> a -> [a] -> [a]
sizeArg [(Text, Int)]
sizedAllocators Text
name [Node (Lexeme Text)]
args
        , (Int
i, Text
p) <- [Int] -> [Text] -> [(Int, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] (Function -> [Text]
fnParams Function
f), Text
p Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Node (Lexeme Text) -> [Text]
varsIn Node (Lexeme Text)
a ]
    throughWrappers :: [Node (Lexeme Text)]
throughWrappers = [[Node (Lexeme Text)]] -> [Node (Lexeme Text)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [(Text, Int)]
-> Text -> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall {a} {a}. Eq a => [(a, Int)] -> a -> [a] -> [a]
sizeArg [ (Text
name, Int
i) | Int
i <- [Int]
is ] Text
name [Node (Lexeme Text)]
args | (Function
_, Text
name, [Node (Lexeme Text)]
args) <- [(Function, Text, [Node (Lexeme Text)])]
calls, Just [Int]
is <- [Text -> Map Text [Int] -> Maybe [Int]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name Map Text [Int]
wrappers] ]
    varsIn :: Node (Lexeme Text) -> [Text]
varsIn Node (Lexeme Text)
e = [ Text
v | Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
v)) <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe Node (Lexeme Text)
e ]
    fieldsIn :: Node (Lexeme Text) -> [Text]
fieldsIn Node (Lexeme Text)
e = [ Text
m | Fix NodeF (Lexeme Text) (Node (Lexeme Text))
n <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe Node (Lexeme Text)
e, Just Text
m <- [NodeF (Lexeme Text) (Node (Lexeme Text)) -> Maybe Text
forall {a} {a}. NodeF (Lexeme a) a -> Maybe a
field NodeF (Lexeme Text) (Node (Lexeme Text))
n] ]
    field :: NodeF (Lexeme a) a -> Maybe a
field = \case
        PointerAccess a
_ (L AlexPosn
_ LexemeClass
_ a
m) -> a -> Maybe a
forall a. a -> Maybe a
Just a
m
        MemberAccess a
_ (L AlexPosn
_ LexemeClass
_ a
m)  -> a -> Maybe a
forall a. a -> Maybe a
Just a
m
        NodeF (Lexeme a) a
_                         -> Maybe a
forall a. Maybe a
Nothing

lastField :: AccessPath -> Maybe Text
lastField :: AccessPath -> Maybe Text
lastField = \case
    PathField AccessPath
_ String
m -> Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
Text.pack String
m)
    AccessPath
_             -> Maybe Text
forall a. Maybe a
Nothing

-- | Dataflow state: the net change of each array length reached through a
-- pointer, and where it first changed.
type Changes = Map AccessPath (Integer, Lexeme Text)

-- | Get the lexeme a diagnostic for an expression points at.
anchor :: C.Node (Lexeme Text) -> Maybe (Lexeme Text)
anchor :: Node (Lexeme Text) -> Maybe (Lexeme Text)
anchor (Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node) = case NodeF (Lexeme Text) (Node (Lexeme Text))
node of
    VarExpr Lexeme Text
l         -> Lexeme Text -> Maybe (Lexeme Text)
forall a. a -> Maybe a
Just Lexeme Text
l
    PointerAccess Node (Lexeme Text)
_ Lexeme Text
l -> Lexeme Text -> Maybe (Lexeme Text)
forall a. a -> Maybe a
Just Lexeme Text
l
    MemberAccess Node (Lexeme Text)
_ Lexeme Text
l  -> Lexeme Text -> Maybe (Lexeme Text)
forall a. a -> Maybe a
Just Lexeme Text
l
    ParenExpr Node (Lexeme Text)
e       -> Node (Lexeme Text) -> Maybe (Lexeme Text)
anchor Node (Lexeme Text)
e
    ArrayAccess Node (Lexeme Text)
e Node (Lexeme Text)
_   -> Node (Lexeme Text) -> Maybe (Lexeme Text)
anchor Node (Lexeme Text)
e
    NodeF (Lexeme Text) (Node (Lexeme Text))
_                 -> Maybe (Lexeme Text)
forall a. Maybe a
Nothing

-- | How much each function adds to array lengths when it succeeds, by the
-- parameter they're reached through. Only lengths that removals lower count.
type Grows = Map Text (Map AccessPath Integer)

data Context = Context
    { Context -> Map Text Shape
ctxShapes      :: Map Text Shape
    , Context -> Grows
ctxGrows       :: Grows
    , Context -> Set Text
ctxLengths     :: Set Text
    , Context -> Destructors
ctxDestructors :: Destructors
    , Context -> Set Text
ctxUndoers     :: Set Text
    -- ^ Functions that failure returns call to undo a call that grew a length.
    }

-- | Replace the variable or parameter a path starts at.
reroot :: AccessPath -> AccessPath -> AccessPath
reroot :: AccessPath -> AccessPath -> AccessPath
reroot AccessPath
new = \case
    PathField AccessPath
p String
m -> AccessPath -> String -> AccessPath
PathField (AccessPath -> AccessPath -> AccessPath
reroot AccessPath
new AccessPath
p) String
m
    PathIndex AccessPath
p String
i -> AccessPath -> String -> AccessPath
PathIndex (AccessPath -> AccessPath -> AccessPath
reroot AccessPath
new AccessPath
p) String
i
    PathDeref AccessPath
p   -> AccessPath -> AccessPath
PathDeref (AccessPath -> AccessPath -> AccessPath
reroot AccessPath
new AccessPath
p)
    AccessPath
_             -> AccessPath
new

paramOf :: AccessPath -> Maybe Int
paramOf :: AccessPath -> Maybe Int
paramOf = \case
    PathParam Int
i   -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
    PathField AccessPath
p String
_ -> AccessPath -> Maybe Int
paramOf AccessPath
p
    PathIndex AccessPath
p String
_ -> AccessPath -> Maybe Int
paramOf AccessPath
p
    PathDeref AccessPath
p   -> AccessPath -> Maybe Int
paramOf AccessPath
p
    AccessPath
_             -> Maybe Int
forall a. Maybe a
Nothing

evalExpr :: Context -> (AccessPath -> Bool) -> C.Node (Lexeme Text) -> Changes -> Changes
evalExpr :: Context
-> (AccessPath -> Bool) -> Node (Lexeme Text) -> Changes -> Changes
evalExpr Context
ctx AccessPath -> Bool
outlives = Node (Lexeme Text) -> Changes -> Changes
go
  where
    go :: Node (Lexeme Text) -> Changes -> Changes
go (Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node) Changes
s = case NodeF (Lexeme Text) (Node (Lexeme Text))
node of
        UnaryExpr UnaryOp
op Node (Lexeme Text)
x | UnaryOp
op UnaryOp -> [UnaryOp] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UnaryOp
UopIncr, UnaryOp
UopDecr] ->
            Node (Lexeme Text) -> Integer -> Changes -> Changes
forall {a}.
(Eq a, Num a) =>
Node (Lexeme Text)
-> a
-> Map AccessPath (a, Lexeme Text)
-> Map AccessPath (a, Lexeme Text)
change Node (Lexeme Text)
x (if UnaryOp
op UnaryOp -> UnaryOp -> Bool
forall a. Eq a => a -> a -> Bool
== UnaryOp
UopIncr then Integer
1 else -Integer
1) (Node (Lexeme Text) -> Changes -> Changes
go Node (Lexeme Text)
x Changes
s)
        AssignExpr Node (Lexeme Text)
l AssignOp
AopPlus Node (Lexeme Text)
r | Just Integer
n <- Node (Lexeme Text) -> Maybe Integer
intLit Node (Lexeme Text)
r -> Node (Lexeme Text) -> Integer -> Changes -> Changes
forall {a}.
(Eq a, Num a) =>
Node (Lexeme Text)
-> a
-> Map AccessPath (a, Lexeme Text)
-> Map AccessPath (a, Lexeme Text)
change Node (Lexeme Text)
l Integer
n (Node (Lexeme Text) -> Changes -> Changes
go Node (Lexeme Text)
r Changes
s)
        AssignExpr Node (Lexeme Text)
l AssignOp
AopMinus Node (Lexeme Text)
r | Just Integer
n <- Node (Lexeme Text) -> Maybe Integer
intLit Node (Lexeme Text)
r -> Node (Lexeme Text) -> Integer -> Changes -> Changes
forall {a}.
(Eq a, Num a) =>
Node (Lexeme Text)
-> a
-> Map AccessPath (a, Lexeme Text)
-> Map AccessPath (a, Lexeme Text)
change Node (Lexeme Text)
l (Integer -> Integer
forall a. Num a => a -> a
negate Integer
n) (Node (Lexeme Text) -> Changes -> Changes
go Node (Lexeme Text)
r Changes
s)
        AssignExpr Node (Lexeme Text)
l AssignOp
_ Node (Lexeme Text)
r -> (Changes -> Changes)
-> (AccessPath -> Changes -> Changes)
-> Maybe AccessPath
-> Changes
-> Changes
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Changes -> Changes
forall a. a -> a
id AccessPath -> Changes -> Changes
forall {a}. AccessPath -> Map AccessPath a -> Map AccessPath a
under (Node (Lexeme Text) -> Maybe AccessPath
accessPath Node (Lexeme Text)
l) (Node (Lexeme Text) -> Changes -> Changes
go Node (Lexeme Text)
r Changes
s)
        FunctionCall Node (Lexeme Text)
callee [Node (Lexeme Text)]
args
            | gone :: [AccessPath]
gone@(AccessPath
_ : [AccessPath]
_) <- (Node (Lexeme Text) -> Maybe AccessPath)
-> [Node (Lexeme Text)] -> [AccessPath]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Node (Lexeme Text) -> Maybe AccessPath
accessPath (Destructors -> Node (Lexeme Text) -> [Node (Lexeme Text)]
destroyed (Context -> Destructors
ctxDestructors Context
ctx) (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node)) ->
                (Changes -> AccessPath -> Changes)
-> Changes -> [AccessPath] -> Changes
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 -> Changes -> Changes)
-> Changes -> AccessPath -> Changes
forall a b c. (a -> b -> c) -> b -> a -> c
flip AccessPath -> Changes -> Changes
forall {a}. AccessPath -> Map AccessPath a -> Map AccessPath a
under) ((Changes -> Node (Lexeme Text) -> Changes)
-> Changes -> [Node (Lexeme Text)] -> Changes
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ((Node (Lexeme Text) -> Changes -> Changes)
-> Changes -> Node (Lexeme Text) -> Changes
forall a b c. (a -> b -> c) -> b -> a -> c
flip Node (Lexeme Text) -> Changes -> Changes
go) Changes
s [Node (Lexeme Text)]
args) [AccessPath]
gone
            | L AlexPosn
_ LexemeClass
_ Text
name <- Node (Lexeme Text) -> Lexeme Text
calleeLexeme Node (Lexeme Text)
callee, Just Map AccessPath Integer
m <- Text -> Grows -> Maybe (Map AccessPath Integer)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name (Context -> Grows
ctxGrows Context
ctx) ->
                (Changes -> (AccessPath, Integer) -> Changes)
-> Changes -> [(AccessPath, Integer)] -> Changes
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (\Changes
acc (AccessPath
q, Integer
n) -> Changes -> (AccessPath -> Changes) -> Maybe AccessPath -> Changes
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Changes
acc (\AccessPath
p -> AccessPath -> Integer -> Lexeme Text -> Changes -> Changes
forall {a} {b}.
(Eq a, Num a) =>
AccessPath
-> a -> b -> Map AccessPath (a, b) -> Map AccessPath (a, b)
changeAt AccessPath
p Integer
n (Node (Lexeme Text) -> Lexeme Text
calleeLexeme Node (Lexeme Text)
callee) Changes
acc) ([Node (Lexeme Text)] -> AccessPath -> Maybe AccessPath
argPath [Node (Lexeme Text)]
args AccessPath
q))
                    ((Changes -> Node (Lexeme Text) -> Changes)
-> Changes -> [Node (Lexeme Text)] -> Changes
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ((Node (Lexeme Text) -> Changes -> Changes)
-> Changes -> Node (Lexeme Text) -> Changes
forall a b c. (a -> b -> c) -> b -> a -> c
flip Node (Lexeme Text) -> Changes -> Changes
go) Changes
s [Node (Lexeme Text)]
args) (Map AccessPath Integer -> [(AccessPath, Integer)]
forall k a. Map k a -> [(k, a)]
Map.toList Map AccessPath Integer
m)
        NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> (Changes -> Node (Lexeme Text) -> Changes)
-> Changes -> [Node (Lexeme Text)] -> Changes
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ((Node (Lexeme Text) -> Changes -> Changes)
-> Changes -> Node (Lexeme Text) -> Changes
forall a b c. (a -> b -> c) -> b -> a -> c
flip Node (Lexeme Text) -> Changes -> Changes
go) Changes
s ((Node (Lexeme Text)
 -> [Node (Lexeme Text)] -> [Node (Lexeme Text)])
-> [Node (Lexeme Text)]
-> NodeF (Lexeme Text) (Node (Lexeme Text))
-> [Node (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) (Node (Lexeme Text))
node)
    -- Forget what is known about a path once it is reassigned or destroyed.
    under :: AccessPath -> Map AccessPath a -> Map AccessPath a
under AccessPath
p = (AccessPath -> a -> Bool) -> Map AccessPath a -> Map AccessPath a
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\AccessPath
k a
_ -> Bool -> Bool
not (AccessPath
p AccessPath -> AccessPath -> Bool
`isPathPrefixOf` AccessPath
k))
    argPath :: [Node (Lexeme Text)] -> AccessPath -> Maybe AccessPath
argPath [Node (Lexeme Text)]
args AccessPath
q = do
        Int
i <- AccessPath -> Maybe Int
paramOf AccessPath
q
        (Node (Lexeme Text)
a : [Node (Lexeme Text)]
_) <- [Node (Lexeme Text)] -> Maybe [Node (Lexeme Text)]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall a. Int -> [a] -> [a]
drop Int
i [Node (Lexeme Text)]
args)
        AccessPath
base <- Node (Lexeme Text) -> Maybe AccessPath
accessPath Node (Lexeme Text)
a
        AccessPath -> Maybe AccessPath
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AccessPath -> AccessPath -> AccessPath
reroot AccessPath
base AccessPath
q)
    change :: Node (Lexeme Text)
-> a
-> Map AccessPath (a, Lexeme Text)
-> Map AccessPath (a, Lexeme Text)
change Node (Lexeme Text)
x a
n Map AccessPath (a, Lexeme Text)
s = case (Node (Lexeme Text) -> Maybe AccessPath
accessPath Node (Lexeme Text)
x, Node (Lexeme Text) -> Maybe (Lexeme Text)
anchor Node (Lexeme Text)
x) of
        (Just AccessPath
p, Just Lexeme Text
at) -> AccessPath
-> a
-> Lexeme Text
-> Map AccessPath (a, Lexeme Text)
-> Map AccessPath (a, Lexeme Text)
forall {a} {b}.
(Eq a, Num a) =>
AccessPath
-> a -> b -> Map AccessPath (a, b) -> Map AccessPath (a, b)
changeAt AccessPath
p a
n Lexeme Text
at Map AccessPath (a, Lexeme Text)
s
        (Maybe AccessPath, Maybe (Lexeme Text))
_                 -> Map AccessPath (a, Lexeme Text)
s
    changeAt :: AccessPath
-> a -> b -> Map AccessPath (a, b) -> Map AccessPath (a, b)
changeAt AccessPath
p a
n b
at Map AccessPath (a, b)
s
        | AccessPath -> Bool
outlives AccessPath
p = (Maybe (a, b) -> Maybe (a, b))
-> AccessPath -> Map AccessPath (a, b) -> Map AccessPath (a, b)
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (a -> b -> Maybe (a, b) -> Maybe (a, b)
forall {a} {b}.
(Eq a, Num a) =>
a -> b -> Maybe (a, b) -> Maybe (a, b)
bump a
n b
at) AccessPath
p Map AccessPath (a, b)
s
        | Bool
otherwise  = Map AccessPath (a, b)
s
    bump :: a -> b -> Maybe (a, b) -> Maybe (a, b)
bump a
n b
at = \case
        Maybe (a, b)
Nothing        -> (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just (a
n, b
at)
        Just (a
m, b
at')  | a
m a -> a -> a
forall a. Num a => a -> a -> a
+ a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 -> Maybe (a, b)
forall a. Maybe a
Nothing
                       | Bool
otherwise  -> (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just (a
m a -> a -> a
forall a. Num a => a -> a -> a
+ a
n, b
at')

-- | Dataflow state: the length changes, the calls each local may hold the
-- result of, and the calls each local was looked up from.
type St = (Changes, Map Text (Set (Lexeme Text)), Map Text (Set (Lexeme Text)))

-- | The state at each exit of a function, with the expression it returns.
exits :: Context -> Function -> [(Node, Maybe (C.Node (Lexeme Text)), Changes)]
exits :: Context
-> Function -> [(Node, Maybe (Node (Lexeme Text)), Changes)]
exits Context
ctx Function
fn =
    [ (Node
n, Node -> Maybe (Node (Lexeme Text))
returned Node
n, if Node -> Bool
cleaned Node
n then ((Integer, Lexeme Text) -> Bool) -> Changes -> Changes
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool -> Bool
not (Bool -> Bool)
-> ((Integer, Lexeme Text) -> Bool)
-> (Integer, Lexeme Text)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lexeme Text -> Bool
grown (Lexeme Text -> Bool)
-> ((Integer, Lexeme Text) -> Lexeme Text)
-> (Integer, Lexeme Text)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer, Lexeme Text) -> Lexeme Text
forall a b. (a, b) -> b
snd) Changes
s else Changes
s)
    | (Node
n, [Edge]
out) <- 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]
out
    , 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 (Changes
s, Map Text (Set (Lexeme Text))
_, Map Text (Set (Lexeme Text))
_) = Node -> St -> St
stepSt Node
n St
st
    ]
  where
    (Node
entry, Map Node [Edge]
cfg) = Node (Lexeme Text) -> (Node, Map Node [Edge])
fromFunction (Function -> Node (Lexeme Text)
fnDefn Function
fn)
    outlives :: AccessPath -> Bool
outlives AccessPath
p = AccessPath -> Bool
throughPointer AccessPath
p Bool -> Bool -> Bool
&& Bool -> (Text -> Bool) -> Maybe Text -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Context -> Set Text
ctxLengths Context
ctx) (AccessPath -> Maybe Text
lastField AccessPath
p)
    isExit :: Node -> Bool
isExit (Node Int
_ NodeKind
ExitNode) = Bool
True
    isExit Node
_                 = Bool
False
    returned :: Node -> Maybe (Node (Lexeme Text))
returned = \case
        Node Int
_ (StmtNode (Fix (Return Maybe (Node (Lexeme Text))
e))) -> Maybe (Node (Lexeme Text))
e
        Node
_                                  -> Maybe (Node (Lexeme Text))
forall a. Maybe a
Nothing

    stepSt :: Node -> St -> St
    stepSt :: Node -> St -> St
stepSt Node
n (Changes
s, Map Text (Set (Lexeme Text))
rs, Map Text (Set (Lexeme Text))
found) =
        ((Changes -> Node (Lexeme Text) -> Changes)
-> Changes -> [Node (Lexeme Text)] -> Changes
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ((Node (Lexeme Text) -> Changes -> Changes)
-> Changes -> Node (Lexeme Text) -> Changes
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Context
-> (AccessPath -> Bool) -> Node (Lexeme Text) -> Changes -> Changes
evalExpr Context
ctx AccessPath -> Bool
outlives)) Changes
s (Node -> [Node (Lexeme Text)]
nodeExprs Node
n), Map Text (Set (Lexeme Text))
-> Node -> Map Text (Set (Lexeme Text))
results Map Text (Set (Lexeme Text))
rs Node
n, Map Text (Set (Lexeme Text))
-> Map Text (Set (Lexeme Text))
-> Node
-> Map Text (Set (Lexeme Text))
forall {a}.
Ord a =>
Map Text (Set a) -> Map Text (Set a) -> Node -> Map Text (Set a)
derive Map Text (Set (Lexeme Text))
rs Map Text (Set (Lexeme Text))
found Node
n)
    assigned :: Node -> [(Text, Maybe (Node (Lexeme Text)))]
assigned Node
n = case Node
n of
        Node Int
_ (StmtNode (Fix (VarDeclStmt (Fix (VarDecl Node (Lexeme Text)
_ (L AlexPosn
_ LexemeClass
_ Text
v) [Node (Lexeme Text)]
_)) Maybe (Node (Lexeme Text))
ini))) -> [(Text
v, Node (Lexeme Text) -> Node (Lexeme Text)
bare (Node (Lexeme Text) -> Node (Lexeme Text))
-> Maybe (Node (Lexeme Text)) -> Maybe (Node (Lexeme Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Node (Lexeme Text))
ini)]
        Node
_ -> [ (Text
v, Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
forall a. a -> Maybe a
Just (Node (Lexeme Text) -> Node (Lexeme Text)
bare Node (Lexeme Text)
r)) | Node (Lexeme Text)
e <- Node -> [Node (Lexeme Text)]
nodeExprs Node
n, Fix (AssignExpr (Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
v))) AssignOp
_ Node (Lexeme Text)
r) <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe Node (Lexeme Text)
e ]
    results :: Map Text (Set (Lexeme Text))
-> Node -> Map Text (Set (Lexeme Text))
results Map Text (Set (Lexeme Text))
rs Node
n = (Map Text (Set (Lexeme Text))
 -> (Text, Maybe (Node (Lexeme Text)))
 -> Map Text (Set (Lexeme Text)))
-> Map Text (Set (Lexeme Text))
-> [(Text, Maybe (Node (Lexeme Text)))]
-> Map Text (Set (Lexeme Text))
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (\Map Text (Set (Lexeme Text))
m (Text
v, Maybe (Node (Lexeme Text))
r) -> case Maybe (Node (Lexeme Text))
r of
        Just (Fix (FunctionCall Node (Lexeme Text)
callee [Node (Lexeme Text)]
_)) -> Text
-> Set (Lexeme Text)
-> Map Text (Set (Lexeme Text))
-> Map Text (Set (Lexeme Text))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
v (Lexeme Text -> Set (Lexeme Text)
forall a. a -> Set a
Set.singleton (Node (Lexeme Text) -> Lexeme Text
calleeLexeme Node (Lexeme Text)
callee)) Map Text (Set (Lexeme Text))
m
        Maybe (Node (Lexeme Text))
_                                  -> Text
-> Map Text (Set (Lexeme Text)) -> Map Text (Set (Lexeme Text))
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
v Map Text (Set (Lexeme Text))
m) Map Text (Set (Lexeme Text))
rs (Node -> [(Text, Maybe (Node (Lexeme Text)))]
assigned Node
n)
    derive :: Map Text (Set a) -> Map Text (Set a) -> Node -> Map Text (Set a)
derive Map Text (Set a)
rs Map Text (Set a)
found Node
n = (Map Text (Set a)
 -> (Text, Maybe (Node (Lexeme Text))) -> Map Text (Set a))
-> Map Text (Set a)
-> [(Text, Maybe (Node (Lexeme Text)))]
-> Map Text (Set a)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (\Map Text (Set a)
m (Text
v, Maybe (Node (Lexeme Text))
r) ->
        let ls :: Set a
ls = [Set a] -> Set a
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [ Set a
l | Just (Fix (FunctionCall Node (Lexeme Text)
_ [Node (Lexeme Text)]
args)) <- [Maybe (Node (Lexeme Text))
r], Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
w)) <- (Node (Lexeme Text) -> Node (Lexeme Text))
-> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall a b. (a -> b) -> [a] -> [b]
map Node (Lexeme Text) -> Node (Lexeme Text)
bare [Node (Lexeme Text)]
args, Just Set a
l <- [Text -> Map Text (Set a) -> Maybe (Set a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
w Map Text (Set a)
rs] ]
        in if Set a -> Bool
forall a. Set a -> Bool
Set.null Set a
ls then Text -> Map Text (Set a) -> Map Text (Set a)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
v Map Text (Set a)
m else Text -> Set a -> Map Text (Set a) -> Map Text (Set a)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
v Set a
ls Map Text (Set a)
m) Map Text (Set a)
found (Node -> [(Text, Maybe (Node (Lexeme Text)))]
assigned Node
n)
    dropFrom :: Set b -> Map k (a, b) -> Map k (a, b)
dropFrom Set b
ls = ((a, b) -> Bool) -> Map k (a, b) -> Map k (a, b)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter ((b -> Set b -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set b
ls) (b -> Bool) -> ((a, b) -> b) -> (a, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> b
forall a b. (a, b) -> b
snd)
    -- Calling what other failure returns call to undo a call counts as undoing
    -- it.
    grown :: Lexeme Text -> Bool
grown (L AlexPosn
_ LexemeClass
_ Text
g) = Text
g Text -> Grows -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Context -> Grows
ctxGrows Context
ctx
    cleaned :: Node -> Bool
cleaned = \case
        Node Int
_ (StmtNode Node (Lexeme Text)
ret) -> Bool -> (Set Text -> Bool) -> Maybe (Set Text) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> Bool
not (Bool -> Bool) -> (Set Text -> Bool) -> Set Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Text -> Bool
forall a. Set a -> Bool
Set.null (Set Text -> Bool) -> (Set Text -> Set Text) -> Set Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection (Context -> Set Text
ctxUndoers Context
ctx)) (Node (Lexeme Text)
-> [(Node (Lexeme Text), Set Text)] -> Maybe (Set Text)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Node (Lexeme Text)
ret (Context -> Function -> [(Node (Lexeme Text), Set Text)]
cleanupsIn Context
ctx Function
fn))
        Node
_                     -> Bool
False

    -- Nothing changed where a call failed or a lookup of its result found
    -- nothing, and nothing is left to undo where an array is empty.
    edge :: Node
-> EdgeType
-> (Map AccessPath (a, Lexeme Text), Map Text (Set (Lexeme Text)),
    Map Text (Set (Lexeme Text)))
-> (Map AccessPath (a, Lexeme Text), Map Text (Set (Lexeme Text)),
    Map Text (Set (Lexeme Text)))
edge Node
n EdgeType
e (Map AccessPath (a, Lexeme Text)
s, Map Text (Set (Lexeme Text))
rs, Map Text (Set (Lexeme Text))
found) = case Node
n of
        Node Int
_ (BranchNode Node (Lexeme Text)
cond) ->
            let failed :: Set (Lexeme Text)
failed = [Lexeme Text] -> Set (Lexeme Text)
forall a. Ord a => [a] -> Set a
Set.fromList [ Lexeme Text
l | Node (Lexeme Text)
c <- Map Text (Set (Lexeme Text))
-> Node (Lexeme Text) -> [Node (Lexeme Text)]
forall {t}.
Eq t =>
Map t (Set (Lexeme t))
-> Fix (NodeF (Lexeme t)) -> [Fix (NodeF (Lexeme t))]
resolve Map Text (Set (Lexeme Text))
rs Node (Lexeme Text)
cond, (Lexeme Text
l, Outcome
Failure) <- Node (Lexeme Text) -> EdgeType -> [(Lexeme Text, Outcome)]
knownOn Node (Lexeme Text)
c EdgeType
e ]
                missing :: Set (Lexeme Text)
missing = [Set (Lexeme Text)] -> Set (Lexeme Text)
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [ Set (Lexeme Text)
ls | Just (Text
v, EdgeType
nullOn) <- [(Node (Lexeme Text) -> Maybe Text)
-> Node (Lexeme Text) -> Maybe (Text, EdgeType)
forall a.
(Node (Lexeme Text) -> Maybe a)
-> Node (Lexeme Text) -> Maybe (a, EdgeType)
nullTest Node (Lexeme Text) -> Maybe Text
var Node (Lexeme Text)
cond], EdgeType
nullOn EdgeType -> EdgeType -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeType
e, Just Set (Lexeme Text)
ls <- [Text -> Map Text (Set (Lexeme Text)) -> Maybe (Set (Lexeme Text))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
v Map Text (Set (Lexeme Text))
found] ]
            in (Node (Lexeme Text)
-> EdgeType
-> Map AccessPath (a, Lexeme Text)
-> Map AccessPath (a, Lexeme Text)
forall {a}.
Node (Lexeme Text)
-> EdgeType -> Map AccessPath a -> Map AccessPath a
emptied Node (Lexeme Text)
cond EdgeType
e (Set (Lexeme Text)
-> Map AccessPath (a, Lexeme Text)
-> Map AccessPath (a, Lexeme Text)
forall {b} {k} {a}. Ord b => Set b -> Map k (a, b) -> Map k (a, b)
dropFrom (Set (Lexeme Text) -> Set (Lexeme Text) -> Set (Lexeme Text)
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set (Lexeme Text)
failed Set (Lexeme Text)
missing) Map AccessPath (a, Lexeme Text)
s), Map Text (Set (Lexeme Text))
rs, Map Text (Set (Lexeme Text))
found)
        Node
_ -> (Map AccessPath (a, Lexeme Text)
s, Map Text (Set (Lexeme Text))
rs, Map Text (Set (Lexeme Text))
found)
    emptied :: Node (Lexeme Text)
-> EdgeType -> Map AccessPath a -> Map AccessPath a
emptied Node (Lexeme Text)
cond EdgeType
e Map AccessPath a
s = case (Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
unFix' (Node (Lexeme Text) -> Node (Lexeme Text)
strip Node (Lexeme Text)
cond), EdgeType
e) of
        (BinaryExpr Node (Lexeme Text)
x BinaryOp
BopEq Node (Lexeme Text)
r, EdgeType
TrueBranch) | Node (Lexeme Text) -> Maybe Integer
intLit Node (Lexeme Text)
r Maybe Integer -> Maybe Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
0, Just AccessPath
p <- Node (Lexeme Text) -> Maybe AccessPath
accessPath Node (Lexeme Text)
x -> AccessPath -> Map AccessPath a -> Map AccessPath a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete AccessPath
p Map AccessPath a
s
        (BinaryExpr Node (Lexeme Text)
x BinaryOp
BopNe Node (Lexeme Text)
r, EdgeType
FalseBranch) | Node (Lexeme Text) -> Maybe Integer
intLit Node (Lexeme Text)
r Maybe Integer -> Maybe Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
0, Just AccessPath
p <- Node (Lexeme Text) -> Maybe AccessPath
accessPath Node (Lexeme Text)
x -> AccessPath -> Map AccessPath a -> Map AccessPath a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete AccessPath
p Map AccessPath a
s
        (NodeF (Lexeme Text) (Node (Lexeme Text)), EdgeType)
_ -> Map AccessPath a
s
    var :: Node (Lexeme Text) -> Maybe Text
var Node (Lexeme Text)
x = case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
unFix' (Node (Lexeme Text) -> Node (Lexeme Text)
strip Node (Lexeme Text)
x) of
        VarExpr (L AlexPosn
_ LexemeClass
_ Text
v) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
v
        NodeF (Lexeme Text) (Node (Lexeme Text))
_                 -> Maybe Text
forall a. Maybe a
Nothing
    knownOn :: Node (Lexeme Text) -> EdgeType -> [(Lexeme Text, Outcome)]
knownOn Node (Lexeme Text)
cond EdgeType
e = case (Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
unFix' (Node (Lexeme Text) -> Node (Lexeme Text)
strip Node (Lexeme Text)
cond), EdgeType
e) of
        (BinaryExpr Node (Lexeme Text)
l BinaryOp
BopAnd Node (Lexeme Text)
r, EdgeType
TrueBranch) -> Node (Lexeme Text) -> EdgeType -> [(Lexeme Text, Outcome)]
knownOn Node (Lexeme Text)
l EdgeType
e [(Lexeme Text, Outcome)]
-> [(Lexeme Text, Outcome)] -> [(Lexeme Text, Outcome)]
forall a. [a] -> [a] -> [a]
++ Node (Lexeme Text) -> EdgeType -> [(Lexeme Text, Outcome)]
knownOn Node (Lexeme Text)
r EdgeType
e
        (BinaryExpr Node (Lexeme Text)
l BinaryOp
BopOr Node (Lexeme Text)
r, EdgeType
FalseBranch) -> Node (Lexeme Text) -> EdgeType -> [(Lexeme Text, Outcome)]
knownOn Node (Lexeme Text)
l EdgeType
e [(Lexeme Text, Outcome)]
-> [(Lexeme Text, Outcome)] -> [(Lexeme Text, Outcome)]
forall a. [a] -> [a] -> [a]
++ Node (Lexeme Text) -> EdgeType -> [(Lexeme Text, Outcome)]
knownOn Node (Lexeme Text)
r EdgeType
e
        -- Comparing an ID with the one we expect treats any other as failure.
        (BinaryExpr (Fix (FunctionCall Node (Lexeme Text)
callee [Node (Lexeme Text)]
_)) BinaryOp
op Node (Lexeme Text)
r, EdgeType
_)
            | L AlexPosn
_ LexemeClass
_ Text
g <- Node (Lexeme Text) -> Lexeme Text
calleeLexeme Node (Lexeme Text)
callee, Just Shape
IdShape <- Text -> Map Text Shape -> Maybe Shape
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
g (Context -> Map Text Shape
ctxShapes Context
ctx)
            , Just Integer
k <- Node (Lexeme Text) -> Maybe Integer
intLit Node (Lexeme Text)
r, Integer
k Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0, BinaryOp
op BinaryOp -> [BinaryOp] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BinaryOp
BopEq, BinaryOp
BopNe] ->
                [(Node (Lexeme Text) -> Lexeme Text
calleeLexeme Node (Lexeme Text)
callee, if (BinaryOp
op BinaryOp -> BinaryOp -> Bool
forall a. Eq a => a -> a -> Bool
== BinaryOp
BopEq) Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== (EdgeType
e EdgeType -> EdgeType -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeType
TrueBranch) then Outcome
Success else Outcome
Failure)]
        (NodeF (Lexeme Text) (Node (Lexeme Text)), EdgeType)
_ -> case (Map Text Shape
-> Node (Lexeme Text) -> Maybe (Lexeme Text, Outcome)
branchOn (Context -> Map Text Shape
ctxShapes Context
ctx) Node (Lexeme Text)
cond, EdgeType
e) of
            (Just (Lexeme Text
l, Outcome
o), EdgeType
TrueBranch)  -> [(Lexeme Text
l, Outcome
o)]
            (Just (Lexeme Text
l, Outcome
o), EdgeType
FalseBranch) -> [(Lexeme Text
l, if Outcome
o Outcome -> Outcome -> Bool
forall a. Eq a => a -> a -> Bool
== Outcome
Success then Outcome
Failure else Outcome
Success)]
            (Maybe (Lexeme Text, Outcome), EdgeType)
_                          -> []
    -- Also read the condition with each local replaced by the call it came
    -- from, so `if (rc < 0)` tests that call.
    resolve :: Map t (Set (Lexeme t))
-> Fix (NodeF (Lexeme t)) -> [Fix (NodeF (Lexeme t))]
resolve Map t (Set (Lexeme t))
rs Fix (NodeF (Lexeme t))
cond = Fix (NodeF (Lexeme t))
cond Fix (NodeF (Lexeme t))
-> [Fix (NodeF (Lexeme t))] -> [Fix (NodeF (Lexeme t))]
forall a. a -> [a] -> [a]
:
        [ t -> Lexeme t -> Fix (NodeF (Lexeme t)) -> Fix (NodeF (Lexeme t))
forall {t}.
Eq t =>
t -> Lexeme t -> Fix (NodeF (Lexeme t)) -> Fix (NodeF (Lexeme t))
subst t
v Lexeme t
l Fix (NodeF (Lexeme t))
cond | (t
v, Set (Lexeme t)
ls) <- Map t (Set (Lexeme t)) -> [(t, Set (Lexeme t))]
forall k a. Map k a -> [(k, a)]
Map.toList Map t (Set (Lexeme t))
rs, Lexeme t
l <- Set (Lexeme t) -> [Lexeme t]
forall a. Set a -> [a]
Set.toList Set (Lexeme t)
ls ]
    subst :: t -> Lexeme t -> Fix (NodeF (Lexeme t)) -> Fix (NodeF (Lexeme t))
subst t
v Lexeme t
l (Fix NodeF (Lexeme t) (Fix (NodeF (Lexeme t)))
node) = case NodeF (Lexeme t) (Fix (NodeF (Lexeme t)))
node of
        VarExpr (L AlexPosn
_ LexemeClass
_ t
v') | t
v' t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
v -> NodeF (Lexeme t) (Fix (NodeF (Lexeme t))) -> Fix (NodeF (Lexeme t))
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Fix (NodeF (Lexeme t))
-> [Fix (NodeF (Lexeme t))]
-> NodeF (Lexeme t) (Fix (NodeF (Lexeme t)))
forall lexeme a. a -> [a] -> NodeF lexeme a
FunctionCall (NodeF (Lexeme t) (Fix (NodeF (Lexeme t))) -> Fix (NodeF (Lexeme t))
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Lexeme t -> NodeF (Lexeme t) (Fix (NodeF (Lexeme t)))
forall lexeme a. lexeme -> NodeF lexeme a
VarExpr Lexeme t
l)) [])
        NodeF (Lexeme t) (Fix (NodeF (Lexeme t)))
_                            -> NodeF (Lexeme t) (Fix (NodeF (Lexeme t))) -> Fix (NodeF (Lexeme t))
forall (f :: * -> *). f (Fix f) -> Fix f
Fix ((Fix (NodeF (Lexeme t)) -> Fix (NodeF (Lexeme t)))
-> NodeF (Lexeme t) (Fix (NodeF (Lexeme t)))
-> NodeF (Lexeme t) (Fix (NodeF (Lexeme t)))
forall a b. (a -> b) -> NodeF (Lexeme t) a -> NodeF (Lexeme t) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t -> Lexeme t -> Fix (NodeF (Lexeme t)) -> Fix (NodeF (Lexeme t))
subst t
v Lexeme t
l) NodeF (Lexeme t) (Fix (NodeF (Lexeme t)))
node)

    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
stepSt
        , edgeTransfer :: Node -> EdgeType -> St -> St
edgeTransfer = Node -> EdgeType -> St -> St
forall {a}.
Node
-> EdgeType
-> (Map AccessPath (a, Lexeme Text), Map Text (Set (Lexeme Text)),
    Map Text (Set (Lexeme Text)))
-> (Map AccessPath (a, Lexeme Text), Map Text (Set (Lexeme Text)),
    Map Text (Set (Lexeme Text)))
edge
        , merge :: St -> St -> St
merge        = \(Changes
a, Map Text (Set (Lexeme Text))
ra, Map Text (Set (Lexeme Text))
fa) (Changes
b, Map Text (Set (Lexeme Text))
rb, Map Text (Set (Lexeme Text))
fb) ->
            (((Integer, Lexeme Text)
 -> (Integer, Lexeme Text) -> (Integer, Lexeme Text))
-> Changes -> Changes -> Changes
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (\(Integer, Lexeme Text)
x (Integer, Lexeme Text)
y -> if (Integer, Lexeme Text) -> Integer
forall a b. (a, b) -> a
fst (Integer, Lexeme Text)
x Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0 then (Integer, Lexeme Text)
x else (Integer, Lexeme Text)
y) Changes
a Changes
b, (Set (Lexeme Text) -> Set (Lexeme Text) -> Set (Lexeme Text))
-> Map Text (Set (Lexeme Text))
-> Map Text (Set (Lexeme Text))
-> Map Text (Set (Lexeme Text))
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set (Lexeme Text) -> Set (Lexeme Text) -> Set (Lexeme Text)
forall a. Ord a => Set a -> Set a -> Set a
Set.union Map Text (Set (Lexeme Text))
ra Map Text (Set (Lexeme Text))
rb, (Set (Lexeme Text) -> Set (Lexeme Text) -> Set (Lexeme Text))
-> Map Text (Set (Lexeme Text))
-> Map Text (Set (Lexeme Text))
-> Map Text (Set (Lexeme Text))
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set (Lexeme Text) -> Set (Lexeme Text) -> Set (Lexeme Text)
forall a. Ord a => Set a -> Set a -> Set a
Set.union Map Text (Set (Lexeme Text))
fa Map Text (Set (Lexeme Text))
fb)
        , initial :: St
initial      = (Changes
forall k a. Map k a
Map.empty, Map Text (Set (Lexeme Text))
forall k a. Map k a
Map.empty, Map Text (Set (Lexeme Text))
forall k a. Map k a
Map.empty)
        }

-- | Find the calls each failure return makes on something looked up from the
-- result of a call that grew a length.
cleanupsIn :: Context -> Function -> [(C.Node (Lexeme Text), Set Text)]
cleanupsIn :: Context -> Function -> [(Node (Lexeme Text), Set Text)]
cleanupsIn Context
ctx Function
fn =
    [ (Node (Lexeme Text)
ret, [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList [ Text
name | Fix (FunctionCall Node (Lexeme Text)
callee [Node (Lexeme Text)]
args) <- (Node (Lexeme Text) -> [Node (Lexeme Text)])
-> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Node (Lexeme Text) -> [Node (Lexeme Text)]
onTheWay [Node (Lexeme Text)]
before
                                , L AlexPosn
_ LexemeClass
_ Text
name <- [Node (Lexeme Text) -> Lexeme Text
calleeLexeme Node (Lexeme Text)
callee], (Node (Lexeme Text) -> Bool) -> [Node (Lexeme Text)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Set String -> Node (Lexeme Text) -> Bool
localIn Set String
found) [Node (Lexeme Text)]
args ])
    | (Node (Lexeme Text)
ret, [Node (Lexeme Text)]
before) <- Function -> [(Node (Lexeme Text), [Node (Lexeme Text)])]
failureReturns Function
fn ]
  where
    found :: Set String
found = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [ String
v | (String
v, Fix (FunctionCall Node (Lexeme Text)
_ [Node (Lexeme Text)]
args)) <- [(String, Node (Lexeme Text))]
given, (Node (Lexeme Text) -> Bool) -> [Node (Lexeme Text)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Set String -> Node (Lexeme Text) -> Bool
localIn Set String
grown) [Node (Lexeme Text)]
args ]
    grown :: Set String
grown = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList
        [ String
v | (String
v, Fix (FunctionCall Node (Lexeme Text)
callee [Node (Lexeme Text)]
_)) <- [(String, Node (Lexeme Text))]
given, L AlexPosn
_ LexemeClass
_ Text
g <- [Node (Lexeme Text) -> Lexeme Text
calleeLexeme Node (Lexeme Text)
callee], Text
g Text -> Grows -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Context -> Grows
ctxGrows Context
ctx ]
    given :: [(String, Node (Lexeme Text))]
given = [ (String
v, Node (Lexeme Text) -> Node (Lexeme Text)
bare Node (Lexeme Text)
r) | (String
v, Just Node (Lexeme Text)
r) <- Node (Lexeme Text) -> [(String, Maybe (Node (Lexeme Text)))]
localDecls (Function -> Node (Lexeme Text)
fnDefn Function
fn) ]
        [(String, Node (Lexeme Text))]
-> [(String, Node (Lexeme Text))] -> [(String, Node (Lexeme Text))]
forall a. [a] -> [a] -> [a]
++ [ (String
v, Node (Lexeme Text) -> Node (Lexeme Text)
bare Node (Lexeme Text)
r) | (String
v, [Node (Lexeme Text)]
rs) <- Map String [Node (Lexeme Text)] -> [(String, [Node (Lexeme Text)])]
forall k a. Map k a -> [(k, a)]
Map.toList (Node (Lexeme Text) -> Map String [Node (Lexeme Text)]
assignments (Function -> Node (Lexeme Text)
fnDefn Function
fn)), Node (Lexeme Text)
r <- [Node (Lexeme Text)]
rs ]
    localIn :: Set String -> Node (Lexeme Text) -> Bool
localIn Set String
vs Node (Lexeme Text)
a = case Node (Lexeme Text) -> Node (Lexeme Text)
bare Node (Lexeme Text)
a of
        Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
v)) -> Text -> String
Text.unpack Text
v String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
vs
        Node (Lexeme Text)
_                       -> Bool
False

-- | Find the failure returns of a function with the array lengths changed and
-- not restored on the way there.
failures :: Context -> Function -> [(C.Node (Lexeme Text), Changes)]
failures :: Context -> Function -> [(Node (Lexeme Text), Changes)]
failures Context
ctx Function
fn =
    [ (Node (Lexeme Text)
ret, Changes
changes)
    | (Node Int
_ (StmtNode ret :: Node (Lexeme Text)
ret@(Fix (Return Maybe (Node (Lexeme Text))
e))), Maybe (Node (Lexeme Text))
_, Changes
changes) <- Context
-> Function -> [(Node, Maybe (Node (Lexeme Text)), Changes)]
exits Context
ctx Function
fn
    , Function -> Maybe (Node (Lexeme Text)) -> Bool
isFailure Function
fn Maybe (Node (Lexeme Text))
e
    , Node (Lexeme Text)
ret Node (Lexeme Text) -> [Node (Lexeme Text)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Node (Lexeme Text)]
stopped
    , Bool -> Bool
not (Changes -> Bool
forall k a. Map k a -> Bool
Map.null Changes
changes)
    ]
  where
    -- A return after `abort` or `LOGGER_FATAL` never runs.
    stopped :: [Node (Lexeme Text)]
stopped = [ Node (Lexeme Text)
ret | (Node (Lexeme Text)
ret, [Node (Lexeme Text)]
before) <- Function -> [(Node (Lexeme Text), [Node (Lexeme Text)])]
failureReturns Function
fn
                    , L AlexPosn
_ LexemeClass
_ Text
g <- [ Node (Lexeme Text) -> Lexeme Text
calleeLexeme Node (Lexeme Text)
callee | Fix (FunctionCall Node (Lexeme Text)
callee [Node (Lexeme Text)]
_) <- (Node (Lexeme Text) -> [Node (Lexeme Text)])
-> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Node (Lexeme Text) -> [Node (Lexeme Text)]
universe [Node (Lexeme Text)]
before ]
                    , Text
g Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"abort", Text
"LOGGER_FATAL"] ]

-- | Find how each function changes the lengths in @shrunk@ when it succeeds.
growers :: Context -> Set Text -> [Function] -> Grows
growers :: Context -> Set Text -> [Function] -> Grows
growers Context
ctx Set Text
shrunk [Function]
fns = [(Text, Map AccessPath Integer)] -> Grows
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Function -> Text
fnName Function
f, Map AccessPath Integer
m)
    | Function
f <- [Function]
fns
    , let param :: AccessPath -> Maybe Int
param AccessPath
p = AccessPath -> Maybe String
rootOf AccessPath
p Maybe String -> (String -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \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
f)
          m :: Map AccessPath Integer
m = (Integer -> Integer -> Integer)
-> [Map AccessPath Integer] -> Map AccessPath Integer
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith Integer -> Integer -> Integer
forall a b. a -> b -> a
const
            [ [(AccessPath, Integer)] -> Map AccessPath Integer
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (AccessPath -> AccessPath -> AccessPath
reroot (Int -> AccessPath
PathParam Int
i) AccessPath
p, Integer
d) | (AccessPath
p, (Integer
d, Lexeme Text
_)) <- Changes -> [(AccessPath, (Integer, Lexeme Text))]
forall k a. Map k a -> [(k, a)]
Map.toList Changes
changes
                           , Bool -> (Text -> Bool) -> Maybe Text -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
shrunk) (AccessPath -> Maybe Text
lastField AccessPath
p), Just Int
i <- [AccessPath -> Maybe Int
param AccessPath
p] ]
            | (Node
_, Maybe (Node (Lexeme Text))
e, Changes
changes) <- Context
-> Function -> [(Node, Maybe (Node (Lexeme Text)), Changes)]
exits Context
ctx Function
f
            , Outcome
Success Outcome -> [Outcome] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Shape -> Maybe (Node (Lexeme Text)) -> [Outcome]
returnOutcomes (Function -> Shape
fnShape Function
f) Maybe (Node (Lexeme Text))
e ]
    , Bool -> Bool
not (Map AccessPath Integer -> Bool
forall k a. Map k a -> Bool
Map.null Map AccessPath Integer
m)
    ]

-- | Find the fields some function lowers by a constant, as removing an entry
-- lowers a count.
shrunkFields :: [Function] -> Set Text
shrunkFields :: [Function] -> Set Text
shrunkFields [Function]
fns = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList
    [ String -> Text
Text.pack String
m
    | Function
f <- [Function]
fns, Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe (Function -> Node (Lexeme Text)
fnDefn Function
f)
    , Just Node (Lexeme Text)
x <- [NodeF (Lexeme Text) (Node (Lexeme Text))
-> Maybe (Node (Lexeme Text))
forall {lexeme}.
NodeF lexeme (Node (Lexeme Text)) -> Maybe (Node (Lexeme Text))
lowered NodeF (Lexeme Text) (Node (Lexeme Text))
node], Just (PathField AccessPath
_ String
m) <- [Node (Lexeme Text) -> Maybe AccessPath
accessPath Node (Lexeme Text)
x] ]
  where
    lowered :: NodeF lexeme (Node (Lexeme Text)) -> Maybe (Node (Lexeme Text))
lowered = \case
        UnaryExpr UnaryOp
UopDecr Node (Lexeme Text)
x                          -> Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
forall a. a -> Maybe a
Just Node (Lexeme Text)
x
        AssignExpr Node (Lexeme Text)
x AssignOp
AopMinus Node (Lexeme Text)
r | Just Integer
_ <- Node (Lexeme Text) -> Maybe Integer
intLit Node (Lexeme Text)
r -> Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
forall a. a -> Maybe a
Just Node (Lexeme Text)
x
        NodeF lexeme (Node (Lexeme Text))
_                                            -> Maybe (Node (Lexeme Text))
forall a. Maybe a
Nothing

-- | Find the failure returns of a function, each with the statements before
-- it in its block.
failureReturns :: Function -> [(C.Node (Lexeme Text), [C.Node (Lexeme Text)])]
failureReturns :: Function -> [(Node (Lexeme Text), [Node (Lexeme Text)])]
failureReturns Function
fn =
    [ (Node (Lexeme Text)
ret, Int -> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall a. Int -> [a] -> [a]
take Int
i [Node (Lexeme Text)]
stmts)
    | Fix (CompoundStmt [Node (Lexeme Text)]
stmts) <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe (Function -> Node (Lexeme Text)
fnDefn Function
fn)
    , (Int
i, ret :: Node (Lexeme Text)
ret@(Fix (Return Maybe (Node (Lexeme Text))
e))) <- [Int] -> [Node (Lexeme Text)] -> [(Int, Node (Lexeme Text))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [Node (Lexeme Text)]
stmts
    , Function -> Maybe (Node (Lexeme Text)) -> Bool
isFailure Function
fn Maybe (Node (Lexeme Text))
e
    ]

-- | The parts of a statement that can run before the statement after it,
-- leaving out blocks that end in a return.
onTheWay :: C.Node (Lexeme Text) -> [C.Node (Lexeme Text)]
onTheWay :: Node (Lexeme Text) -> [Node (Lexeme Text)]
onTheWay node :: Node (Lexeme Text)
node@(Fix NodeF (Lexeme Text) (Node (Lexeme Text))
n) = case NodeF (Lexeme Text) (Node (Lexeme Text))
n of
    CompoundStmt [Node (Lexeme Text)]
stmts | (Fix Return{} : [Node (Lexeme Text)]
_) <- [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall a. [a] -> [a]
reverse [Node (Lexeme Text)]
stmts -> []
    NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> Node (Lexeme Text)
node Node (Lexeme Text) -> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall a. a -> [a] -> [a]
: (Node (Lexeme Text) -> [Node (Lexeme Text)])
-> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Node (Lexeme Text) -> [Node (Lexeme Text)]
onTheWay ((Node (Lexeme Text)
 -> [Node (Lexeme Text)] -> [Node (Lexeme Text)])
-> [Node (Lexeme Text)]
-> NodeF (Lexeme Text) (Node (Lexeme Text))
-> [Node (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) (Node (Lexeme Text))
n)

-- | What comes before at least two failure returns: the function's cleanup
-- convention.
conventions :: Ord a => [Set a] -> Set a
conventions :: forall a. Ord a => [Set a] -> Set a
conventions [Set a]
befores = Map a Int -> Set a
forall k a. Map k a -> Set k
Map.keysSet (Map a Int -> Set a)
-> (Map a Int -> Map a Int) -> Map a Int -> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Bool) -> Map a Int -> Map a Int
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= (Int
2 :: Int)) (Map a Int -> Set a) -> Map a Int -> Set a
forall a b. (a -> b) -> a -> b
$
    (Int -> Int -> Int) -> [(a, Int)] -> Map a Int
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) [ (a
x, Int
1) | Set a
xs <- [Set a]
befores, a
x <- Set a -> [a]
forall a. Set a -> [a]
Set.toList Set a
xs ]

-- | Find destructor calls on a local immediately before failure returns that
-- are the function's cleanup convention.
failureCleanups :: Destructors -> Function -> Set (Text, String)
failureCleanups :: Destructors -> Function -> Set (Text, String)
failureCleanups Destructors
ds Function
fn = [Set (Text, String)] -> Set (Text, String)
forall a. Ord a => [Set a] -> Set a
conventions
    [ [(Text, String)] -> Set (Text, String)
forall a. Ord a => [a] -> Set a
Set.fromList
        [ (Text
name, String
v)
        | Fix (ExprStmt call :: Node (Lexeme Text)
call@(Fix (FunctionCall Node (Lexeme Text)
callee [Node (Lexeme Text)]
_))) <- [Node (Lexeme Text)]
before
        , L AlexPosn
_ LexemeClass
_ Text
name <- [Node (Lexeme Text) -> Lexeme Text
calleeLexeme Node (Lexeme Text)
callee]
        , Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
v')) <- (Node (Lexeme Text) -> Node (Lexeme Text))
-> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall a b. (a -> b) -> [a] -> [b]
map Node (Lexeme Text) -> Node (Lexeme Text)
strip (Destructors -> Node (Lexeme Text) -> [Node (Lexeme Text)]
destroyed Destructors
ds Node (Lexeme Text)
call)
        , let v :: String
v = Text -> String
Text.unpack Text
v', String
v String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
locals
        ]
    | (Node (Lexeme Text)
_, [Node (Lexeme Text)]
before) <- Function -> [(Node (Lexeme Text), [Node (Lexeme Text)])]
failureReturns Function
fn
    ]
  where
    locals :: Set String
locals = Function -> Set String
pointerLocals Function
fn

pointerLocals :: Function -> Set String
pointerLocals :: Function -> Set String
pointerLocals Function
fn = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList
    [ Text -> String
Text.unpack Text
v | Fix (VarDeclStmt (Fix (VarDecl Node (Lexeme Text)
ty (L AlexPosn
_ LexemeClass
_ Text
v) [Node (Lexeme Text)]
_)) Maybe (Node (Lexeme Text))
_) <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe (Function -> Node (Lexeme Text)
fnDefn Function
fn), Node (Lexeme Text) -> Bool
isPointer Node (Lexeme Text)
ty ]
  where
    isPointer :: Node (Lexeme Text) -> Bool
isPointer Node (Lexeme Text)
ty = Bool -> Bool
not ([()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ () | Fix (TyPointer Node (Lexeme Text)
_) <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe Node (Lexeme Text)
ty ])

-- | Find functions returning a pointer that report a status through an
-- out-parameter, with the parameter's position and the status values that
-- come with a non-null pointer. A function qualifies only if it sets the
-- status right before every return, and no status value comes with both a
-- pointer and @nullptr@.
statusFunctions :: [Function] -> Map Text (Int, Set Text)
statusFunctions :: [Function] -> Map Text (Int, Set Text)
statusFunctions [Function]
fns = [(Text, (Int, Set Text))] -> Map Text (Int, Set Text)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Function -> Text
fnName Function
f, (Int
i, Set Text
okValues))
    | f :: Function
f@Function{fnShape :: Function -> Shape
fnShape = Shape
PtrShape} <- [Function]
fns
    , let said :: [(Maybe (Text, Text), Bool)]
said = [ (Maybe (Text, Text)
st, Node (Lexeme Text) -> Bool
isNullLit Node (Lexeme Text)
e) | Fix (CompoundStmt [Node (Lexeme Text)]
stmts) <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe (Function -> Node (Lexeme Text)
fnDefn Function
f)
                                  , (Int
k, Fix (Return (Just Node (Lexeme Text)
e))) <- [Int] -> [Node (Lexeme Text)] -> [(Int, Node (Lexeme Text))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [Node (Lexeme Text)]
stmts
                                  , let st :: Maybe (Text, Text)
st = [Node (Lexeme Text)] -> Maybe (Text, Text)
lastStatus ([Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall a. [a] -> [a]
reverse (Int -> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall a. Int -> [a] -> [a]
take Int
k [Node (Lexeme Text)]
stmts)) ]
    , Bool -> Bool
not ([(Maybe (Text, Text), Bool)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Maybe (Text, Text), Bool)]
said)
    , Just [(Text, Text)]
params <- [((Maybe (Text, Text), Bool) -> Maybe (Text, Text))
-> [(Maybe (Text, Text), Bool)] -> Maybe [(Text, Text)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Maybe (Text, Text), Bool) -> Maybe (Text, Text)
forall a b. (a, b) -> a
fst [(Maybe (Text, Text), Bool)]
said]
    , (Text
p : [Text]
rest) <- [((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Text
forall a b. (a, b) -> a
fst [(Text, Text)]
params]
    , (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
== Text
p) [Text]
rest
    , Just Int
i <- [Text -> [Text] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
List.elemIndex Text
p (Function -> [Text]
fnParams Function
f)]
    , let okValues :: Set Text
okValues = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList [ Text
c | ((Text
_, Text
c), Bool
False) <- [(Text, Text)] -> [Bool] -> [((Text, Text), Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Text, Text)]
params (((Maybe (Text, Text), Bool) -> Bool)
-> [(Maybe (Text, Text), Bool)] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe (Text, Text), Bool) -> Bool
forall a b. (a, b) -> b
snd [(Maybe (Text, Text), Bool)]
said) ]
          badValues :: Set Text
badValues = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList [ Text
c | ((Text
_, Text
c), Bool
True) <- [(Text, Text)] -> [Bool] -> [((Text, Text), Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Text, Text)]
params (((Maybe (Text, Text), Bool) -> Bool)
-> [(Maybe (Text, Text), Bool)] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe (Text, Text), Bool) -> Bool
forall a b. (a, b) -> b
snd [(Maybe (Text, Text), Bool)]
said) ]
    , Bool -> Bool
not (Set Text -> Bool
forall a. Set a -> Bool
Set.null Set Text
okValues)
    , Set Text -> Bool
forall a. Set a -> Bool
Set.null (Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set Text
okValues Set Text
badValues)
    ]
  where
    lastStatus :: [Node (Lexeme Text)] -> Maybe (Text, Text)
lastStatus = \case
        (Fix (ExprStmt Node (Lexeme Text)
e) : [Node (Lexeme Text)]
_) | Just (Text, Text)
st <- Node (Lexeme Text) -> Maybe (Text, Text)
status Node (Lexeme Text)
e -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text, Text)
st
        [Node (Lexeme Text)]
_                                            -> Maybe (Text, Text)
forall a. Maybe a
Nothing
    status :: Node (Lexeme Text) -> Maybe (Text, Text)
status Node (Lexeme Text)
e = case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
unFix' Node (Lexeme Text)
e of
        AssignExpr (Fix (UnaryExpr UnaryOp
UopDeref (Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
p))))) AssignOp
_ Node (Lexeme Text)
c -> (,) Text
p (Text -> (Text, Text)) -> Maybe Text -> Maybe (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node (Lexeme Text) -> Maybe Text
literal Node (Lexeme Text)
c
        FunctionCall Node (Lexeme Text)
callee [Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
p)), Node (Lexeme Text)
c]
            | L AlexPosn
_ LexemeClass
_ Text
"SET_ERROR_PARAMETER" <- Node (Lexeme Text) -> Lexeme Text
calleeLexeme Node (Lexeme Text)
callee -> (,) Text
p (Text -> (Text, Text)) -> Maybe Text -> Maybe (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node (Lexeme Text) -> Maybe Text
literal Node (Lexeme Text)
c
        NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> Maybe (Text, Text)
forall a. Maybe a
Nothing

literal :: C.Node (Lexeme Text) -> Maybe Text
literal :: Node (Lexeme Text) -> Maybe Text
literal Node (Lexeme Text)
c = case (Node (Lexeme Text) -> Maybe Text
constName Node (Lexeme Text)
c, Node (Lexeme Text) -> Maybe Integer
intLit Node (Lexeme Text)
c) of
    (Just Text
t, Maybe Integer
_) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
    (Maybe Text
_, Just Integer
n) -> Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
Text.pack (Integer -> String
forall a. Show a => a -> String
show Integer
n))
    (Maybe Text, Maybe Integer)
_           -> Maybe Text
forall a. Maybe a
Nothing

isFailure :: Function -> Maybe (C.Node (Lexeme Text)) -> Bool
isFailure :: Function -> Maybe (Node (Lexeme Text)) -> Bool
isFailure Function
fn Maybe (Node (Lexeme Text))
e = Outcome
Failure Outcome -> [Outcome] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Outcome]
outcomes Bool -> Bool -> Bool
&& Outcome
Success Outcome -> [Outcome] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Outcome]
outcomes
  where outcomes :: [Outcome]
outcomes = Shape -> Maybe (Node (Lexeme Text)) -> [Outcome]
returnOutcomes (Function -> Shape
fnShape Function
fn) Maybe (Node (Lexeme Text))
e

-- | Find the failure returns of a function with the locals it may still own
-- there: assigned the result of a call, and since then not destroyed, stored
-- elsewhere or known to be null.
ownedAtFailures :: Destructors -> Map Text (Int, Set Text) -> Function -> [(C.Node (Lexeme Text), Set String)]
ownedAtFailures :: Destructors
-> Map Text (Int, Set Text)
-> Function
-> [(Node (Lexeme Text), Set String)]
ownedAtFailures Destructors
ds Map Text (Int, Set Text)
statuses Function
fn =
    [ (Node (Lexeme Text)
ret, Node -> Set String -> Set String
step Node
n Set String
owned)
    | (n :: Node
n@(Node Int
_ (StmtNode ret :: Node (Lexeme Text)
ret@(Fix (Return Maybe (Node (Lexeme Text))
e)))), [Edge]
_) <- Map Node [Edge] -> [(Node, [Edge])]
forall k a. Map k a -> [(k, a)]
Map.toList Map Node [Edge]
cfg
    , Function -> Maybe (Node (Lexeme Text)) -> Bool
isFailure Function
fn Maybe (Node (Lexeme Text))
e
    , Just Set String
owned <- [Node -> Map Node (Set String) -> Maybe (Set String)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Node
n Map Node (Set String)
result]
    ]
  where
    (Node
entry, Map Node [Edge]
cfg) = Node (Lexeme Text) -> (Node, Map Node [Edge])
fromFunction (Function -> Node (Lexeme Text)
fnDefn Function
fn)
    locals :: Set String
locals = Function -> Set String
pointerLocals Function
fn
    step :: Node -> Set String -> Set String
step Node
n Set String
owned = case Node
n of
        Node Int
_ (StmtNode (Fix (VarDeclStmt (Fix (VarDecl Node (Lexeme Text)
_ (L AlexPosn
_ LexemeClass
_ Text
v) [Node (Lexeme Text)]
_)) Maybe (Node (Lexeme Text))
ini))) ->
            String -> Maybe (Node (Lexeme Text)) -> Set String -> Set String
acquire (Text -> String
Text.unpack Text
v) Maybe (Node (Lexeme Text))
ini Set String
owned
        Node
_ -> (Set String -> Node (Lexeme Text) -> Set String)
-> Set String -> [Node (Lexeme Text)] -> 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' ((Node (Lexeme Text) -> Set String -> Set String)
-> Set String -> Node (Lexeme Text) -> Set String
forall a b c. (a -> b -> c) -> b -> a -> c
flip Node (Lexeme Text) -> Set String -> Set String
expr) Set String
owned (Node -> [Node (Lexeme Text)]
nodeExprs Node
n)
    acquire :: String -> Maybe (Node (Lexeme Text)) -> Set String -> Set String
acquire String
v Maybe (Node (Lexeme Text))
ini Set String
owned
        | Just (Fix FunctionCall{}) <- Node (Lexeme Text) -> Node (Lexeme Text)
strip (Node (Lexeme Text) -> Node (Lexeme Text))
-> Maybe (Node (Lexeme Text)) -> Maybe (Node (Lexeme Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Node (Lexeme Text))
ini, String
v String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
locals = String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.insert String
v Set String
owned
        | Bool
otherwise = String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.delete String
v Set String
owned
    expr :: Node (Lexeme Text) -> Set String -> Set String
expr Node (Lexeme Text)
e Set String
owned = (Set String -> Node (Lexeme Text) -> Set String)
-> Set String -> [Node (Lexeme Text)] -> 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' ((Node (Lexeme Text) -> Set String -> Set String)
-> Set String -> Node (Lexeme Text) -> Set String
forall a b c. (a -> b -> c) -> b -> a -> c
flip Node (Lexeme Text) -> Set String -> Set String
effect) Set String
owned (Node (Lexeme Text) -> [Node (Lexeme Text)]
universe Node (Lexeme Text)
e)
    effect :: Node (Lexeme Text) -> Set String -> Set String
effect (Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node) Set String
owned = case NodeF (Lexeme Text) (Node (Lexeme Text))
node of
        AssignExpr (Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
v))) AssignOp
_ Node (Lexeme Text)
r -> String -> Maybe (Node (Lexeme Text)) -> Set String -> Set String
acquire (Text -> String
Text.unpack Text
v) (Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
forall a. a -> Maybe a
Just Node (Lexeme Text)
r) Set String
owned
        -- Storing a local transfers its ownership to what it is stored in.
        AssignExpr Node (Lexeme Text)
_ AssignOp
_ Node (Lexeme Text)
r | Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
v)) <- Node (Lexeme Text) -> Node (Lexeme Text)
strip Node (Lexeme Text)
r -> String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.delete (Text -> String
Text.unpack Text
v) Set String
owned
        FunctionCall{} ->
            Set String
owned Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [ Text -> String
Text.unpack Text
v | Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
v)) <- (Node (Lexeme Text) -> Node (Lexeme Text))
-> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall a b. (a -> b) -> [a] -> [b]
map Node (Lexeme Text) -> Node (Lexeme Text)
strip (Destructors -> Node (Lexeme Text) -> [Node (Lexeme Text)]
destroyed Destructors
ds (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node)) ]
        NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> Set String
owned
    -- A local that is null on an edge needs no destroying there.
    edge :: Node -> EdgeType -> Set String -> Set String
edge Node
n EdgeType
e Set String
owned = case Node
n of
        Node Int
_ (BranchNode Node (Lexeme Text)
cond) ->
            let byTest :: Set String -> Set String
byTest = case (Node (Lexeme Text) -> Maybe String)
-> Node (Lexeme Text) -> Maybe (String, EdgeType)
forall a.
(Node (Lexeme Text) -> Maybe a)
-> Node (Lexeme Text) -> Maybe (a, EdgeType)
nullTest Node (Lexeme Text) -> Maybe String
var Node (Lexeme Text)
cond of
                    Just (String
v, EdgeType
nullOn) | EdgeType
nullOn EdgeType -> EdgeType -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeType
e -> String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.delete String
v
                    Maybe (String, EdgeType)
_                              -> Set String -> Set String
forall a. a -> a
id
            in Set String -> Set String
byTest (Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set String
owned (Node (Lexeme Text) -> EdgeType -> Set String
nullByStatus Node (Lexeme Text)
cond EdgeType
e))
        Node
_ -> Set String
owned
    -- The locals whose accompanying status shows they are null on this edge.
    nullByStatus :: Node (Lexeme Text) -> EdgeType -> Set String
nullByStatus Node (Lexeme Text)
cond EdgeType
e = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList
        [ String
v
        | (String
v, (Text
st, Set Text
okValues)) <- Map String (Text, Set Text) -> [(String, (Text, Set Text))]
forall k a. Map k a -> [(k, a)]
Map.toList Map String (Text, Set Text)
linked
        , Just Bool
isOk <- [Text -> Set Text -> Node (Lexeme Text) -> EdgeType -> Maybe Bool
statusOnEdge Text
st Set Text
okValues Node (Lexeme Text)
cond EdgeType
e]
        , Bool -> Bool
not Bool
isOk
        ]
    statusOnEdge :: Text -> Set Text -> Node (Lexeme Text) -> EdgeType -> Maybe Bool
statusOnEdge Text
st Set Text
okValues Node (Lexeme Text)
cond EdgeType
e = case (Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
unFix' (Node (Lexeme Text) -> Node (Lexeme Text)
strip Node (Lexeme Text)
cond), EdgeType
e) of
        (VarExpr (L AlexPosn
_ LexemeClass
_ Text
x), CaseBranch Node (Lexeme Text)
c) | Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
st, Just Text
c' <- Node (Lexeme Text) -> Maybe Text
literal Node (Lexeme Text)
c -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Text
c' Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
okValues)
        (BinaryExpr (Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
x))) BinaryOp
op Node (Lexeme Text)
r, EdgeType
_) | Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
st, Just Text
c <- Node (Lexeme Text) -> Maybe Text
literal Node (Lexeme Text)
r -> case (BinaryOp
op, EdgeType
e) of
            (BinaryOp
BopEq, EdgeType
TrueBranch)  -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Text
c Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
okValues)
            (BinaryOp
BopEq, EdgeType
FalseBranch) | Set Text
okValues Set Text -> Set Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Set Text
forall a. a -> Set a
Set.singleton Text
c -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
            (BinaryOp
BopNe, EdgeType
TrueBranch)  | Set Text
okValues Set Text -> Set Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Set Text
forall a. a -> Set a
Set.singleton Text
c -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
            (BinaryOp
BopNe, EdgeType
FalseBranch) -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Text
c Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
okValues)
            (BinaryOp, EdgeType)
_                    -> Maybe Bool
forall a. Maybe a
Nothing
        (NodeF (Lexeme Text) (Node (Lexeme Text)), EdgeType)
_ -> Maybe Bool
forall a. Maybe a
Nothing
    -- Locals assigned from a status-reporting function, with the status
    -- variable and the status values that come with a non-null result.
    linked :: Map String (Text, Set Text)
linked = [(String, (Text, Set Text))] -> Map String (Text, Set Text)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (Text -> String
Text.unpack Text
v, (Text
st, Set Text
okValues))
        | (Text
v, Node (Lexeme Text)
r) <- [ (Text
v, Node (Lexeme Text)
r) | Fix (VarDeclStmt (Fix (VarDecl Node (Lexeme Text)
_ (L AlexPosn
_ LexemeClass
_ Text
v) [Node (Lexeme Text)]
_)) (Just Node (Lexeme Text)
r)) <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe (Function -> Node (Lexeme Text)
fnDefn Function
fn) ]
                 [(Text, Node (Lexeme Text))]
-> [(Text, Node (Lexeme Text))] -> [(Text, Node (Lexeme Text))]
forall a. [a] -> [a] -> [a]
++ [ (Text
v, Node (Lexeme Text)
r) | Fix (AssignExpr (Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
v))) AssignOp
_ Node (Lexeme Text)
r) <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe (Function -> Node (Lexeme Text)
fnDefn Function
fn) ]
        , Fix (FunctionCall Node (Lexeme Text)
callee [Node (Lexeme Text)]
args) <- [Node (Lexeme Text) -> Node (Lexeme Text)
strip Node (Lexeme Text)
r]
        , L AlexPosn
_ LexemeClass
_ Text
name <- [Node (Lexeme Text) -> Lexeme Text
calleeLexeme Node (Lexeme Text)
callee]
        , Just (Int
i, Set Text
okValues) <- [Text -> Map Text (Int, Set Text) -> Maybe (Int, Set Text)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name Map Text (Int, Set Text)
statuses]
        , (Fix (UnaryExpr UnaryOp
UopAddress (Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
st)))) : [Node (Lexeme Text)]
_) <- [Int -> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall a. Int -> [a] -> [a]
drop Int
i [Node (Lexeme Text)]
args]
        ]
    var :: Node (Lexeme Text) -> Maybe String
var Node (Lexeme Text)
x = case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
unFix' (Node (Lexeme Text) -> Node (Lexeme Text)
strip Node (Lexeme Text)
x) of
        VarExpr (L AlexPosn
_ LexemeClass
_ Text
v) -> String -> Maybe String
forall a. a -> Maybe a
Just (Text -> String
Text.unpack Text
v)
        NodeF (Lexeme Text) (Node (Lexeme Text))
_                 -> Maybe String
forall a. Maybe a
Nothing
    result :: Map Node (Set String)
result = Node
-> Map Node [Edge]
-> Dataflow Node EdgeType (Set String)
-> Map Node (Set String)
forall node state edge.
(Ord node, Eq state) =>
node
-> Map node [(edge, node)]
-> Dataflow node edge state
-> Map node state
solve Node
entry Map Node [Edge]
cfg Dataflow
        { transfer :: Node -> Set String -> Set String
transfer     = Node -> Set String -> Set String
step
        , edgeTransfer :: Node -> EdgeType -> Set String -> Set String
edgeTransfer = Node -> EdgeType -> Set String -> Set String
edge
        , merge :: Set String -> Set String -> Set String
merge        = Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
Set.union
        , initial :: Set String
initial      = Set String
forall a. Set a
Set.empty
        }

-- | Find failure returns where a local the function cleans up before other
-- failure returns may still be owned.
skippedCleanups :: Destructors -> Map Text (Int, Set Text) -> Function -> [(C.Node (Lexeme Text), (Text, String))]
skippedCleanups :: Destructors
-> Map Text (Int, Set Text)
-> Function
-> [(Node (Lexeme Text), (Text, String))]
skippedCleanups Destructors
ds Map Text (Int, Set Text)
statuses Function
fn =
    [ (Node (Lexeme Text)
ret, (Text, String)
c)
    | (Node (Lexeme Text)
ret, Set String
owned) <- Destructors
-> Map Text (Int, Set Text)
-> Function
-> [(Node (Lexeme Text), Set String)]
ownedAtFailures Destructors
ds Map Text (Int, Set Text)
statuses Function
fn
    , c :: (Text, String)
c@(Text
_, String
v) <- Set (Text, String) -> [(Text, String)]
forall a. Set a -> [a]
Set.toList Set (Text, String)
pairs
    , String
v String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
owned
    ]
  where
    pairs :: Set (Text, String)
pairs = Destructors -> Function -> Set (Text, String)
failureCleanups Destructors
ds Function
fn

analyse :: [(FilePath, [C.Node (Lexeme Text)])] -> [Diagnostic CimplePos]
analyse :: [(String, [Node (Lexeme Text)])] -> [Diagnostic CimplePos]
analyse [(String, [Node (Lexeme Text)])]
tus = [Diagnostic CimplePos] -> [Diagnostic CimplePos]
forall a. [a] -> [a]
reverse ([Diagnostic CimplePos] -> [Diagnostic CimplePos])
-> [Diagnostic CimplePos] -> [Diagnostic CimplePos]
forall a b. (a -> b) -> a -> b
$ State [Diagnostic CimplePos] ()
-> [Diagnostic CimplePos] -> [Diagnostic CimplePos]
forall s a. State s a -> s -> s
State.execState ((((String, Lexeme Text), [(Text, AccessPath, Node (Lexeme Text))])
 -> State [Diagnostic CimplePos] ())
-> [((String, Lexeme Text),
     [(Text, AccessPath, Node (Lexeme Text))])]
-> State [Diagnostic CimplePos] ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((String, Lexeme Text), [(Text, AccessPath, Node (Lexeme Text))])
-> State [Diagnostic CimplePos] ()
report [((String, Lexeme Text), [(Text, AccessPath, Node (Lexeme Text))])]
reports State [Diagnostic CimplePos] ()
-> State [Diagnostic CimplePos] ()
-> State [Diagnostic CimplePos] ()
forall a b.
StateT [Diagnostic CimplePos] Identity a
-> StateT [Diagnostic CimplePos] Identity b
-> StateT [Diagnostic CimplePos] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ((Function, Node (Lexeme Text), (Text, String))
 -> State [Diagnostic CimplePos] ())
-> [(Function, Node (Lexeme Text), (Text, String))]
-> State [Diagnostic CimplePos] ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Function, Node (Lexeme Text), (Text, String))
-> State [Diagnostic CimplePos] ()
reportSkipped [(Function, Node (Lexeme Text), (Text, String))]
skipped) []
  where
    fns :: [Function]
fns = [(String, [Node (Lexeme Text)])] -> [Function]
definitions [(String, [Node (Lexeme Text)])]
tus
    lengths :: Set Text
lengths = [Function] -> Set Text
lengthFields [Function]
fns
    shapes :: Map Text Shape
shapes = [(Text, Shape)] -> Map Text Shape
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Function -> Text
fnName Function
f, Function -> Shape
fnShape Function
f) | Function
f <- [Function]
fns ]
    direct :: Context
direct = Map Text Shape
-> Grows -> Set Text -> Destructors -> Set Text -> Context
Context Map Text Shape
shapes Grows
forall k a. Map k a
Map.empty Set Text
lengths Destructors
ds Set Text
forall a. Set a
Set.empty
    grows :: Context
grows = Context
direct { ctxGrows = growers direct (Set.intersection lengths (shrunkFields fns)) fns }
    ctx :: Context
ctx = Context
grows { ctxUndoers = Set.unions [ conventions (map snd (cleanupsIn grows f)) | f <- fns ] }
    reports :: [((String, Lexeme Text), [(Text, AccessPath, Node (Lexeme Text))])]
reports = Map (String, Lexeme Text) [(Text, AccessPath, Node (Lexeme Text))]
-> [((String, Lexeme Text),
     [(Text, AccessPath, Node (Lexeme Text))])]
forall k a. Map k a -> [(k, a)]
Map.toList (Map (String, Lexeme Text) [(Text, AccessPath, Node (Lexeme Text))]
 -> [((String, Lexeme Text),
      [(Text, AccessPath, Node (Lexeme Text))])])
-> Map
     (String, Lexeme Text) [(Text, AccessPath, Node (Lexeme Text))]
-> [((String, Lexeme Text),
     [(Text, AccessPath, Node (Lexeme Text))])]
forall a b. (a -> b) -> a -> b
$ ([(Text, AccessPath, Node (Lexeme Text))]
 -> [(Text, AccessPath, Node (Lexeme Text))]
 -> [(Text, AccessPath, Node (Lexeme Text))])
-> [((String, Lexeme Text),
     [(Text, AccessPath, Node (Lexeme Text))])]
-> Map
     (String, Lexeme Text) [(Text, AccessPath, Node (Lexeme Text))]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [(Text, AccessPath, Node (Lexeme Text))]
-> [(Text, AccessPath, Node (Lexeme Text))]
-> [(Text, AccessPath, Node (Lexeme Text))]
forall a. [a] -> [a] -> [a]
(++)
        [ ((Function -> String
fnFile Function
f, Lexeme Text
at), [(Function -> Text
fnName Function
f, AccessPath
p, Node (Lexeme Text)
ret)])
        | Function
f <- [Function]
fns
        , (Node (Lexeme Text)
ret, Changes
changes) <- Context -> Function -> [(Node (Lexeme Text), Changes)]
failures Context
ctx Function
f
        , (AccessPath
p, (Integer
_, Lexeme Text
at)) <- Changes -> [(AccessPath, (Integer, Lexeme Text))]
forall k a. Map k a -> [(k, a)]
Map.toList Changes
changes ]
    statuses :: Map Text (Int, Set Text)
statuses = [Function] -> Map Text (Int, Set Text)
statusFunctions [Function]
fns
    ds :: Destructors
ds = [(String, [Node (Lexeme Text)])] -> Destructors
destructors [(String, [Node (Lexeme Text)])]
tus
    skipped :: [(Function, Node (Lexeme Text), (Text, String))]
skipped = [ (Function
f, Node (Lexeme Text)
ret, (Text, String)
c) | Function
f <- [Function]
fns, (Node (Lexeme Text)
ret, (Text, String)
c) <- Destructors
-> Map Text (Int, Set Text)
-> Function
-> [(Node (Lexeme Text), (Text, String))]
skippedCleanups Destructors
ds Map Text (Int, Set Text)
statuses Function
f ]

reportSkipped :: (Function, C.Node (Lexeme Text), (Text, String)) -> State [Diagnostic CimplePos] ()
reportSkipped :: (Function, Node (Lexeme Text), (Text, String))
-> State [Diagnostic CimplePos] ()
reportSkipped (Function
fn, Node (Lexeme Text)
ret, (Text
name, String
v)) = do
    let file :: String
file = Function -> String
fnFile Function
fn
        (CimplePos
pos, Int
len) = String -> Node (Lexeme Text) -> (CimplePos, Int)
forall at pos.
HasDiagnosticInfo at pos =>
String -> at -> (pos, Int)
getDiagnosticInfo String
file Node (Lexeme Text)
ret
        cleanups :: [DiagnosticSpan CimplePos]
cleanups = Map (Int, Int) (DiagnosticSpan CimplePos)
-> [DiagnosticSpan CimplePos]
forall k a. Map k a -> [a]
Map.elems (Map (Int, Int) (DiagnosticSpan CimplePos)
 -> [DiagnosticSpan CimplePos])
-> Map (Int, Int) (DiagnosticSpan CimplePos)
-> [DiagnosticSpan CimplePos]
forall a b. (a -> b) -> a -> b
$ [((Int, Int), DiagnosticSpan CimplePos)]
-> Map (Int, Int) (DiagnosticSpan CimplePos)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
            [ ((CimplePos -> Int
forall p. IsPosition p => p -> Int
posLine CimplePos
cp, CimplePos -> Int
forall p. IsPosition p => p -> Int
posColumn CimplePos
cp), CimplePos -> Int -> [Doc AnsiStyle] -> DiagnosticSpan CimplePos
forall pos. pos -> Int -> [Doc AnsiStyle] -> DiagnosticSpan pos
DiagnosticSpan CimplePos
cp Int
cl [Doc AnsiStyle
"called before another failure"])
            | (Node (Lexeme Text)
_, [Node (Lexeme Text)]
before) <- Function -> [(Node (Lexeme Text), [Node (Lexeme Text)])]
failureReturns Function
fn
            , Fix (ExprStmt (Fix (FunctionCall Node (Lexeme Text)
callee [Node (Lexeme Text)]
args))) <- [Node (Lexeme Text)]
before
            , l :: Lexeme Text
l@(L AlexPosn
_ LexemeClass
_ Text
name') <- [Node (Lexeme Text) -> Lexeme Text
calleeLexeme Node (Lexeme Text)
callee], Text
name' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name
            , [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Bool
True | Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
a)) <- (Node (Lexeme Text) -> Node (Lexeme Text))
-> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall a b. (a -> b) -> [a] -> [b]
map Node (Lexeme Text) -> Node (Lexeme Text)
strip [Node (Lexeme Text)]
args, Text -> String
Text.unpack Text
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
v ]
            , let (CimplePos
cp, Int
cl) = String -> Lexeme Text -> (CimplePos, Int)
forall at pos.
HasDiagnosticInfo at pos =>
String -> at -> (pos, Int)
getDiagnosticInfo String
file Lexeme Text
l ]
    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 (Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Function -> Text
fnName Function
fn)) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"fails without calling" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
backticks (Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
name)
            Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"on" 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
v) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
", which it does when it fails before this")
        Maybe Text
forall a. Maybe a
Nothing (CimplePos -> Int -> [Doc AnsiStyle] -> DiagnosticSpan CimplePos
forall pos. pos -> Int -> [Doc AnsiStyle] -> DiagnosticSpan pos
DiagnosticSpan CimplePos
pos Int
len [Doc AnsiStyle
"fails here"] DiagnosticSpan CimplePos
-> [DiagnosticSpan CimplePos] -> [DiagnosticSpan CimplePos]
forall a. a -> [a] -> [a]
: [DiagnosticSpan CimplePos]
cleanups) []

report :: ((FilePath, Lexeme Text), [(Text, AccessPath, C.Node (Lexeme Text))]) -> State [Diagnostic CimplePos] ()
report :: ((String, Lexeme Text), [(Text, AccessPath, Node (Lexeme Text))])
-> State [Diagnostic CimplePos] ()
report ((String
file, Lexeme Text
at), [(Text, AccessPath, Node (Lexeme Text))]
sites) = case [(Text, AccessPath, Node (Lexeme Text))]
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, Node (Lexeme Text)
_) : [(Text, AccessPath, Node (Lexeme Text))]
_ -> 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
            rets :: [DiagnosticSpan CimplePos]
rets = Map (Int, Int) (DiagnosticSpan CimplePos)
-> [DiagnosticSpan CimplePos]
forall k a. Map k a -> [a]
Map.elems (Map (Int, Int) (DiagnosticSpan CimplePos)
 -> [DiagnosticSpan CimplePos])
-> Map (Int, Int) (DiagnosticSpan CimplePos)
-> [DiagnosticSpan CimplePos]
forall a b. (a -> b) -> a -> b
$ [((Int, Int), DiagnosticSpan CimplePos)]
-> Map (Int, Int) (DiagnosticSpan CimplePos)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                [ ((CimplePos -> Int
forall p. IsPosition p => p -> Int
posLine CimplePos
rp, CimplePos -> Int
forall p. IsPosition p => p -> Int
posColumn CimplePos
rp), CimplePos -> Int -> [Doc AnsiStyle] -> DiagnosticSpan CimplePos
forall pos. pos -> Int -> [Doc AnsiStyle] -> DiagnosticSpan pos
DiagnosticSpan CimplePos
rp Int
rl [Doc AnsiStyle
"fails here"])
                | (Text
_, AccessPath
_, Node (Lexeme Text)
ret) <- [(Text, AccessPath, Node (Lexeme Text))]
sites, let (CimplePos
rp, Int
rl) = String -> Node (Lexeme Text) -> (CimplePos, Int)
forall at pos.
HasDiagnosticInfo at pos =>
String -> at -> (pos, Int)
getDiagnosticInfo String
file Node (Lexeme Text)
ret ]
        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
p) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"is not changed back 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
"fails")
            Maybe Text
forall a. Maybe a
Nothing (CimplePos -> Int -> [Doc AnsiStyle] -> DiagnosticSpan CimplePos
forall pos. pos -> Int -> [Doc AnsiStyle] -> DiagnosticSpan pos
DiagnosticSpan CimplePos
pos Int
len [Doc AnsiStyle
"changed here"] DiagnosticSpan CimplePos
-> [DiagnosticSpan CimplePos] -> [DiagnosticSpan CimplePos]
forall a. a -> [a] -> [a]
: [DiagnosticSpan CimplePos]
rets) []

descr :: ([(FilePath, [C.Node (Lexeme Text)])] -> [Diagnostic CimplePos], (Text, Text))
descr :: ([(String, [Node (Lexeme Text)])] -> [Diagnostic CimplePos],
 (Text, Text))
descr = ([(String, [Node (Lexeme Text)])] -> [Diagnostic CimplePos]
analyse, (Text
"partial-failure", [Text] -> Text
Text.unlines
    [ Text
"Checks that a function that fails leaves the lengths of the arrays it was"
    , Text
"given as they were."
    , Text
""
    , Text
"**Reason:** a caller that sees the failure goes on as if nothing changed."
    , Text
"A length changed anyway no longer matches the array, and the work that was"
    , Text
"meant to go with the change, such as telling a callback, never happens."
    , Text
""
    , Text
"Also checks that a failure destroys what the failures before it destroy, so"
    , Text
"that what the function made is not left behind for a caller who was told"
    , Text
"nothing was made."
    ]))