Newer
Older
-- * Context
Context (..),
defaultContext,
-- * Helpers
prettyIdent,
) where
import qualified Data.Set as Set
import Data.Vector.Internal.Check (HasCallStack)
, fields :: !(Map.Map C.Ident (Maybe C.Ident))
, structs :: !(Map.Map C.Ident (Maybe C.CStructUnion))
= ITKeep
| ITInline ![C.CDeclarationSpecifier C.NodeInfo]
deriving (Show, Eq)
data InlineExpr
= IEDelete
| IEInline !C.CExpr
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
, ..
}
addStruct :: StructDef -> Context -> Context
addStruct (StructDef k fs _) Context{..} =
Context
{ structs = Map.insert k Nothing structs
, fields = foldr (`Map.insert` Just k) fields fs
, ..
}
removeStruct :: StructDef -> Context -> Context
removeStruct (StructDef k fs un) Context{..} =
Context
{ structs = Map.insert k (Just un) structs
, fields = foldr (`Map.insert` Nothing) fields fs
, ..
}
defaultContext :: Context
defaultContext =
Context
[ (C.builtinIdent "fabsf", IEKeep (CTFun [Just CTInt, Just CTInt]))
, (C.builtinIdent "fabs", IEKeep (CTFun [Just CTInt, Just CTInt]))
, (C.builtinIdent "__PRETTY_FUNCTION__", IEKeep CTInt)
, (C.builtinIdent "__FUNCTION__", IEKeep CTInt)
, fields = Map.empty
, structs = 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)
reduceCTranslUnit
:: (MonadReduce Lab m)
=> C.CTranslationUnit C.NodeInfo
-> Context
-> m (C.CTranslationUnit C.NodeInfo)
reduceCTranslUnit (C.CTranslUnit es ni) ctx = do
res' <- evalStateT (mapM (StateT . reduceCExternalDeclaration) es) ctx
es' <- sequence . catMaybes $ res'
pure $ C.CTranslUnit es' ni
reduceCExternalDeclaration
:: (MonadReduce Lab m)
=> C.CExternalDeclaration C.NodeInfo
-> Context
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
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
-> m (Maybe (m (C.CExternalDeclaration C.NodeInfo)), Context)
reduceCExternalDeclaration r ctx = case r of
C.CFDefExt fun
| not (LoseMain `isIn` ctx)
&& maybe False (("main" ==) . C.identToString) (functionName fun) -> do
pure (Just $ C.CFDefExt <$> reduceCFunDef fun ctx, ctx)
| otherwise ->
case functionName fun of
Just fid -> do
split
("remove function " <> C.identToString fid, C.posOf r)
(pure (Nothing, addInlineExpr fid IEDelete ctx))
do
(fun', ps) <- case Map.lookup fid . inlineExprs $ ctx of
Just (IEKeep (CTFun args)) ->
reduceParamsTo args fun
_ow -> do
reduceParams ctx fun
let x =
reduceCFunDef
fun'
( foldr
( \case
(Just t, Just i) -> addInlineExpr i (IEKeep t)
(Nothing, Just i) -> addInlineExpr i IEDelete
(_, Nothing) -> id
)
ctx
ps
)
pure
( Just (C.CFDefExt <$> x)
, addInlineExpr fid (IEKeep (CTFun (map fst ps))) ctx
)
Nothing -> do
split
("remove function", C.posOf r)
(pure (Nothing, ctx))
(pure (Just (C.CFDefExt <$> reduceCFunDef fun ctx), ctx))
C.CDeclExt decl -> do
(decl', ctx') <- handleDecl decl ctx
case decl' of
Just d -> pure (Just (C.CDeclExt <$> d), ctx')
Nothing -> pure (Nothing, ctx')
_r -> don'tHandle r
data StructDef = StructDef
{ structId :: !C.Ident
, fieldIds :: ![C.Ident]
, structDef :: !C.CStructUnion
}
deriving (Show, Eq)
structIds
:: (Foldable f)
=> f (C.CDeclarationSpecifier C.NodeInfo)
-> [StructDef]
structIds = concatMap \case
C.CTypeSpec (C.CSUType (C.CStruct a (Just n) (Just ma) b c) _) ->
[ StructDef
n
[ x
| C.CDecl _ itms _ <- ma
, C.CDeclarationItem (C.CDeclr (Just x) _ _ _ _) _ _ <- itms
]
(C.CStruct a (Just n) (Just ma) b c)
]
_ow -> []
trySplit :: (MonadReduce l m, Eq a) => l -> a -> (a -> a) -> m a
trySplit l a action = do
let a' = action a
if a /= a'
then split l (pure a') (pure a)
else pure a
=> C.CFunctionDef C.NodeInfo
-> Context
-> m (C.CFunctionDef C.NodeInfo)
reduceCFunDef (C.CFunDef spc dec cdecls smt ni) ctx = do
spc1 <- trySplit ("remove static", C.posOf ni) spc $ filter \case
C.CStorageSpec (C.CStatic _) -> False
_ow -> True
spc2 <- trySplit ("remove inline", C.posOf ni) spc1 $ filter \case
C.CFunSpec (C.CInlineQual _) -> False
_ow -> True
(inlineTypeDefsCDeclarator dec ctx)
(map (`inlineTypeDefsCDeclaration` ctx) cdecls)
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
reduceParamsTo
:: (MonadReduce Lab m)
=> [Maybe CType]
-> C.CFunctionDef C.NodeInfo
-> m (C.CFunctionDef C.NodeInfo, [(Maybe CType, Maybe (C.Identifier C.NodeInfo))])
reduceParamsTo types (C.CFunDef a (C.CDeclr b declrs c d e) f g h) =
types & evalStateT do
(unzip -> (declrs', defs)) <-
declrs & mapM \case
C.CFunDeclr (C.CFunParamsNew decls i) j k -> do
(unzip -> (decls', defs)) <-
decls & mapM \case
C.CDecl def items l -> do
(unzip -> (items', defs)) <-
items & mapM \case
a'@(C.CDeclarationItem (C.CDeclr idx _ _ _ _) _ _) -> do
t' <- state (\(t : tps) -> (t, tps))
case t' of
Just t -> pure ([a'], [(Just t, idx)])
Nothing -> pure ([], [(Nothing, idx)])
a' -> notSupportedYet a' k
case concat items' of
[] -> pure ([], concat defs)
items'' -> pure ([C.CDecl def items'' l], concat defs)
a' -> don'tHandleWithPos a'
pure (C.CFunDeclr (C.CFunParamsNew (concat decls') i) j k, concat defs)
ow -> pure (ow, [])
pure (C.CFunDef a (C.CDeclr b declrs' c d e) f g h, concat defs)
reduceParams'
:: (MonadReduce Lab m)
=> Context
-> [C.CDerivedDeclarator C.NodeInfo]
-> m ([C.CDerivedDeclarator C.NodeInfo], [[(Maybe CType, Maybe (C.Identifier C.NodeInfo))]])
reduceParams' ctx declrs = do
(unzip -> (declrs', defs)) <-
declrs & mapM \case
C.CFunDeclr (C.CFunParamsNew decls i) j k -> do
(unzip -> (decls', defs)) <-
decls & mapM \case
C.CDecl def items l -> do
(unzip -> (items', defs)) <-
items & mapM \case
a'@(C.CDeclarationItem (C.CDeclr idx _ _ _ _) _ _) ->
split
("remove parameter", C.posOf k)
(pure ([], [(Nothing, idx)]))
(pure ([a'], [(Just (ctype ctx def), idx)]))
a' -> notSupportedYet a' k
case concat items' of
[] -> pure ([], concat defs)
items'' -> pure ([C.CDecl def items'' l], concat defs)
a' -> don'tHandleWithPos a'
pure (C.CFunDeclr (C.CFunParamsNew (concat decls') i) j k, [concat defs])
ow -> pure (ow, [])
pure (declrs', concat defs)
reduceParams
:: (MonadReduce Lab m)
=> Context
-> C.CFunctionDef C.NodeInfo
-> m (C.CFunctionDef C.NodeInfo, [(Maybe CType, Maybe C.Ident)])
reduceParams ctx (C.CFunDef a (C.CDeclr b declrs c d e) f g h) = do
(declrs', defs) <- reduceParams' ctx declrs
pure (C.CFunDef a (C.CDeclr b declrs' c d e) f g h, concat defs)
ctype :: 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
f = \case
(C.CTypeSpec tp) -> Just $ case tp of
C.CVoidType _ -> CTAny
C.CCharType _ -> CTInt
C.CShortType _ -> CTInt
C.CIntType _ -> CTInt
C.CFloatType _ -> CTInt
C.CDoubleType _ -> CTInt
C.CSignedType _ -> CTInt
C.CUnsigType _ -> CTInt
C.CBoolType _ -> CTInt
C.CLongType _ -> CTInt
C.CInt128Type _ -> CTInt
C.CFloatNType{} -> CTInt
C.CSUType _ _ -> CTStruct
C.CEnumType _ _ -> CTInt
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 idx)
a -> notSupportedYet a C.undefNode
_ow -> Nothing
=> C.CCompoundBlockItem C.NodeInfo
-> (Context -> m [C.CCompoundBlockItem C.NodeInfo])
-> Context
-> m [C.CCompoundBlockItem C.NodeInfo]
reduceCCompoundBlockItem r cont ctx = do
case r of
C.CBlockStmt smt -> do
case reduceCStatement smt ctx of
Just rsmt -> split ("remove statement", C.posOf r) (cont ctx) do
smt' <- rsmt
case smt' of
C.CCompound [] ss _ -> do
split ("expand compound statment", C.posOf r) ((ss <>) <$> cont ctx) do
(C.CBlockStmt smt' :) <$> cont ctx
_ow -> do
(C.CBlockStmt smt' :) <$> cont ctx
Nothing -> cont ctx
C.CBlockDecl declr -> do
(declr', ctx') <- handleDecl declr ctx
case declr' of
handleDecl
:: (MonadReduce Lab m)
=> C.CDeclaration C.NodeInfo
-> Context
handleDecl d ctx = case inlineTypeDefsCDeclaration d ctx of
-- A typedef
C.CDecl (C.CStorageSpec (C.CTypedef _) : rst) decl _ -> do
let [ids] = identifiers decl
("inline typedef " <> C.identToString ids, C.posOf d)
(pure (Nothing, addTypeDefs [ids] (ctype ctx rst, ITInline rst) ctx))
(pure (Just (pure d), addTypeDefs [ids] (ctype ctx rst, ITKeep) ctx))
(decl', ctx') <- foldr (reduceCDeclarationItem (ctype ctx spc)) (pure ([], ctx)) decl
let fn = do
spc1 <- trySplit ("remove static", C.posOf ni') spc $ filter \case
C.CStorageSpec (C.CStatic _) -> False
_ow -> True
([], [])
| AllowEmptyDeclarations `isIn` ctx' ->
split ("remove empty declaration", C.posOf d) (pure (Nothing, ctx')) do
| otherwise -> pure (Nothing, ctx')
([], stcts) ->
split
("remove declaration", C.posOf d)
(pure (Nothing, foldr removeStruct ctx' stcts))
do
-> 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)
( inlineTypeDefsCDI (C.CDeclarationItem dr (Just (C.CInitExpr c' ni')) Nothing) ctx
: ds
C.CDeclarationItem (C.CDeclr (Just i) a Nothing b ni) ex Nothing -> do
ex' <- case ex of
Just ix -> maybeSplit ("remove initializer", C.posOf ni) (reduceCInitializer ix ctx)
Nothing -> pure Nothing
(a', t') <-
if C.identToString i == "printf"
then pure (a, CTAny)
else do
(a', defs) <- reduceParams' ctx a
let t' = case defs of
[args] -> CTFun (map fst args)
[] -> t
_x -> error ("Unexpected" <> unlines (map show _x) <> show (C.posOf ni))
pure (a', t')
let d' = C.CDeclarationItem (C.CDeclr (Just i) a' Nothing b ni) ex' Nothing
split
("remove variable " <> C.identToString i, C.posOf ni)
(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
=> C.CStatement C.NodeInfo
-> Context
-> m (C.CStatement C.NodeInfo)
reduceCStatementOrEmptyBlock stmt ctx = do
case reduceCStatement stmt ctx of
Just ex -> do
ex
Nothing -> do
pure emptyBlock
emptyBlock :: C.CStatement C.NodeInfo
emptyBlock = C.CCompound [] [] C.undefNode
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
=> C.CStatement C.NodeInfo
-> Context
-> Maybe (m (C.CStatement C.NodeInfo))
reduceCStatement smt ctx = case smt of
C.CCompound is cbi ni -> Just do
cbi' <- foldr reduceCCompoundBlockItem (\_ -> pure []) cbi ctx
pure $ C.CCompound is cbi' ni
C.CWhile e s dow ni -> do
rs <- reduceCStatement s ctx
Just do
e' <- reduceCExprOrZero e ctx
s' <- rs
pure $ C.CWhile e' s' dow ni
C.CExpr me ni -> do
case me of
Just e -> do
if DoNoops `isIn` ctx
then Just do
e' <- maybeSplit ("change to noop", C.posOf smt) $ reduceCExpr e ctx
pure $ C.CExpr e' ni
else do
re <- reduceCExpr e ctx
Just do
e' <- re
pure $ C.CExpr (Just e') ni
Nothing ->
Just $ pure $ C.CExpr Nothing ni
C.CReturn me ni -> do
-- TODO: If function returntype is not struct return 0
re <- reduceCExpr e ctx
Just $ do
e' <- re
pure $ C.CReturn (Just e') ni
C.CIf e s els ni -> Just do
e' <- maybeSplit ("remove condition", C.posOf e) $ reduceCExpr e ctx
els' <- case els of
Just els' -> do
maybeSplit ("remove else branch", C.posOf els') do
reduceCStatement els' ctx
Nothing -> pure Nothing
ms' <- maybeSplit ("remove if branch", C.posOf s) do
reduceCStatement s 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'
C.CFor e1 e2 e3 s ni -> Just $ do
(me1', ctx') <- case e1 of
C.CForDecl (C.CDecl rec decl ni') -> do
(decl', ctx') <- foldr (reduceCDeclarationItem (ctype ctx rec)) (pure ([], ctx)) decl
res <-
if null decl'
then
whenSplit
(AllowEmptyDeclarations `isIn` ctx')
("remove empty declaration", C.posOf ni')
(pure Nothing)
(pure $ Just $ C.CForDecl (C.CDecl rec decl' ni'))
else pure $ Just $ C.CForDecl (C.CDecl rec decl' ni')
pure (res, ctx')
C.CForInitializing e -> do
e' <- maybeSplit ("remove initializer", C.posOf ni) (e >>= \e' -> reduceCExpr e' ctx)
whenSplit
(AllowEmptyDeclarations `isIn` ctx)
("remove empty declaration", C.posOf ni)
(pure (Nothing, ctx))
e2' <- case e2 of
Just e2' -> maybeSplit ("remove check", C.posOf e2') (reduceCExpr e2' ctx')
Nothing -> pure Nothing
e3' <- case e3 of
Just e3' -> maybeSplit ("remove iterator", C.posOf e3') (reduceCExpr e3' ctx')
Nothing -> pure Nothing
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 -> Just do
s' <- reduceCStatementOrEmptyBlock s ctx
pure $ C.CLabel i s' [] ni
C.CGoto i ni -> Just do
pure $ C.CGoto i ni
-- | 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)
data CType
= CTInt
| CTStruct
| CTPointer
| CTFun ![Maybe CType]
| CTAny
deriving (Show, Eq)
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
Nothing -> error ("Could not find " <> show 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
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
let inlineExprOf i = Map.lookup i . inlineExprs $ ctx
case e of
(C.CVar i _) -> case inlineExprOf i of
Just IEDelete -> 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 (IEKeep (CTFun args)) -> do
rargs' :: [m C.CExpr] <- sequence . catMaybes . (\f -> zipWith f args es) $ \a ae' ->
a <&> \tt ->
let r = 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
in r :: Maybe (m C.CExpr)
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
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) => a -> C.NodeInfo -> 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))