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

import           Control.Monad                 (foldM, forM_)
import           Data.List                     (inits, sortOn, tails)
import qualified Data.Map.Strict               as Map
import           Data.Maybe                    (isJust)
import qualified Data.Set                      as Set
import           Data.Text                     (Text)
import qualified Data.Text                     as Text
import           Language.C.Analysis.SemRep    (ArraySize (..), FunDef (..),
                                                GlobalDecls, IdentDecl (..),
                                                ObjDef (..), Type (..),
                                                VarDecl (..), VarName (..))
import           Language.C.Analysis.TravMonad (Trav, getUserState)
import           Language.C.Analysis.TypeUtils (canonicalType)
import           Language.C.Data.Ident         (identToString)
import           Language.C.Data.Node          (nameOfNode, posOfNode)
import           Language.C.Syntax.AST
import           Prettyprinter                 (Doc, pretty, (<+>))
import           Prettyprinter.Render.Terminal (AnsiStyle)
import           Tokstyle.C.Analysis.Access    (Access (..), AccessBy (..),
                                                accesses, changedNames)
import           Tokstyle.C.Analysis.Interval  (Facts, IntTy (..), Range (..),
                                                Term (..), TermKind (..),
                                                atMost, constantSum, eval,
                                                exactSum, intType, subTerms,
                                                times, wrapSite)
import           Tokstyle.C.Analysis.Known     (allocators)
import           Tokstyle.C.Analysis.Syntax    (exprChildren, localDecls)
import           Tokstyle.C.Env                (Env (..))
import           Tokstyle.C.IntervalLinter     (analysedFunctions, exprDoc,
                                                recordWrap, valuesDoc)
import           Tokstyle.C.TravUtils          (backticks)


-- | The numbers whose product is the size in bytes of the memory an
-- allocation returns.
allocated :: CExpr -> Maybe [CExpr]
allocated :: CExpr -> Maybe [CExpr]
allocated = \case
    CCast CDeclaration NodeInfo
_ CExpr
e NodeInfo
_ -> CExpr -> Maybe [CExpr]
allocated CExpr
e
    CCall (CVar Ident
f NodeInfo
_) [CExpr]
args NodeInfo
_
        | Just (Int
arity, [Int]
factors) <- String -> Map String (Int, [Int]) -> Maybe (Int, [Int])
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Ident -> String
identToString Ident
f) Map String (Int, [Int])
allocators, [CExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CExpr]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
arity ->
            [CExpr] -> Maybe [CExpr]
forall a. a -> Maybe a
Just ((Int -> CExpr) -> [Int] -> [CExpr]
forall a b. (a -> b) -> [a] -> [b]
map ([CExpr]
args [CExpr] -> Int -> CExpr
forall a. HasCallStack => [a] -> Int -> a
!!) [Int]
factors)
    CExpr
_ -> Maybe [CExpr]
forall a. Maybe a
Nothing

-- | The functions the check looks at: those that declare an array whose size
-- isn't a constant, or allocate memory.
looksAt :: FunDef -> Bool
looksAt :: FunDef -> Bool
looksAt (FunDef VarDecl
_ Stmt
body NodeInfo
_) = (CDeclaration NodeInfo -> Bool) -> [CDeclaration NodeInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any CDeclaration NodeInfo -> Bool
sized (Stmt -> [CDeclaration NodeInfo]
localDecls Stmt
body)
  where
    sized :: CDeclaration NodeInfo -> Bool
sized = \case
        CDecl [CDeclarationSpecifier NodeInfo]
_ [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
  Maybe CExpr)]
ds NodeInfo
_ -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
            [ (CDerivedDeclarator NodeInfo -> Bool)
-> [CDerivedDeclarator NodeInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any CDerivedDeclarator NodeInfo -> Bool
forall {a}. CDerivedDeclarator a -> Bool
variable [CDerivedDeclarator NodeInfo]
derived Bool -> Bool -> Bool
|| Bool
-> (CInitializer NodeInfo -> Bool)
-> Maybe (CInitializer NodeInfo)
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False CInitializer NodeInfo -> Bool
allocates Maybe (CInitializer NodeInfo)
ini
            | (Just (CDeclr Maybe Ident
_ [CDerivedDeclarator NodeInfo]
derived Maybe (CStringLiteral NodeInfo)
_ [CAttribute NodeInfo]
_ NodeInfo
_), Maybe (CInitializer NodeInfo)
ini, Maybe CExpr
_) <- [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
  Maybe CExpr)]
ds ]
        CDeclaration NodeInfo
_ -> Bool
False
    variable :: CDerivedDeclarator a -> Bool
variable = \case
        CArrDeclr [CTypeQualifier a]
_ (CArrSize Bool
_ CConst{}) a
_ -> Bool
False
        CArrDeclr [CTypeQualifier a]
_ (CArrSize Bool
_ CExpression a
_) a
_        -> Bool
True
        CDerivedDeclarator a
_                                   -> Bool
False
    allocates :: CInitializer NodeInfo -> Bool
allocates = \case
        CInitExpr CExpr
e NodeInfo
_ -> Maybe [CExpr] -> Bool
forall a. Maybe a -> Bool
isJust (CExpr -> Maybe [CExpr]
allocated CExpr
e)
        CInitializer NodeInfo
_             -> Bool
False

-- | The byte buffers among a function's locals that always point at the
-- memory they were made with, the expressions whose product gives their
-- sizes, and whether those expressions keep their values.
buffers :: FunDef -> [IdentDecl] -> [(String, ([CExpr], Bool))]
buffers :: FunDef -> [IdentDecl] -> [(String, ([CExpr], Bool))]
buffers (FunDef VarDecl
_ Stmt
body NodeInfo
_) [IdentDecl]
locals =
    [ (String
name, ([CExpr]
size, (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set String
changed) ((CExpr -> [String]) -> [CExpr] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CExpr -> [String]
names [CExpr]
size)))
    | ObjectDef (ObjDef (VarDecl (VarName Ident
i Maybe (CStringLiteral NodeInfo)
_) DeclAttrs
_ Type
ty) Maybe (CInitializer NodeInfo)
ini NodeInfo
_) <- [IdentDecl]
locals
    , let name :: String
name = Ident -> String
identToString Ident
i
    , String
name String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set String
changed
    , Just [CExpr]
size <- [Type -> Maybe (CInitializer NodeInfo) -> Maybe [CExpr]
sizeOf (Type -> Type
canonicalType Type
ty) Maybe (CInitializer NodeInfo)
ini]
    ]
  where
    sizeOf :: Type -> Maybe (CInitializer NodeInfo) -> Maybe [CExpr]
sizeOf Type
ty Maybe (CInitializer NodeInfo)
ini = case Type
ty of
        ArrayType Type
el (ArraySize Bool
_ CExpr
e) TypeQuals
_ Attributes
_ | Type -> Bool
isByte Type
el            -> [CExpr] -> Maybe [CExpr]
forall a. a -> Maybe a
Just [CExpr
e]
        PtrType Type
el TypeQuals
_ Attributes
_ | Type -> Bool
isByte Type
el, Just (CInitExpr CExpr
e NodeInfo
_) <- Maybe (CInitializer NodeInfo)
ini -> CExpr -> Maybe [CExpr]
allocated CExpr
e
        Type
_                                                       -> Maybe [CExpr]
forall a. Maybe a
Nothing
    isByte :: Type -> Bool
isByte Type
el = Bool -> (IntTy -> Bool) -> Maybe IntTy -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
8) (Integer -> Bool) -> (IntTy -> Integer) -> IntTy -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntTy -> Integer
tyBits) (Type -> Maybe IntTy
intType Type
el)

    changed :: Set String
changed = Stmt -> Set String
changedNames Stmt
body
    names :: CExpr -> [String]
names CExpr
e = [ Ident -> String
identToString Ident
i | CVar Ident
i NodeInfo
_ <- CExpr -> [CExpr]
everyExpr CExpr
e ]
    everyExpr :: CExpr -> [CExpr]
everyExpr CExpr
e = CExpr
e CExpr -> [CExpr] -> [CExpr]
forall a. a -> [a] -> [a]
: (CExpr -> [CExpr]) -> [CExpr] -> [CExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CExpr -> [CExpr]
everyExpr (CExpr -> [CExpr]
exprChildren CExpr
e)

-- | How many bytes into its buffer an access can reach.
reach :: Facts -> Access -> Maybe Integer
reach :: Facts -> Access -> Maybe Integer
reach Facts
facts Access
acc = (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Access -> Integer
accConst Access
acc) (Integer -> Integer)
-> ([Integer] -> Integer) -> [Integer] -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Integer] -> Integer) -> Maybe [Integer] -> Maybe Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Integer, Term) -> Maybe Integer)
-> [(Integer, Term)] -> Maybe [Integer]
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 (Integer, Term) -> Maybe Integer
furthest (Access -> [(Integer, Term)]
accTerms Access
acc)
  where
    furthest :: (Integer, Term) -> Maybe Integer
furthest (Integer
k, Term
x) = Facts -> Term -> Maybe [Range]
eval Facts
facts Term
x Maybe [Range] -> ([Range] -> Maybe Integer) -> Maybe Integer
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        [] -> Maybe Integer
forall a. Maybe a
Nothing
        [Range]
rs -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just ([Integer] -> Integer
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [ Integer
k Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
v | Range
r <- [Range]
rs, Integer
v <- [Range -> Integer
lo Range
r, Range -> Integer
hi Range
r] ])

-- | A buffer's size in bytes: the numbers whose product it is, with the
-- values each has when the buffer is made, and whether they keep them.
data Size = Size
    { Size -> [(Term, [Range])]
sizeFactors :: [(Term, [Range])]
    , Size -> Bool
sizeKept    :: Bool
    }

fits :: Facts -> Access -> Size -> Bool
fits :: Facts -> Access -> Size -> Bool
fits Facts
facts Access
acc Size
size = Bool -> (Linear -> Bool) -> Maybe Linear -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Facts -> [(Integer, Term)] -> Integer -> Linear -> Bool
atMost Facts
facts (Access -> [(Integer, Term)]
accTerms Access
acc) (Access -> Integer
accConst Access
acc)) (Maybe Linear -> Bool) -> Maybe Linear -> Bool
forall a b. (a -> b) -> a -> b
$
    ((Term, [Range]) -> Maybe Linear)
-> [(Term, [Range])] -> Maybe [Linear]
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 (Facts -> Term -> Maybe Linear
exactSum Facts
facts (Term -> Maybe Linear)
-> ((Term, [Range]) -> Term) -> (Term, [Range]) -> Maybe Linear
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term, [Range]) -> Term
forall a b. (a, b) -> a
fst) (Size -> [(Term, [Range])]
sizeFactors Size
size) Maybe [Linear] -> ([Linear] -> Maybe Linear) -> Maybe Linear
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Linear -> Linear -> Maybe Linear)
-> Linear -> [Linear] -> Maybe Linear
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Linear -> Linear -> Maybe Linear
times (Integer -> Linear
constantSum Integer
1)

-- | A size without its factor of one, like @sizeof(uint8_t)@.
inBytes :: Term -> Term
inBytes :: Term -> Term
inBytes Term
t = case Term -> TermKind
termKind Term
t of
    TBin CBinaryOp
CMulOp Term
a Term
b | TConst Integer
1 <- Term -> TermKind
termKind Term
b -> Term -> Term
inBytes Term
a
    TermKind
_                                        -> Term
t

bytesDoc :: Integer -> Doc a
bytesDoc :: forall a. Integer -> Doc a
bytesDoc Integer
1 = Doc a
"1 byte"
bytesDoc Integer
n = Integer -> Doc a
forall a. Integer -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty Integer
n Doc a -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc a
"bytes"

analyse :: GlobalDecls -> Trav Env ()
analyse :: GlobalDecls -> Trav Env ()
analyse GlobalDecls
_ = do
    Env
env <- Trav Env Env
forall s. Trav s s
getUserState
    [(FunDef, [(Node, Facts, [Term])])]
functions <- (FunDef -> Bool) -> Trav Env [(FunDef, [(Node, Facts, [Term])])]
analysedFunctions FunDef -> Bool
looksAt
    [(FunDef, [(Node, Facts, [Term])])]
-> ((FunDef, [(Node, Facts, [Term])]) -> Trav Env ())
-> Trav Env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(FunDef, [(Node, Facts, [Term])])]
functions (((FunDef, [(Node, Facts, [Term])]) -> Trav Env ()) -> Trav Env ())
-> ((FunDef, [(Node, Facts, [Term])]) -> Trav Env ())
-> Trav Env ()
forall a b. (a -> b) -> a -> b
$ \(fd :: FunDef
fd@(FunDef (VarDecl VarName
self DeclAttrs
_ Type
_) Stmt
_ NodeInfo
_), [(Node, Facts, [Term])]
nodes) -> do
        let locals :: [IdentDecl]
locals = case VarName
self of
                VarName Ident
i Maybe (CStringLiteral NodeInfo)
_ -> [IdentDecl] -> String -> Map String [IdentDecl] -> [IdentDecl]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] (Ident -> String
identToString Ident
i) (Env -> Map String [IdentDecl]
localsOf Env
env)
                VarName
NoName      -> []
            bufs :: Map String ([CExpr], Bool)
bufs = [(String, ([CExpr], Bool))] -> Map String ([CExpr], Bool)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (FunDef -> [IdentDecl] -> [(String, ([CExpr], Bool))]
buffers FunDef
fd [IdentDecl]
locals)
            sizeNames :: Map Name String
sizeNames = [(Name, String)] -> Map Name String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Name
n, String
b) | (String
b, ([CExpr]
es, Bool
_)) <- Map String ([CExpr], Bool) -> [(String, ([CExpr], Bool))]
forall k a. Map k a -> [(k, a)]
Map.toList Map String ([CExpr], Bool)
bufs, CExpr
e <- [CExpr]
es, Just Name
n <- [NodeInfo -> Maybe Name
nameOfNode (CExpr -> NodeInfo
forall a. CExpression a -> a
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation CExpr
e)] ]
            factors :: Map String (Map Name (Term, [Range]))
factors = (Map Name (Term, [Range])
 -> Map Name (Term, [Range]) -> Map Name (Term, [Range]))
-> [(String, Map Name (Term, [Range]))]
-> Map String (Map Name (Term, [Range]))
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Map Name (Term, [Range])
-> Map Name (Term, [Range]) -> Map Name (Term, [Range])
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union
                [ (String
b, Name -> (Term, [Range]) -> Map Name (Term, [Range])
forall k a. k -> a -> Map k a
Map.singleton Name
n (Term -> Term
inBytes Term
s, [Range]
rs))
                | (Node
_, Facts
facts, [Term]
terms) <- [(Node, Facts, [Term])]
nodes, Term
s <- (Term -> [Term]) -> [Term] -> [Term]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Term -> [Term]
subTerms [Term]
terms
                , Just Name
n <- [NodeInfo -> Maybe Name
nameOfNode (CExpr -> NodeInfo
forall a. CExpression a -> a
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation (Term -> CExpr
termExpr Term
s))]
                , Just String
b <- [Name -> Map Name String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name String
sizeNames]
                , Just [Range]
rs <- [Facts -> Term -> Maybe [Range]
eval Facts
facts (Term -> Term
inBytes Term
s)] ]
            sizes :: Map String Size
sizes = [(String, Size)] -> Map String Size
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                [ (String
b, [(Term, [Range])] -> Bool -> Size
Size [(Term, [Range])]
found Bool
kept)
                | (String
b, ([CExpr]
es, Bool
kept)) <- Map String ([CExpr], Bool) -> [(String, ([CExpr], Bool))]
forall k a. Map k a -> [(k, a)]
Map.toList Map String ([CExpr], Bool)
bufs
                , let found :: [(Term, [Range])]
found = Map Name (Term, [Range]) -> [(Term, [Range])]
forall k a. Map k a -> [a]
Map.elems (Map Name (Term, [Range])
-> String
-> Map String (Map Name (Term, [Range]))
-> Map Name (Term, [Range])
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map Name (Term, [Range])
forall k a. Map k a
Map.empty String
b Map String (Map Name (Term, [Range]))
factors)
                , [(Term, [Range])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Term, [Range])]
found Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [CExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CExpr]
es ]
            problems :: [(Position, String, Trav Env ())]
problems =
                [ (NodeInfo -> Position
posOfNode (CExpr -> NodeInfo
forall a. CExpression a -> a
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation (Term -> CExpr
termExpr Term
t)), Access -> String
accBuffer Access
acc, Term
-> Access -> CExpr -> Range -> NodeInfo -> Integer -> Trav Env ()
report Term
t Access
acc (Term -> CExpr
termExpr Term
factor) Range
r NodeInfo
site Integer
end)
                | (Node
_, Facts
facts, [Term]
terms) <- [(Node, Facts, [Term])]
nodes, Term
t <- (Term -> [Term]) -> [Term] -> [Term]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Term -> [Term]
subTerms [Term]
terms, Access
acc <- Program -> Term -> [Access]
accesses (Env -> Program
program Env
env) Term
t
                , Just Size
size <- [String -> Map String Size -> Maybe Size
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Access -> String
accBuffer Access
acc) Map String Size
sizes]
                , Bool -> Bool
not (Size -> Bool
sizeKept Size
size Bool -> Bool -> Bool
&& Facts -> Access -> Size -> Bool
fits Facts
facts Access
acc Size
size)
                , Just Integer
end <- [Facts -> Access -> Maybe Integer
reach Facts
facts Access
acc]
                , (Term
factor, Range
r, NodeInfo
site) : [(Term, Range, NodeInfo)]
_ <- [[(Term, [Range])] -> Integer -> [(Term, Range, NodeInfo)]
forall {a}. [(a, [Range])] -> Integer -> [(a, Range, NodeInfo)]
wrapped (Size -> [(Term, [Range])]
sizeFactors Size
size) Integer
end] ]
        -- One error for each buffer, at the first access past its size.
        [Trav Env ()] -> Trav Env ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([Trav Env ()] -> Trav Env ())
-> (Map String (Trav Env ()) -> [Trav Env ()])
-> Map String (Trav Env ())
-> Trav Env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String (Trav Env ()) -> [Trav Env ()]
forall k a. Map k a -> [a]
Map.elems (Map String (Trav Env ()) -> Trav Env ())
-> Map String (Trav Env ()) -> Trav Env ()
forall a b. (a -> b) -> a -> b
$ (Trav Env () -> Trav Env () -> Trav Env ())
-> [(String, Trav Env ())] -> Map String (Trav Env ())
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (\Trav Env ()
_ Trav Env ()
old -> Trav Env ()
old)
            [ (String
b, Trav Env ()
act) | (Position
_, String
b, Trav Env ()
act) <- ((Position, String, Trav Env ()) -> Position)
-> [(Position, String, Trav Env ())]
-> [(Position, String, Trav Env ())]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\(Position
pos, String
_, Trav Env ()
_) -> Position
pos) [(Position, String, Trav Env ())]
problems ]
  where
    -- A factor's values that wrapped around, with which the size can be
    -- less than an access reaches.
    wrapped :: [(a, [Range])] -> Integer -> [(a, Range, NodeInfo)]
wrapped [(a, [Range])]
factors Integer
end =
        [ (a
factor, Range
r, NodeInfo
site)
        | ([(a, [Range])]
before, (a
factor, [Range]
rs) : [(a, [Range])]
after) <- [[(a, [Range])]]
-> [[(a, [Range])]] -> [([(a, [Range])], [(a, [Range])])]
forall a b. [a] -> [b] -> [(a, b)]
zip ([(a, [Range])] -> [[(a, [Range])]]
forall a. [a] -> [[a]]
inits [(a, [Range])]
factors) ([(a, [Range])] -> [[(a, [Range])]]
forall a. [a] -> [[a]]
tails [(a, [Range])]
factors)
        , Just [Integer]
others <- [((a, [Range]) -> Maybe Integer)
-> [(a, [Range])] -> Maybe [Integer]
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 ([Range] -> Maybe Integer
least ([Range] -> Maybe Integer)
-> ((a, [Range]) -> [Range]) -> (a, [Range]) -> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, [Range]) -> [Range]
forall a b. (a, b) -> b
snd) ([(a, [Range])]
before [(a, [Range])] -> [(a, [Range])] -> [(a, [Range])]
forall a. [a] -> [a] -> [a]
++ [(a, [Range])]
after)]
        , Range
r <- [Range]
rs, Just NodeInfo
site <- [Origin -> Maybe NodeInfo
wrapSite (Range -> Origin
origin Range
r)], Range -> Integer
lo Range
r Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product [Integer]
others Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
end ]
    least :: [Range] -> Maybe Integer
least = \case
        [] -> Maybe Integer
forall a. Maybe a
Nothing
        [Range]
rs -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just ([Integer] -> Integer
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ((Range -> Integer) -> [Range] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map Range -> Integer
lo [Range]
rs))
    report :: Term
-> Access -> CExpr -> Range -> NodeInfo -> Integer -> Trav Env ()
report Term
t Access
acc CExpr
size Range
r NodeInfo
site Integer
end = Term -> NodeInfo -> Doc AnsiStyle -> Trav Env ()
recordWrap Term
t NodeInfo
site (Doc AnsiStyle -> Trav Env ()) -> Doc AnsiStyle -> Trav Env ()
forall a b. (a -> b) -> a -> b
$
        CExpr -> Doc AnsiStyle
forall a. CExpr -> Doc a
exprDoc CExpr
size Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"can wrap around to" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Range -> Doc AnsiStyle
forall a. Range -> Doc a
valuesDoc Range
r
        Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
", so" 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 (Access -> String
accBuffer Access
acc)) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"can be smaller than the"
        Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Integer -> Doc AnsiStyle
forall a. Integer -> Doc a
bytesDoc Integer
end Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AccessBy -> Doc AnsiStyle
forall {a}. AccessBy -> Doc a
byDoc (Access -> AccessBy
accBy Access
acc) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"reaches"
    byDoc :: AccessBy -> Doc a
byDoc = \case
        ByElement CExpr
e -> CExpr -> Doc a
forall a. CExpr -> Doc a
exprDoc CExpr
e
        ByCall String
fn   -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann
backticks (String -> Doc a
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
fn)


descr :: (GlobalDecls -> Trav Env (), (Text, Text))
descr :: (GlobalDecls -> Trav Env (), (Text, Text))
descr = (GlobalDecls -> Trav Env ()
analyse, (Text
"buffer-size", [Text] -> Text
Text.unlines
    [ Text
"Checks for local byte buffers whose size can wrap around and that are then"
    , Text
"accessed past that size, by indexing or by a call that reads or writes them,"
    , Text
"such as `memcpy` or a function that accesses its buffer argument up to another"
    , Text
"argument."
    , Text
""
    , Text
"**Reason:** `const uint16_t size = length + HEADER_SIZE;` truncates to a small"
    , Text
"value when `length` is close to 65536, and copying `length` bytes into a"
    , Text
"buffer of that size writes past its end. Compute sizes in a type that can hold"
    , Text
"them, and limit them before making the buffer."
    ]))