Newer
Older
-- * Context
Context (..),
defaultContext,
-- * Helpers
prettyIdent,
) where
import Control.Applicative
import Control.Monad
import qualified Control.Monad.IRTree as IRTree
import qualified Data.Set as Set
import Data.Vector.Internal.Check (HasCallStack)
reduceCTranslUnit
:: (MonadReduce Lab m)
=> C.CTranslationUnit C.NodeInfo
-> Context
-> m (C.CTranslationUnit C.NodeInfo)
reduceCTranslUnit (C.CTranslUnit es ni) ctx = do
(_functions, _structs) <- flip evalState ctx do
(fs, sts) <- flip mapAndUnzipM es \e -> do
includeTypeDef e
funcs <- gets \ctx' -> findFunctions (: []) ctx' e
structs <- gets \ctx' -> findStructs (: []) ctx' e
pure (funcs, structs)
pure (pure (concat fs, concat sts))
functions' <- flip execStateT (functions ctx) do
forM_ (List.sortOn (negate . funSize) _functions) \f -> do
functions <- get
if funName f `Map.member` functions
then pure ()
else do
mf <- runMaybeT do
when (C.identToString (funName f) /= "main" || LoseMain `isIn` ctx) do
exceptIf ("remove function " <> C.identToString (funName f), funPosition f)
case funParams f of
Just params -> do
params' <- forM params \p -> runMaybeT do
p' <- liftMaybe p
exceptIf ("remove parameter", funPosition f)
pure p'
pure f{funParams = Just params'}
Nothing -> pure f
modify' (Map.insert (funName f) mf)
let insertStub (C.builtinIdent -> fid) ret params
| not (fid `Map.member` functions) =
modify' . Map.insert fid . Just $
Function
{ funName = fid
, funParams = params
, funReturns = ret
, funIsStatic = False
, funPosition = C.posOf fid
, funSize = 0
}
| otherwise = pure ()
insertStub "fabsf" (Just CTNum) (Just [Just CTNum, Just CTNum])
insertStub "fabs" (Just CTNum) (Just [Just CTNum, Just CTNum])
structs' <- flip execStateT (structs ctx) do
forM_ _structs \s ->
modify' (Map.insert (structName s) (Just s))
let ctx' = ctx{functions = functions', structs = structs'}
res' <- evalStateT (mapM reduceCExternalDeclaration es) ctx'
pure $ C.CTranslUnit (catMaybes res') ni
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
-> StateT Context m (Maybe (C.CExternalDeclaration C.NodeInfo))
reduceCExternalDeclaration r = case r of
C.CFDefExt (C.CFunDef spec declr [] stmt ni) -> runMaybeT do
ctx <- get
guard (not $ any (shouldDeleteDeclSpec ctx) spec)
let C.CDeclr mid dd Nothing [] ni2 = declr
let (C.CFunDeclr (C.CFunParamsNew params b) attr ni3 : dd') = dd
pFilter <- case mid of
Just fid -> do
f <- liftMaybe (lookupFunction ctx fid)
pure $ funParams f
Nothing -> do
exceptIf ("remove function", C.posOf r)
case params of
[C.CDecl [C.CTypeSpec (C.CVoidType _)] [] _] -> pure Nothing
_ow -> pure . Just $ Just . snd <$> concatMap (declarations ctx) params
let (params', idents) = case pFilter of
Just flt -> filterParams ctx flt params
Nothing -> ([C.CDecl [C.CTypeSpec (C.CVoidType C.undefNode)] [] C.undefNode], [])
labs <- flip collect (labelsOf stmt) \l -> do
exceptIf ("remove label" <> show l, C.posOf l)
pure l
stmt' <-
reduceCStatementOrEmptyBlock stmt labs $
foldr (uncurry addInlineExpr) ctx idents
let dd'' = C.CFunDeclr (C.CFunParamsNew params' b) attr ni3 : dd'
pure . C.CFDefExt $
C.CFunDef
(inlineTypeDefsSpecs spec ctx)
(C.CDeclr mid dd'' Nothing [] ni2)
[]
stmt'
ni
-- Type definitions
C.CDeclExt d@(C.CDecl (C.CStorageSpec (C.CTypedef _) : rst) [item] ni) -> runMaybeT do
let C.CDeclarationItem (C.CDeclr (Just ix) [] Nothing [] _) Nothing Nothing = item
("Inline typedef" <> C.identToString ix, C.posOf ni)
(modify (\ctx' -> addTypeDefs [ix] (ctype ctx' rst, ITInline rst) ctx') >> empty)
do
modify (\ctx' -> addTypeDefs [ix] (ctype ctx' rst, ITKeep) ctx')
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
-- The rest.
C.CDeclExt (C.CDecl spec items ni) -> runMaybeT do
ctx <- get
let t = ctype ctx spec
lift $ includeTypeDef r
keep <- containsStructDeclaration spec
-- Try to remove each declaration item
items' <- flip collect items \case
di@(C.CDeclarationItem (C.CDeclr mid dd Nothing [] ni2) einit size) -> do
case dd of
(C.CFunDeclr params attr ni3) : rst -> do
dd' <- case mid of
Just fid -> do
f <- liftMaybe (lookupFunction ctx fid)
params' <- case funParams f of
Just flt -> case params of
C.CFunParamsNew params' b ->
pure . flip C.CFunParamsNew b . fst $
filterParams ctx flt params'
C.CFunParamsOld _ ->
notSupportedYet (di $> ()) ni2
Nothing -> pure params
pure (C.CFunDeclr params' attr ni3 : rst)
Nothing -> do
exceptIf ("remove function", C.posOf ni2)
pure dd
pure (C.CDeclarationItem (C.CDeclr mid dd' Nothing [] ni2) einit size)
_dd -> do
let Just t' = applyDerivedDeclarators dd (Just t)
einit' <- reduceVariable t' mid einit ni2
pure (C.CDeclarationItem (C.CDeclr mid dd Nothing [] ni2) einit' size)
decl' <- gets (inlineTypeDefsCDeclaration (C.CDecl spec items' ni))
pure (C.CDeclExt decl')
reduceVariable
:: ( MonadReduce Lab m
, MonadState Context m
, MonadPlus m
)
=> CType
-> Maybe C.Ident
-> Maybe (C.CInitializer C.NodeInfo)
-> C.NodeInfo
reduceVariable t' mid einit ni = do
case mid of
Just vid -> do
case einit of
Just (C.CInitExpr e ni2) -> do
ctx <- get
e' <- reduceCExprOrZero e ctx
split
("inline variable " <> C.identToString vid, C.posOf ni)
do
split
("delete variable", C.posOf ni)
(modify' (addInlineExpr vid IEDelete) >> empty)
do
modify' (addInlineExpr vid (IEKeep t'))
pure (Just (C.CInitList i ni2))
Nothing ->
split
("delete uninitialized variable", C.posOf vid)
(modify' (addInlineExpr vid IEDelete) >> empty)
Nothing -> do
exceptIf ("remove unnamed declaration item", C.posOf ni)
=> [C.Ident]
-> C.CCompoundBlockItem C.NodeInfo
-> StateT Context m [C.CCompoundBlockItem C.NodeInfo]
reduceCCompoundBlockItem lab r = do
ctx <- get
msmt <- runMaybeT $ reduceCStatement smt lab ctx
case msmt of
Just smt' -> do
C.CCompound [] ss _ ->
split
("expand compound statment", C.posOf r)
(pure ss)
(pure [C.CBlockStmt smt'])
_ow -> pure [C.CBlockStmt smt']
Nothing -> pure []
C.CBlockDecl (C.CDecl spec items ni) -> fmap (fromMaybe []) . runMaybeT $ do
let t = ctype ctx spec
keep <- containsStructDeclaration spec
-- Try to remove each declaration item
items' <- flip collect items \case
C.CDeclarationItem (C.CDeclr mid dd Nothing [] ni2) einit size -> do
let Just t' = applyDerivedDeclarators dd (Just t)
einit' <- reduceVariable t' mid einit ni2
pure (C.CDeclarationItem (C.CDeclr mid dd Nothing [] ni2) einit' size)
a -> notSupportedYet (a $> ()) ni
-- Somtimes we just declare a struct or a typedef.
when (not keep && List.null items') do
guard (AllowEmptyDeclarations `isIn` ctx)
exceptIf ("remove declaration", C.posOf ni)
decl' <- gets (inlineTypeDefsCDeclaration (C.CDecl spec items' ni))
pure [C.CBlockDecl decl']
-> m ([C.CDeclarationItem C.NodeInfo], Context)
-> m ([C.CDeclarationItem C.NodeInfo], Context)
dr@(C.CDeclr (Just i) [] Nothing [] ni)
(Just (C.CInitExpr c ni'))
(ds, ctx) <- ma
c' <- fromMaybe (pure zeroExpr) (reduceCExpr c ctx)
if shouldDelete
then pure (ds, addInlineExpr i (IEInline c') ctx)
else
split
("inline variable " <> C.identToString i, C.posOf ni)
(pure (ds, addInlineExpr i (IEInline c') ctx))
( pure
( inlineTypeDefsCDI (C.CDeclarationItem dr (Just (C.CInitExpr c' ni')) Nothing) ctx
: ds
, addInlineExpr i (IEKeep t) ctx
)
C.CDeclarationItem (C.CDeclr (Just i) a Nothing b ni) ex Nothing -> do
if shouldDelete
then pure (ds, addInlineExpr i IEDelete ctx)
else do
ex' <- case ex of
Just ix -> maybeSplit ("remove initializer", C.posOf ni) (reduceCInitializer ix ctx)
Nothing -> pure Nothing
let d' = C.CDeclarationItem (C.CDeclr (Just i) a Nothing b ni) ex' Nothing
split
("remove variable " <> C.identToString i, C.posOf ni)
(pure (ds, addInlineExpr i IEDelete ctx))
(pure (inlineTypeDefsCDI d' ctx : ds, addInlineExpr i (IEKeep t) ctx))
a@(C.CDeclarationItem (C.CDeclr _ _ _ _ ni) _ _) -> do
don'tHandleWithNodeInfo a ni
reduceCInitializer
:: (MonadReduce Lab m)
=> C.CInitializer C.NodeInfo
-> Context
-> Maybe (m (C.CInitializer C.NodeInfo))
reduceCInitializer a ctx = case a of
C.CInitExpr e ni' -> do
rm <- reduceCExpr e ctx
Just $ (`C.CInitExpr` ni') <$> rm
C.CInitList (C.CInitializerList items) ni -> do
ritems <- forM items \case
([], it) -> fmap ([],) <$> reduceCInitializer it ctx
(as, _) -> notSupportedYet (fmap noinfo as) ni
Just $ (`C.CInitList` ni) . C.CInitializerList <$> sequence ritems
reduceCStatementOrEmptyBlock stmt ids ctx = do
fromMaybe emptyBlock <$> runMaybeT (reduceCStatement stmt ids ctx)
emptyBlock :: C.CStatement C.NodeInfo
emptyBlock = C.CCompound [] [] C.undefNode
-- | Reduce given a list of required labels reduce a c statement, possibly into nothingness.
-> MaybeT m (C.CStatement C.NodeInfo)
reduceCStatement smt labs ctx = case smt of
C.CCompound is cbi ni -> do
cbi' <- lift $ evalStateT (mapM (reduceCCompoundBlockItem labs) cbi) ctx
case concat cbi' of
s' <- reduceCStatement s labs ctx
e' <- lift (reduceCExprOrZero e ctx)
pure $ C.CWhile e' s' dow ni
C.CExpr me ni -> do
case me of
Just e -> do
if DoNoops `isIn` ctx
e' <- maybeSplit ("change to noop", C.posOf smt) $ reduceCExpr e ctx
pure $ C.CExpr e' ni
else do
re' <- liftMaybe $ reduceCExpr e ctx
exceptIf ("remove expr statement", C.posOf smt)
e' <- re'
pure $ C.CExpr (Just e') ni
C.CReturn me ni -> do
-- TODO: If function returntype is not struct return 0
re' <- liftMaybe $ reduceCExpr e ctx
exceptIf ("remove return statement", C.posOf smt)
e' <- re'
pure $ C.CReturn (Just e') ni
Nothing -> do
exceptIf ("remove return statement", C.posOf smt)
pure $ C.CReturn Nothing ni
C.CIf e s els ni -> do
e' <- maybeSplit ("remove condition", C.posOf e) $ reduceCExpr e ctx
els' <- lift . runMaybeT $ do
els' <- liftMaybe els
reduceCStatement els' labs ctx
ms' <- lift . runMaybeT $ reduceCStatement s labs ctx
case (e', ms', els') of
(Nothing, Nothing, Nothing) -> pure emptyBlock
(Just e'', Just s', Nothing) -> pure $ C.CIf e'' s' Nothing ni
(Nothing, Just s', Just x) -> pure $ C.CIf zeroExpr s' (Just x) ni
(Just e'', Just s', Just x) -> pure $ C.CIf e'' s' (Just x) ni
(Just e'', Nothing, Nothing) -> pure $ C.CExpr (Just e'') C.undefNode
(Nothing, Nothing, Just x) -> pure x
(Just e'', Nothing, Just x) -> pure $ C.CIf e'' emptyBlock (Just x) ni
(Nothing, Just s', Nothing) -> pure s'
(reduceCDeclarationItem (shouldDeleteDeclaration ctx d) (ctype ctx spec))
if AllowEmptyDeclarations `isIn` ctx'
then
split
("remove empty declaration", C.posOf ni')
(pure Nothing)
C.CForInitializing e -> do
e' <- maybeSplit ("remove initializer", C.posOf ni) (e >>= \e' -> reduceCExpr e' ctx)
("remove empty declaration", C.posOf ni)
(pure (Nothing, ctx))
e2' <- runMaybeT do
e2' <- liftMaybe e2
re2' <- liftMaybe (reduceCExpr e2' ctx')
exceptIf ("remove check", C.posOf e2')
re2'
e3' <- runMaybeT do
e3' <- liftMaybe e3
re3' <- liftMaybe (reduceCExpr e3' ctx')
exceptIf ("remove iterator", C.posOf e3')
re3'
let e2'' =
if AllowInfiniteForLoops `isIn` ctx || isNothing e2
then e2'
else e2' <|> Just zeroExpr
pure $ C.CFor n e2'' e3' s' ni
case me1' of
Nothing -> do
split ("remove the for loop", C.posOf smt) (pure s') do
forloop (C.CForInitializing Nothing)
C.CLabel i s [] ni -> do
if i `List.elem` labs
then do
s' <- lift $ reduceCStatementOrEmptyBlock s labs ctx
pure $ C.CLabel i s' [] ni
else do
empty
C.CGoto i ni ->
if i `List.elem` labs
then pure $ C.CGoto i ni
else empty
C.CBreak _ -> defaultBehavior
C.CCont _ -> defaultBehavior
where
defaultBehavior =
split ("remove statement", C.posOf smt) empty (pure smt)
-- | If the condition is statisfied try to reduce to the a.
whenSplit :: (MonadReduce Lab m) => Bool -> Lab -> m a -> m a -> m a
whenSplit cn lab a b
| cn = split lab a b
| otherwise = b
maybeSplit :: (MonadReduce Lab m) => Lab -> Maybe (m a) -> m (Maybe a)
maybeSplit lab = \case
Just r -> do
split lab (pure Nothing) (Just <$> r)
Nothing -> do
pure Nothing
zeroExpr :: C.CExpression C.NodeInfo
zeroExpr = C.CConst (C.CIntConst (C.cInteger 0) C.undefNode)
reduceCExprOrZero :: (MonadReduce Lab m, HasCallStack) => C.CExpr -> Context -> m C.CExpr
reduceCExprOrZero expr ctx = do
case reduceCExpr expr ctx of
Just ex -> do
r <- ex
if r == zeroExpr
then pure r
else split ("replace by zero", C.posOf expr) (pure zeroExpr) (pure r)
reduceCExpr :: forall m. (MonadReduce Lab m, HasCallStack) => C.CExpr -> Context -> Maybe (m C.CExpr)
reduceCExpr expr ctx = case expr of
C.CBinary o elhs erhs ni -> do
if o `elem` [C.CNeqOp, C.CEqOp, C.CGeqOp, C.CLeqOp, C.CGrOp, C.CLeOp]
then do
-- in this case we change type, so we need to keep the operation
rl <- reduceCExpr elhs ctx
rr <- reduceCExpr erhs ctx
Just $ do
l' <- rl
r' <- rr
pure $ C.CBinary o l' r' ni
else do
case reduceCExpr elhs ctx of
Just elhs' -> case reduceCExpr erhs ctx of
Just erhs' -> pure do
split ("reduce to left", C.posOf elhs) elhs' do
split ("reduce to right", C.posOf erhs) erhs' do
l' <- elhs'
r' <- erhs'
pure $ C.CBinary o l' r' ni
Nothing ->
pure elhs'
Nothing
| otherwise -> fail "could not reduce left hand side"
C.CAssign o elhs erhs ni ->
case reduceCExpr elhs (addKeyword DisallowVariableInlining ctx) of
Just elhs' -> case reduceCExpr erhs ctx of
Just erhs' -> pure do
split ("reduce to left", C.posOf elhs) elhs' do
split ("reduce to right", C.posOf erhs) erhs' do
l' <- elhs'
r' <- erhs'
pure $ C.CAssign o l' r' ni
Nothing ->
fail "could not reduce right hand side"
Nothing
| otherwise -> fail "could not reduce left hand side"
C.CVar i _ ->
case Map.lookup i . inlineExprs $ ctx of
Just mx -> case mx of
Nothing -> error ("Could not find " <> show (C.identToString i) <> " at " <> show (C.posOf expr) <> "\n" <> show (inlineExprs ctx))
C.CConst x -> Just do
pure $ C.CConst x
C.CUnary o elhs ni -> do
elhs' <- reduceCExpr elhs (addKeyword DisallowVariableInlining ctx)
Just $ split ("reduce to operant", C.posOf expr) elhs' do
e <- elhs'
pure $ C.CUnary o e ni
(C.CVar i _) -> case functions ctx Map.!? i of
Just Nothing -> Nothing
-- TODO improve
-- Just $ do
-- es' <- traverse (maybeSplit ("do without param", C.posOf e) . (`reduceCExpr` ctx)) es
-- -- Not completely correct.
-- case catMaybes es' of
-- [] -> pure zeroExpr
-- [e''] -> pure e''
-- es'' -> pure $ C.CComma es'' C.undefNode
Just (Just fun) -> do
let f a ae' =
a <&> \tt -> case reduceCExpr ae' ctx of
Just re ->
Just $
whenSplit
(tt /= CTStruct)
("do without param", C.posOf ae')
(pure zeroExpr)
re
Nothing
| tt /= CTStruct -> Just (pure zeroExpr)
| otherwise -> Nothing
rargs' <- sequence . catMaybes $ zipWith f (fromMaybe [] $ funParams fun) es
Just $ do
es' <- sequence rargs'
pure $ C.CCall e es' ni
-- Just (IEKeep CTAny) -> do
-- let re = reduceCExpr e (addKeyword DisallowVariableInlining ctx)
-- res = map (`reduceCExpr` ctx) es
-- case (re, catMaybes res) of
-- (Nothing, []) -> Nothing
-- (Nothing, [r]) -> Just r
-- (_, _) -> Just do
-- e' <- maybeSplit ("do without function", C.posOf e) re
-- es' <- res & traverse (maybeSplit ("do without pram", C.posOf e))
-- case (e', catMaybes es') of
-- (Nothing, []) -> pure zeroExpr
-- (Nothing, [e'']) -> pure e''
-- (Nothing, es'') -> pure $ C.CComma es'' C.undefNode
-- (Just f, _) -> pure $ C.CCall f (map (fromMaybe zeroExpr) es') ni
-- Just (IEKeep t) -> error ("unexpected type" <> show i <> show t)
-- Just (IEInline x) -> error ("unexpected inline" <> show x)
Nothing -> error ("could not find " <> show i)
_ow -> notSupportedYet e ni
-- do
-- let re = reduceCExpr e (addKeyword DisallowVariableInlining ctx)
-- res = map (`reduceCExpr` ctx) es
-- case (re, catMaybes res) of
-- (Nothing, []) -> Nothing
-- (Nothing, [r]) -> Just r
-- (_, _) -> Just do
-- e' <- maybeSplit ("do without function", C.posOf e) re
-- es' <- res & traverse (maybeSplit ("do without pram", C.posOf e))
-- case (e', catMaybes es') of
-- (Nothing, []) -> pure zeroExpr
-- (Nothing, [e'']) -> pure e''
-- (Nothing, es'') -> pure $ C.CComma es'' C.undefNode
-- (Just f, _) -> pure $ C.CCall f (map (fromMaybe zeroExpr) es') ni
C.CCond ec et ef ni -> do
-- TODO: More fine grained reduction is possible here.
Just $ do
ec' <- reduceCExprOrZero ec ctx
ef' <- reduceCExprOrZero ef ctx
et' <- case et of
Just et' -> Just <$> reduceCExprOrZero et' ctx
Nothing -> pure Nothing
pure $ C.CCond ec' et' ef' ni
C.CCast decl e ni -> do
re <- reduceCExpr e ctx
Just do
split ("don't cast", C.posOf ni) re do
e' <- re
pure (C.CCast (inlineTypeDefsCDeclaration decl ctx) e' ni)
C.CIndex e1 e2 ni -> do
-- TODO: Better reduction is posisble here.
re1 <- reduceCExpr e1 ctx
Just do
e1' <- re1
e2' <- reduceCExprOrZero e2 ctx
pure $ C.CIndex e1' e2' ni
rx <- reduceCExpr x ctx
Just do
rst' <-
foldr
( \e cc -> do
maybeSplit ("remove expression", C.posOf e) (reduceCExpr e ctx) >>= \case
Just e' -> (e' :) <$> cc
Nothing -> cc
)
(pure [])
rst
x' <- rx
if List.null rst'
then pure x'
else pure $ C.CComma (reverse (x' : rst')) ni
C.CMember e i l ni -> do
re <- reduceCExpr e ctx
Just do
e' <- re
pure (C.CMember e' i l ni)
inlineTypeDefsCDeclaration :: C.CDeclaration C.NodeInfo -> Context -> C.CDeclaration C.NodeInfo
inlineTypeDefsCDeclaration decl ctx =
case decl of
C.CDecl items decli ni ->
C.CDecl (inlineTypeDefsSpecs items ctx) (map (`inlineTypeDefsCDI` ctx) decli) ni
a -> don'tHandle a
-- shouldDeleteFunction :: Context -> C.CFunctionDef C.NodeInfo -> Bool
-- shouldDeleteFunction ctx (C.CFunDef spec _ _ _ _) =
-- any (shouldDeleteDeclSpec ctx) spec
shouldDeleteDeclaration :: Context -> C.CDeclaration C.NodeInfo -> Bool
shouldDeleteDeclaration ctx decl =
case decl of
C.CDecl items decli _ -> any (shouldDeleteDeclSpec ctx) items || any shouldDeleteDeclItem decli
a -> don'tHandle a
where
shouldDeleteDeclItem = \case
C.CDeclarationItem a _ _ -> shouldDeleteDeclartor a
a -> don'tHandle a
shouldDeleteDeclartor = \case
C.CDeclr _ def _ _ _ -> any shouldDeleteDerivedDeclartor def
shouldDeleteDerivedDeclartor = \case
C.CFunDeclr (C.CFunParamsNew x _) _ _ ->
any (shouldDeleteDeclaration ctx) x
C.CArrDeclr{} -> False
C.CPtrDeclr _ _ -> False
a -> don'tHandle a
shouldDeleteDeclSpec :: Context -> C.CDeclarationSpecifier C.NodeInfo -> Bool
shouldDeleteDeclSpec ctx = \case
C.CTypeSpec (C.CSUType (C.CStruct _ (Just idx) Nothing _ _) _) ->
case Map.lookup idx . structs $ ctx of
Nothing -> error ("could not find struct:" <> show idx)
C.CTypeSpec (C.CSUType (C.CStruct _ _ (Just c) _ _) _) ->
any (shouldDeleteDeclaration ctx) c
_ow -> False
inlineTypeDefsSpecs :: [C.CDeclarationSpecifier C.NodeInfo] -> Context -> [C.CDeclarationSpecifier C.NodeInfo]
inlineTypeDefsSpecs r ctx =
r & concatMap \case
a@(C.CTypeSpec (C.CTypeDef idx _)) -> do
case Map.lookup idx . typeDefs $ ctx of
Just (_, ITKeep) -> [a]
Just (_, ITInline res) -> res
Nothing -> error ("could not find typedef:" <> show idx)
-- a@(C.CTypeSpec (C.CSUType (C.CStruct _ (Just idx) Nothing _ _) _)) ->
-- case Map.lookup idx . structs $ ctx of
-- Just (Just def) -> [C.CTypeSpec (C.CSUType def C.undefNode)]
-- Just Nothing -> [a]
-- Nothing -> error ("could not find struct:" <> show idx)
C.CTypeSpec (C.CSUType (C.CStruct a b (Just c) d e) f) ->
[C.CTypeSpec (C.CSUType (C.CStruct a b (Just $ map (`inlineTypeDefsCDeclaration` ctx) c) d e) f)]
a -> [a]
{-# NOINLINE inlineTypeDefsSpecs #-}
inlineTypeDefsCDeclarator
:: C.CDeclarator C.NodeInfo
-> Context
-> C.CDeclarator C.NodeInfo
inlineTypeDefsCDeclarator (C.CDeclr idn derivedd st atr ni) ctx =
C.CDeclr idn (map (inlineTypeDefsX ctx) derivedd) st atr ni
inlineTypeDefsX :: Context -> C.CDerivedDeclarator C.NodeInfo -> C.CDerivedDeclarator C.NodeInfo
inlineTypeDefsX ctx = \case
C.CFunDeclr (C.CFunParamsNew x y) b c ->
C.CFunDeclr (C.CFunParamsNew (map (`inlineTypeDefsCDeclaration` ctx) x) y) b c
C.CArrDeclr a b c -> C.CArrDeclr a b c
C.CPtrDeclr a b -> C.CPtrDeclr a b
a -> don'tHandle a
inlineTypeDefsCDI :: C.CDeclarationItem C.NodeInfo -> Context -> C.CDeclarationItem C.NodeInfo
inlineTypeDefsCDI di ctx = case di of
C.CDeclarationItem a b ni -> C.CDeclarationItem (inlineTypeDefsCDeclarator a ctx) b ni
a -> don'tHandle a
identifiers :: forall a. (Data a) => a -> [C.Ident]
identifiers d = appEndo (go d) []
where
go :: forall a'. (Data a') => a' -> Endo [C.Ident]
go d' = case cast d' of
Just l -> Endo (l :)
Nothing -> gmapQl (<>) mempty go d'
-- functionName :: C.CFunctionDef C.NodeInfo -> Maybe C.Ident
-- functionName = \case
-- C.CFunDef _ (C.CDeclr ix _ _ _ _) _ _ _ -> ix
notSupportedYet :: (HasCallStack, Show a, C.Pos n) => a -> n -> b
notSupportedYet a ni = error (show a <> " at " <> show (C.posOf ni))
noinfo :: (Functor f) => f C.NodeInfo -> f ()
noinfo a = a $> ()
don'tHandle :: (HasCallStack, Functor f, Show (f ())) => f C.NodeInfo -> b
don'tHandle f = error (show (f $> ()))
don'tHandleWithPos :: (HasCallStack, Functor f, Show (f ()), C.Pos (f C.NodeInfo)) => f C.NodeInfo -> b
don'tHandleWithPos f = error (show (f $> ()) <> " at " <> show (C.posOf f))
don'tHandleWithNodeInfo :: (HasCallStack, Functor f, Show (f ())) => f C.NodeInfo -> C.NodeInfo -> b
don'tHandleWithNodeInfo f ni = error (show (f $> ()) <> " at " <> show (C.posOf ni))
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
lookupFunction :: (HasCallStack) => Context -> C.Ident -> Maybe Function
lookupFunction ctx k =
fromMaybe (error ("could not find function " <> C.identToString k)) $
functions ctx Map.!? k
lookupStruct :: (HasCallStack) => Context -> C.Ident -> Maybe Struct
lookupStruct ctx k =
fromMaybe (error ("could not find struct " <> C.identToString k)) $
structs ctx Map.!? k
labelsOf :: C.CStatement C.NodeInfo -> [C.Ident]
labelsOf = \case
C.CLabel i s [] _ -> i : labelsOf s
C.CWhile _ s _ _ -> labelsOf s
C.CCase _ s _ -> labelsOf s
C.CDefault s _ -> labelsOf s
C.CCompound _ ss _ ->
ss & concatMap \case
C.CBlockStmt s -> labelsOf s
_ow -> []
C.CCases _ _ s _ -> labelsOf s
C.CIf _ l r _ -> labelsOf l <> maybe [] labelsOf r
C.CSwitch _ s _ -> labelsOf s
C.CFor _ _ _ s _ -> labelsOf s
_ow -> []
ctype :: (HasCallStack) => Context -> [C.CDeclarationSpecifier C.NodeInfo] -> CType
ctype ctx xs =
let ts = mapMaybe f xs
in fromJust $
foldr
( \t t' -> case t' of
Nothing -> Just t
Just t''
| t == t'' -> Just t''
| otherwise -> error ("something is broken in the c-file" <> show ts)
)
Nothing
ts
where
f = \case
(C.CTypeSpec tp) -> Just $ case tp of
C.CVoidType _ -> CTAny
C.CCharType _ -> CTNum
C.CShortType _ -> CTNum
C.CIntType _ -> CTNum
C.CFloatType _ -> CTNum
C.CDoubleType _ -> CTNum
C.CSignedType _ -> CTNum
C.CUnsigType _ -> CTNum
C.CBoolType _ -> CTNum
C.CLongType _ -> CTNum
C.CInt128Type _ -> CTNum
C.CFloatNType{} -> CTNum
C.CSUType _ _ -> CTStruct
C.CEnumType _ _ -> CTNum
C.CTypeDef idx _ ->
case Map.lookup idx . typeDefs $ ctx of
Just (t, ITKeep) -> t
Just (t, ITInline _) -> t
Nothing -> error ("could not find typedef: " <> show (C.identToString idx))
a -> notSupportedYet a C.undefNode
_ow -> Nothing
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
data Context = Context
{ keywords :: !(Set.Set Keyword)
, typeDefs :: !(Map.Map C.Ident (CType, InlineType))
, inlineExprs :: !(Map.Map C.Ident InlineExpr)
, structs :: !(Map.Map C.Ident (Maybe Struct))
, functions :: !(Map.Map C.Ident (Maybe Function))
}
deriving (Show)
data InlineType
= ITKeep
| ITInline ![C.CDeclarationSpecifier C.NodeInfo]
deriving (Show, Eq)
data InlineExpr
= IEDelete
| IEInline !C.CExpr
| IEKeep !CType
deriving (Show, Eq)
data Keyword
= LoseMain
| DoNoops
| InlineTypeDefs
| NoSemantics
| AllowEmptyDeclarations
| DisallowVariableInlining
| AllowInfiniteForLoops
deriving (Show, Read, Enum, Eq, Ord)
type Lab = (String, C.Position)
data CType
= CTNum
| CTStruct
| CTPointer
| CTFun ![Maybe CType]
| CTAny
deriving (Show, Eq)
defaultReduceCWithKeywords :: (MonadReduce (String, C.Position) m) => [Keyword] -> C.CTranslUnit -> m C.CTranslUnit
defaultReduceCWithKeywords keywords a = reduceCTranslUnit a (defaultContext{keywords = Set.fromList keywords})
{-# SPECIALIZE defaultReduceCWithKeywords :: [Keyword] -> C.CTranslUnit -> IRTree.IRTree (String, C.Position) C.CTranslUnit #-}
defaultReduceC :: (MonadReduce (String, C.Position) m) => C.CTranslUnit -> m C.CTranslUnit
defaultReduceC a = reduceCTranslUnit a defaultContext
{-# SPECIALIZE defaultReduceC :: C.CTranslUnit -> IRTree.IRTree (String, C.Position) C.CTranslUnit #-}
addTypeDefs :: [C.Ident] -> (CType, InlineType) -> Context -> Context
addTypeDefs ids cs Context{..} =
Context
{ typeDefs =
foldl' (\a i -> Map.insert i cs a) typeDefs ids
, ..
}
addInlineExpr :: C.Ident -> InlineExpr -> Context -> Context
addInlineExpr i e Context{..} =
Context
{ inlineExprs = Map.insert i e inlineExprs
, ..
}
addKeyword :: Keyword -> Context -> Context
addKeyword k Context{..} =
Context
{ keywords = Set.insert k keywords
, ..
}
defaultContext :: Context
defaultContext =
Context
{ keywords = Set.fromList []
, typeDefs = Map.empty
, inlineExprs =
Map.fromList
[ (C.builtinIdent "__PRETTY_FUNCTION__", IEKeep CTNum)
, (C.builtinIdent "__FUNCTION__", IEKeep CTNum)
]
, structs = Map.empty
, functions = Map.empty
}
isIn :: Keyword -> Context -> Bool
isIn k = Set.member k . keywords
prettyIdent :: C.Identifier C.NodeInfo -> [Char]
prettyIdent (C.Ident s _ a) = s ++ " at " ++ show (C.posOfNode a)
data Struct = Struct
{ structName :: !C.Ident
, structFields :: ![(Maybe C.Ident, Maybe CType)]
, structTag :: !C.CStructTag
, structPosition :: !C.Position
}
deriving (Show, Eq)
findStructs
:: forall m
. (Monoid m)
=> (Struct -> m)
-> Context
-> C.CExternalDeclaration C.NodeInfo
-> m
findStructs inject ctx = \case
C.CDeclExt decl -> findStructsInDeclaration decl
C.CFDefExt (C.CFunDef spec declr params stmt _ni) ->
findStructsInDeclarator declr
<> foldMap findStructsInSpecifier spec
<> foldMap findStructsInDeclaration params
<> findStructsInStatement stmt
C.CAsmExt _ _ -> mempty
where
toStruct (C.CStruct tag mid mfields _attr ni) = fromMaybe mempty do
fields <- mfields
let fields' = fmap Just <$> concatMap (declarations ctx) fields
sid <- mid
pure $ inject (Struct sid fields' tag (C.posOf ni))
-- TODO currently we do not look for structs inside of expressions.
-- (Can hide in CCompoundLiterals)
findStructsInStatement = \case
C.CCompound _ blocks _ -> flip foldMap blocks \case
C.CBlockDecl decl -> findStructsInDeclaration decl
C.CBlockStmt stmt -> findStructsInStatement stmt
a@(C.CNestedFunDef _) -> notSupportedYet (void a) a
C.CFor (C.CForDecl decl) _ _ _ _ ->
findStructsInDeclaration decl
_ow -> mempty
findStructsInDeclarator = \case
C.CDeclr _ dd Nothing [] _ -> flip foldMap dd \case
C.CPtrDeclr _ _ -> mempty
C.CArrDeclr{} -> mempty
C.CFunDeclr (C.CFunParamsOld _) _ _ -> mempty
C.CFunDeclr (C.CFunParamsNew params _) _ _ ->
foldMap findStructsInDeclaration params
a -> notSupportedYet (a $> ()) a
findStructsInDeclaration = \case
C.CDecl spec items ni ->
foldMap findStructsInSpecifier spec <> flip foldMap items \case
C.CDeclarationItem d _minit _mexpr -> do
findStructsInDeclarator d
a -> notSupportedYet (a $> ()) ni
a@(C.CStaticAssert _ _ ni) -> notSupportedYet (a $> ()) ni
findStructsInSpecifier = \case
C.CTypeSpec (C.CSUType cu _) -> toStruct cu
_ow -> mempty
data Function = Function
{ funName :: !C.Ident
, funParams :: !(Maybe [Maybe CType])
, funReturns :: !(Maybe CType)
, funIsStatic :: !Bool
, funSize :: !Int
, funPosition :: !C.Position
}
deriving (Show, Eq)
findFunctions
:: (Monoid m)
=> (Function -> m)
-> Context
-> C.CExternalDeclaration C.NodeInfo
-> m
findFunctions inject ctx = \case
C.CFDefExt (C.CFunDef spec declr [] _ ni) ->
findFunctionsInDeclarator ni spec declr
-- # for now let's not anlyse function declarations.
C.CFDefExt def@(C.CFunDef{}) ->
notSupportedYet (void def) def
C.CDeclExt (C.CDecl spec items ni) -> flip foldMap items \case
C.CDeclarationItem declr Nothing Nothing ->
findFunctionsInDeclarator ni spec declr
_ow -> mempty
C.CDeclExt a@(C.CStaticAssert{}) ->
notSupportedYet (void a) a
C.CAsmExt _ _ -> mempty
where
findFunctionsInDeclarator ni spec = \case
(C.CDeclr mid (functionParameters -> Just (params, change)) Nothing [] _) -> case mid of
Just funName -> inject Function{..}
where
funParams = params <&> fmap (Just . snd) . concatMap (declarations ctx)
funReturns = change $ case ctype ctx spec of
CTAny -> Nothing
t -> Just t
funIsStatic = any (\case (C.CStorageSpec (C.CStatic _)) -> True; _ow -> False) spec
funSize = fromMaybe 0 (C.lengthOfNode ni)
funPosition = C.posOf ni
Nothing -> mempty
_ow -> mempty
-- \| Returns nothing if void is used
functionParameters
:: [C.CDerivedDeclarator C.NodeInfo]
-> Maybe (Maybe [C.CDeclaration C.NodeInfo], Maybe CType -> Maybe CType)
functionParameters = \case
(C.CFunDeclr (C.CFunParamsNew x _) _ _) : rst ->
case x of
[C.CDecl [C.CTypeSpec (C.CVoidType _)] _ _] ->
Just (Nothing, applyDerivedDeclarators rst)
params -> Just (Just params, applyDerivedDeclarators rst)
_ow -> Nothing
applyDerivedDeclarators :: [C.CDerivedDeclarator C.NodeInfo] -> Maybe CType -> Maybe CType
applyDerivedDeclarators [] ct = ct
applyDerivedDeclarators _ _ = Just CTPointer
declarations :: Context -> C.CDeclaration C.NodeInfo -> [(Maybe C.Ident, CType)]
declarations ctx = \case
C.CDecl spec items _ -> let t = ctype ctx spec in map (\i -> (name i, t)) items
a@(C.CStaticAssert _ _ n) -> notSupportedYet a n
class Named f where
name :: f a -> Maybe (C.Identifier a)
instance Named C.CDeclarator where
name (C.CDeclr idx _ _ _ _) = idx
instance Named C.CDeclarationItem where
name = \case
C.CDeclarationItem decl _ _ -> name decl
C.CDeclarationExpr _ -> Nothing
includeTypeDef :: (Monad m) => C.CExternalDeclaration C.NodeInfo -> StateT Context m ()
includeTypeDef = \case
C.CDeclExt (C.CDecl (C.CStorageSpec (C.CTypedef _) : rst) decl _) -> do
let [ids] = identifiers decl
modify (\ctx -> addTypeDefs [ids] (ctype ctx rst, ITInline rst) ctx)
_ow -> pure ()
containsStructDeclaration
:: (MonadPlus m, MonadState Context m)
=> [C.CDeclarationSpecifier C.NodeInfo]
-> m Bool
containsStructDeclaration spec =
or <$> forM spec \case
-- Is a struct definition
C.CTypeSpec (C.CSUType (C.CStruct _ mid def _ _) _) -> case mid of
Just sid -> do
-- Delete if struct is deleted.
ctx <- get
_ <- liftMaybe (lookupStruct ctx sid)
case def of
Just _ -> pure True
Nothing -> pure False
Nothing -> pure False
_ow -> pure False
filterParams
:: Context
-> [Maybe CType]
-> [C.CDeclaration C.NodeInfo]
-> ([C.CDeclaration C.NodeInfo], [(C.Ident, InlineExpr)])
filterParams ctx typefilter params = flip evalState typefilter do
(params', mapping) <- flip mapAndUnzipM params \case
decl@(C.CDecl def items l) -> do
(items', defs) <- flip mapAndUnzipM items \case
a'@(C.CDeclarationItem (C.CDeclr idx _ _ _ _) _ _) -> do
t' <- state (\(t : tps) -> (t, tps))
pure $ case t' of
Just t
| not (shouldDeleteDeclaration ctx decl) ->
([a'], [(idx', IEKeep t) | idx' <- maybeToList idx])
_ow ->
([], [(idx', IEDelete) | idx' <- maybeToList idx])
a' -> notSupportedYet a' l
case concat items' of
[] -> pure ([], concat defs)
items'' -> pure ([C.CDecl def items'' l], concat defs)
a' -> don'tHandleWithPos a'
pure (concat params', concat mapping)