{-# LANGUAGE BlockArguments #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE NoMonomorphismRestriction #-} module ReduceC ( defaultReduceC, defaultReduceCWithKeywords, -- reduceCTranslUnit, -- * Context Context (..), defaultContext, -- * Helpers prettyIdent, ) where import CType import Control.Applicative import Control.Monad import qualified Control.Monad.IRTree as IRTree import Control.Monad.Reduce import Control.Monad.State import Control.Monad.Trans.Maybe import Data.Bifunctor import Data.Function import Data.Functor import qualified Data.List as List import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.Set as Set import Data.Vector.Internal.Check (HasCallStack) import Debug.Pretty.Simple import Language.C (Pos (posOf)) import qualified Language.C as C import qualified Language.C.Data.Ident as C import qualified Language.C.Data.Node as C import Text.Pretty.Simple (pShow) 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 #-} reduceCTranslUnit :: (MonadReduce Lab m) => C.CTranslationUnit C.NodeInfo -> Context -> m (C.CTranslationUnit C.NodeInfo) reduceCTranslUnit (C.CTranslUnit es ni) ctx = do let _functions = foldMap (findFunctions (: [])) es let funmap :: [(C.Ident, Maybe Function)] = List.sortOn (maybe 0 (negate . funSize) . snd) . Map.toList . Map.fromListWith const . map (\f -> (funName f, Just f)) . List.sortOn funSize $ _functions let reduce funcs = forM funcs \(k, mf) -> (k,) <$> runMaybeT do f <- liftMaybe mf let fstr = C.identToString (funName f) when (C.identToString (funName f) /= "main" || LoseMain `isIn` ctx) do exceptIf ("remove function " <> fstr <> " (" <> show (funSize f) <> ")", funPosition f) isStatic <- if funIsStatic f then split ("remove static from " <> fstr, funPosition f) (pure False) (pure True) else pure False pure f{funIsStatic = isStatic} -- try remove static functions2 <- do funmap' <- reduce funmap if ComputeFunctionFixpoint `isIn` ctx then reduce funmap else pure funmap' functions3 <- forM functions2 \(k, mf) -> (k,) <$> runMaybeT do f <- liftMaybe mf params <- case funParams f of Just params -> do Just <$> forM params \p -> if p then split ("remove parameter", funPosition f) (pure False) (pure True) else pure False ow -> pure ow pure f{funParams = params} let builtins = [ ("fabsf", FunType (NonVoid TNum) (Params [Just TNum] False)) , ("fabs", FunType (NonVoid TNum) (Params [Just TNum] False)) ] let functions''' = Map.fromList $ [ ( funName , Just $ Function { funIsStatic = False , funPosition = C.posOf funName , funSize = 0 , funParams = case funTypeParams funType of VoidParams -> Nothing Params _ True -> Nothing Params fx False -> Just [isJust f | f <- fx] , .. } ) | (C.builtinIdent -> funName, funType) <- builtins ] <> functions3 -- let _structs = foldMap (findStructs (: [])) es -- structs' <- flip execStateT (structs ctx) do -- forM_ _structs \s -> do -- let sstr = C.identToString (structName s) -- ms <- runMaybeT do -- exceptIf ("remove struct " <> show sstr, structPosition s) -- let st = structType s -- fields <- forM (structTypeFields st) \(i, m) -> do -- (i,) <$> runMaybeT do -- m' <- liftMaybe m -- exceptIf ("remove field " <> sstr <> "." <> C.identToString i, structPosition s) -- pure m' -- pure s{structType = st{structTypeFields = fields}} -- modify' (Map.insert (structName s) (structType s, ms)) let ctx' = ctx { functions = functions''' , inlineExprs = inlineExprs ctx <> Map.fromList [(C.builtinIdent f, IEKeep (TFun ft)) | (f, ft) <- builtins] } res' <- evalStateT (mapM reduceCExternalDeclaration es) ctx' pure $ C.CTranslUnit (catMaybes res') ni data SpecifierFilter = SpecifierFilter { sfKeepStatic :: Bool } keepAll :: SpecifierFilter keepAll = SpecifierFilter{sfKeepStatic = True} {- | Update the CDeclarationSpecifier's to match the context. Specifically, update the typedefs and the structs. Alos return a base type. -} updateCDeclarationSpecifiers :: ( MonadState Context m , MonadPlus m ) => SpecifierFilter -> [C.CDeclarationSpecifier C.NodeInfo] -> m (Voidable, [C.CDeclarationSpecifier C.NodeInfo]) updateCDeclarationSpecifiers sf spec = do ctx <- get spec' <- concat <$> mapM (updateSpec ctx) spec bt <- baseType ctx spec' pure (bt, spec') where baseType :: (MonadPlus m) => Context -> [C.CDeclarationSpecifier C.NodeInfo] -> m Voidable baseType ctx = do liftMaybe . baseTypeOf (lookupStruct ctx) ( \t -> case Map.lookup t (typeDefs ctx) of Just (ITKeep t') -> Just t' Just ITDelete -> Nothing Just (ITInline t' _) -> Just t' Nothing -> error "error" ) updateSpec ctx a = case a of C.CTypeSpec t -> case t of C.CSUType (C.CStruct st (Just i) (Just declrs) attr x) b -> do fields <- liftMaybe $ structTypeFields <$> lookupStruct ctx i let declrs' :: [C.CDeclaration C.NodeInfo] = filterStruct ctx fields declrs pure [C.CTypeSpec (C.CSUType (C.CStruct st (Just i) (Just declrs') attr x) b)] C.CTypeDef idx _ -> do case Map.lookup idx . typeDefs $ ctx of Just (ITKeep _) -> pure [C.CTypeSpec t] Just (ITInline _ res) -> pure res Just ITDelete -> mzero Nothing -> error ("could not find typedef: " <> show idx) _ow -> pure [C.CTypeSpec t] C.CStorageSpec (C.CStatic _) -> pure [a | sfKeepStatic sf] C.CFunSpec (C.CInlineQual _) -> pure [a | sfKeepStatic sf] _ow -> pure [a] filterStruct ctx fields declrs = flip evalState fields do fmap concat . forM declrs $ \case decl@(C.CDecl def items l) -> do items' <- fmap catMaybes . forM items $ \item -> do t' <- state (\((_, t) : tps) -> (t, tps)) case t' of Just _ -> do -- TODO check for bad struct name here declaration pure (Just item) _ow -> do pure Nothing pure [C.CDecl def items' l | not (List.null items')] a' -> notSupportedYet' a' updateCDerivedDeclarators :: forall m . ( MonadState Context m , MonadPlus m ) => Voidable -> [Bool] -> [C.CDerivedDeclarator C.NodeInfo] -> m (Voidable, [C.CDerivedDeclarator C.NodeInfo]) updateCDerivedDeclarators bt ff dd = do foldM applyDD (bt, []) (reverse dd) where applyDD :: (r ~ (Voidable, [C.CDerivedDeclarator C.NodeInfo])) => r -> C.CDerivedDeclarator C.NodeInfo -> m r applyDD (t, dd') d = case d of C.CPtrDeclr _ _ -> do pure (NonVoid . TPointer $ t, d : dd') C.CArrDeclr{} -> pure (NonVoid . TPointer $ t, d : dd') C.CFunDeclr params arr ni -> do case params of C.CFunParamsNew params' varadic -> do (tp, params'') <- state (runState (findParams varadic params')) let t' = NonVoid $ TFun (FunType t tp) pure (t', C.CFunDeclr (C.CFunParamsNew params'' varadic) arr ni : dd') b -> notSupportedYet b ni findParams :: Bool -> [C.CDeclaration C.NodeInfo] -> State Context (Params, [C.CDeclaration C.NodeInfo]) findParams varadic decls = case decls of [C.CDecl [C.CTypeSpec (C.CVoidType _)] [] _] -> pure (VoidParams, decls) _ow -> flip evalStateT ff do result <- forM decls $ \case C.CDecl spec items ni -> do keep <- state (\(t : tps) -> (t, tps)) lift . runMaybeT $ do (bt', spec') <- updateCDeclarationSpecifiers keepAll spec (t, items') <- case items of [] -> do guard keep pure (nonVoid bt', []) [C.CDeclarationItem (C.CDeclr mid dd2 Nothing [] ni3) Nothing ni2] -> do (t, dd2') <- case mid of Just ix -> do modify' (addInlineExpr ix IEDelete) (nonVoid -> t, dd2') <- updateCDerivedDeclarators bt' [] dd2 guard keep modify' (addInlineExpr ix (IEKeep t)) pure (t, dd2') Nothing -> do (nonVoid -> t, dd2') <- updateCDerivedDeclarators bt' [] dd2 guard keep pure (t, dd2') pure (t, [C.CDeclarationItem (C.CDeclr mid dd2' Nothing [] ni3) Nothing ni2]) _ow -> notSupportedYet items ni pure (t, C.CDecl spec' items' ni) a -> notSupportedYet' a let (t, decls') = unzip $ catMaybes result pure (Params (map Just t) varadic, decls') -- filterParams -- :: Context -- -> [Maybe Type] -- -> [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 -- t' <- state (\(t : tps) -> (t, tps)) -- case t' of -- Just t -- | not (shouldDeleteDeclaration ctx decl) -> do -- let defs = [(idx', IEKeep t) | i <- items, idx' <- maybeToList (name i)] -- pure ([C.CDecl def items l], defs) -- _ow -> do -- let defs = [(idx', IEDelete) | i <- items, idx' <- maybeToList (name i)] -- pure ([], defs) -- a' -> notSupportedYet' a' -- pure (concat params', concat mapping) -- 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 -> notSupportedYet' a -- -- 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 -> notSupportedYet' 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 -> notSupportedYet a C.undefNode reduceCExternalDeclaration :: (HasCallStack, MonadReduce Lab m) => C.CExternalDeclaration C.NodeInfo -> 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 let C.CDeclr mid dd Nothing [] ni2 = declr -- TODO handle this edgecase (struct declared in function declaration) (_, spec2) <- reduceStructDeclaration spec mfun <- case mid of Just fid -> do modify' (addInlineExpr fid IEDelete) Just <$> liftMaybe (lookupFunction ctx fid) Nothing -> pure Nothing let keepStatic = maybe True funIsStatic mfun (bt, spec') <- updateCDeclarationSpecifiers keepAll{sfKeepStatic = keepStatic} spec2 ((nonVoid -> t@(TFun (FunType rt _)), dd'), ctx') <- runStateT (updateCDerivedDeclarators bt (fromMaybe (repeat True) (mfun >>= funParams)) dd) ctx case mfun of Just fun -> do modify' (addInlineExpr (funName fun) (IEKeep t)) Nothing -> do exceptIf ("remove function", C.posOf r) labs <- flip collect (labelsOf stmt) \l -> do exceptIf ("remove label" <> show l, C.posOf l) pure l stmt' <- reduceCStatementOrEmptyBlock stmt StmtContext{stmtLabels = labs, stmtInLoop = False} $ ctx'{returnType = rt} pure . C.CFDefExt $ C.CFunDef spec' (C.CDeclr mid dd' Nothing [] ni2) [] stmt' ni -- Type definitions C.CDeclExt (C.CDecl (C.CStorageSpec (C.CTypedef nif) : rst) [item] ni) -> runMaybeT do let C.CDeclarationItem (C.CDeclr (Just ix) [] Nothing [] _) Nothing Nothing = item modify' (addTypeDef ix ITDelete) (keep, rst2) <- reduceStructDeclaration rst (NonVoid t, rst') <- updateCDeclarationSpecifiers keepAll rst2 unless keep do modify' (addTypeDef ix (ITInline t rst')) exceptIf ("inline typedef " <> C.identToString ix, C.posOf ni) modify' (addTypeDef ix (ITKeep t)) pure $ C.CDeclExt $ C.CDecl (C.CStorageSpec (C.CTypedef nif) : rst') [item] ni -- The rest. C.CDeclExt (C.CDecl spec items ni) -> runMaybeT do ctx <- get markDeleted items -- TODO: Actually we should split it up here let isStatic = flip any items \case (C.CDeclarationItem (C.CDeclr (Just fid) (C.CFunDeclr{} : _) _ _ _) _ _) -> do maybe True funIsStatic (lookupFunction ctx fid) _ow -> True (keep, spec2) <- reduceStructDeclaration spec (bt, spec') <- updateCDeclarationSpecifiers keepAll{sfKeepStatic = isStatic} spec2 -- 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{} : _ -> do mfun <- case mid of Just fid -> Just <$> liftMaybe (lookupFunction ctx fid) Nothing -> pure Nothing let ff = fromMaybe (repeat True) (mfun >>= funParams) (nonVoid -> t, dd') <- evalStateT (updateCDerivedDeclarators bt ff dd) ctx case mid of Just fid -> do modify' (addInlineExpr fid (IEKeep t)) Nothing -> do exceptIf ("remove function", C.posOf ni2) pure (C.CDeclarationItem (C.CDeclr mid dd' Nothing [] ni2) einit size) _dd -> reduceCDeclarationItem bt di 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) pure $ C.CDeclExt $ C.CDecl spec' items' ni _r -> notSupportedYet' r wrapCCompound :: C.CStatement C.NodeInfo -> C.CStatement C.NodeInfo wrapCCompound = \case s@(C.CCompound{}) -> s s -> C.CCompound [] [C.CBlockStmt s] C.undefNode isStaticFromSpecs :: [C.CDeclarationSpecifier C.NodeInfo] -> Bool isStaticFromSpecs = any \case (C.CStorageSpec (C.CStatic _)) -> True _ow -> False {- | This checks the current declaration and reduces any new struct found here. Returns true if the specifier is requried. -} reduceStructDeclaration :: ( MonadReduce Lab m , MonadState Context m , MonadPlus m ) => [C.CDeclarationSpecifier C.NodeInfo] -> m (Bool, [C.CDeclarationSpecifier C.NodeInfo]) reduceStructDeclaration = fmap (first or) . mapAndUnzipM \case x@(C.CTypeSpec (C.CSUType (C.CStruct tag mid (Just fields) attr ni2) ni)) -> case mid of Just sid -> do struct <- gets (Map.lookup sid . structs) case struct of -- Already declared do nothing. Just _ -> pure (False, x) -- Not declared do somthing Nothing -> do split ("remove struct " <> C.identToString sid, C.posOf ni) do modify' (addStruct sid Nothing) mzero do (ft, catMaybes -> fields') <- mapAndUnzipM (structField sid) fields modify' ( addStruct sid ( Just StructType { structTypeTag = tag , structTypeName = Just sid , structTypeFields = concat ft } ) ) pure (True, C.CTypeSpec (C.CSUType (C.CStruct tag mid (Just fields') attr ni2) ni)) Nothing -> pure (False, x) x -> pure (False, x) where structField sid = \case C.CDecl spec items ni -> do -- TODO: Currently deletes all struct fields if one of them are deleted. res <- runMaybeT $ updateCDeclarationSpecifiers keepAll spec case res of Just (bt, spec') -> do (fields, items') <- flip mapAndUnzipM items \case (C.CDeclarationItem (C.CDeclr mid dd Nothing [] ni3) ini ni2) -> do let fid = fromMaybe (error "all struct fields should be named") mid res' <- runMaybeT $ do (nonVoid -> t, dd') <- updateCDerivedDeclarators bt (repeat True) dd exceptIf ("remove field " <> C.identToString sid <> "." <> C.identToString fid, C.posOf ni) pure (t, dd') case res' of Nothing -> pure ((fid, Nothing), Nothing) Just (t, dd') -> pure ((fid, Just t), Just $ C.CDeclarationItem (C.CDeclr mid dd' Nothing [] ni3) ini ni2) a -> notSupportedYet a ni case catMaybes items' of [] -> pure (fields, Nothing) items'' -> pure (fields, Just (C.CDecl spec' items'' ni)) Nothing -> pure ( map (\i -> (fromMaybe (error "all struct fields should be named") (name i), Nothing)) items , Nothing ) a@(C.CStaticAssert{}) -> notSupportedYet' a reduceCDeclarationItem :: ( MonadReduce Lab m , MonadState Context m , MonadPlus m ) => Voidable -> C.CDeclarationItem C.NodeInfo -> m (C.CDeclarationItem C.NodeInfo) reduceCDeclarationItem bt = \case di@(C.CDeclarationItem (C.CDeclr mid dd Nothing [] ni) einit Nothing) -> do ctx <- get case mid of Just vid -> do (nonVoid -> t, dd') <- evalStateT (updateCDerivedDeclarators bt (repeat True) dd) ctx einit' <- case einit of Just einit2 -> do (einit', inlinable) <- reduceCInitializer t einit2 ctx case inlinable of Just e' -> do modify' (addInlineExpr vid (IEInline e')) exceptIf ("inline variable " <> C.identToString vid, C.posOf ni) Nothing -> do exceptIf ("delete variable", C.posOf ni) pure (Just einit') Nothing -> do exceptIf ("delete uninitilized variable", C.posOf ni) pure Nothing modify' (addInlineExpr vid (IEKeep t)) let decl' = C.CDeclr mid dd' Nothing [] ni pure (C.CDeclarationItem decl' einit' Nothing) Nothing -> do exceptIf ("remove unnamed declaration item", C.posOf ni) pure di a -> notSupportedYet a C.undefNode reduceCInitializer :: (MonadReduce Lab m) => Type -> C.CInitializer C.NodeInfo -> Context -> m (C.CInitializer C.NodeInfo, Maybe C.CExpr) reduceCInitializer t einit ctx = case einit of C.CInitExpr e ni2 -> do e' <- fromMaybe (pure zeroExpr) $ reduceCExpr e (exactly t) ctx pure ( C.CInitExpr e' ni2 , case e' of C.CConst _ -> Just e' C.CVar _ _ -> Just e' _ow -> Nothing ) C.CInitList (C.CInitializerList items) ni2 -> do items' <- case t of TStruct stct -> do let i'' = catMaybes $ zipWith (\(_, t') i -> (i,) <$> t') (structTypeFields stct) items forM i'' \((p, r), t') -> do (r', _) <- reduceCInitializer t' r ctx pure (p, r') TPointer (NonVoid t') -> do forM items \(p, r) -> do (r', _) <- reduceCInitializer t' r ctx pure (p, r') _ow -> error $ "Unexpected type of init list" <> show t pure (C.CInitList (C.CInitializerList items') ni2, Nothing) reduceCCompoundBlockItem :: (MonadReduce Lab m, HasCallStack) => StmtContext -> C.CCompoundBlockItem C.NodeInfo -> StateT Context m [C.CCompoundBlockItem C.NodeInfo] reduceCCompoundBlockItem lab r = do case r of C.CBlockStmt smt -> do ctx <- get msmt <- runMaybeT $ reduceCStatement smt lab ctx case msmt of Just smt' -> do case smt' of C.CCompound [] ss _ -> whenSplit (all (\case C.CBlockStmt _ -> True; _ow -> False) ss) ("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 ctx <- get markDeleted items (keep, spec2) <- reduceStructDeclaration spec (bt, spec') <- updateCDeclarationSpecifiers keepAll spec2 -- Try to remove each declaration item items' <- collect (reduceCDeclarationItem bt) items -- 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) pure [C.CBlockDecl (C.CDecl spec' items' ni)] a -> notSupportedYet' a markDeleted :: (MonadState Context m) => [C.CDeclarationItem C.NodeInfo] -> m () markDeleted = mapM_ \case C.CDeclarationItem (name -> Just ix) _ _ -> do modify' (addInlineExpr ix IEDelete) _a -> pure () reduceCStatementOrEmptyBlock :: (MonadReduce Lab m, HasCallStack) => C.CStatement C.NodeInfo -> StmtContext -> Context -> m (C.CStatement C.NodeInfo) reduceCStatementOrEmptyBlock stmt ids ctx = do fromMaybe emptyBlock <$> runMaybeT ( wrapCCompound <$> reduceCStatement stmt ids ctx ) reduceCStatementOrEmptyExpr :: (MonadReduce Lab m, HasCallStack) => C.CStatement C.NodeInfo -> StmtContext -> Context -> m (C.CStatement C.NodeInfo) reduceCStatementOrEmptyExpr stmt ids ctx = do fromMaybe (C.CExpr Nothing C.undefNode) <$> runMaybeT (reduceCStatement stmt ids ctx) emptyBlock :: C.CStatement C.NodeInfo emptyBlock = C.CCompound [] [] C.undefNode data StmtContext = StmtContext { stmtLabels :: ![C.Ident] , stmtInLoop :: !Bool } deriving (Show, Eq) etAny :: EType etAny = EType ETAny False etNum :: EType etNum = EType (ETExactly TNum) False exactly :: Type -> EType exactly c = EType (ETExactly c) False -- | Reduce given a list of required labels reduce a c statement, possibly into nothingness. reduceCStatement :: forall m . (MonadReduce Lab m, HasCallStack) => C.CStatement C.NodeInfo -> StmtContext -> Context -> 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 pure (C.CCompound is (concat cbi') ni) C.CWhile e s dow ni -> split ("remove while loop", C.posOf ni) do reduceCStatement s labs ctx do s' <- reduceCStatement s labs{stmtInLoop = True} ctx e' <- fromMaybe (pure zeroExpr) (reduceCExpr e etNum ctx) pure $ C.CWhile e' s' dow ni C.CExpr me ni -> do case me of Just e -> do if DoNoops `isIn` ctx then do e' <- maybeSplit ("change to noop", C.posOf smt) $ reduceCExpr e etAny ctx pure $ C.CExpr e' ni else do re' <- liftMaybe $ reduceCExpr e etAny ctx exceptIf ("remove expr statement", C.posOf smt) e' <- re' pure $ C.CExpr (Just e') ni Nothing -> do exceptIf ("remove expr statement", C.posOf smt) pure $ C.CExpr Nothing ni C.CReturn me ni -> do re :: m (Maybe C.CExpr) <- case me of Just e -> do case returnType ctx of NonVoid rt -> do res :: (m C.CExpr) <- liftMaybe (reduceCExpr e (exactly rt) ctx) pure (Just <$> res) Void -> pure (pure Nothing) Nothing -> pure (pure Nothing) exceptIf ("remove return statement", C.posOf smt) e <- lift re pure $ C.CReturn e ni C.CIf e s els ni -> do e' <- maybeSplit ("remove condition", C.posOf e) $ reduceCExpr e etNum 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' C.CFor e1 e2 e3 s ni -> do case e1 of C.CForDecl (C.CDecl spec items ni') -> do (bt, spec') <- evalStateT (updateCDeclarationSpecifiers keepAll spec) ctx (items', ctx') <- runStateT (collect (reduceCDeclarationItem bt) items) ctx e2' <- runMaybeT do e2' <- liftMaybe e2 re2' <- liftMaybe (reduceCExpr e2' etAny ctx') exceptIf ("remove check", C.posOf e2') re2' e3' <- runMaybeT do e3' <- liftMaybe e3 re3' <- liftMaybe (reduceCExpr e3' etAny ctx') exceptIf ("remove iterator", C.posOf e3') re3' let e2'' = if AllowInfiniteForLoops `isIn` ctx || isNothing e2 then e2' else e2' <|> Just zeroExpr s' <- reduceCStatementOrEmptyExpr s labs{stmtInLoop = True} ctx' -- Todo allow removal of these loops as well pure $ C.CFor (C.CForDecl (C.CDecl spec' items' ni')) e2'' e3' s' ni C.CForInitializing e -> do split ("remove the for loop", C.posOf ni) do reduceCStatement s labs ctx do e' <- maybeSplit ("remove initializer", C.posOf ni) (e >>= \e' -> reduceCExpr e' etAny ctx) e2' <- runMaybeT do e2' <- liftMaybe e2 re2' <- liftMaybe (reduceCExpr e2' etNum ctx) exceptIf ("remove check", C.posOf e2') re2' e3' <- runMaybeT do e3' <- liftMaybe e3 re3' <- liftMaybe (reduceCExpr e3' etAny ctx) exceptIf ("remove iterator", C.posOf e3') re3' let e2'' = if AllowInfiniteForLoops `isIn` ctx || isNothing e2 then e2' else e2' <|> Just zeroExpr s' <- reduceCStatementOrEmptyExpr s labs{stmtInLoop = True} ctx pure $ C.CFor (C.CForInitializing e') e2'' e3' s' ni d -> notSupportedYet d ni C.CLabel i s [] ni -> do if i `List.elem` stmtLabels labs then do s' <- lift $ reduceCStatementOrEmptyExpr s labs ctx pure $ C.CLabel i s' [] ni else do empty C.CGoto i ni -> if i `List.elem` stmtLabels labs then do exceptIf ("remove goto", C.posOf smt) pure $ C.CGoto i ni else empty C.CBreak n -> if stmtInLoop labs then do exceptIf ("remove break", C.posOf smt) pure $ C.CBreak n else empty C.CCont n -> if stmtInLoop labs then do exceptIf ("remove continue", C.posOf smt) pure $ C.CCont n else empty a -> notSupportedYet' a -- | 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) -- Nothing -> do -- pure zeroExpr -- {-# INLINE reduceCExprOrZero #-} -- | The expected type data EType = EType { etSet :: !ETSet , etAssignable :: !Bool } deriving (Show, Eq) data ETSet = ETExactly !Type | ETStructWithField !C.Ident !ETSet | ETComparable | ETCastable !Type | ETPointer !ETSet | ETAny deriving (Show, Eq) checkExpectedType :: (MonadPlus m) => Voidable -> EType -> m () checkExpectedType (NonVoid t) et = guard $ isExpectedType t et checkExpectedType Void _ = pure () match :: Type -> Type -> Bool match = curry \case (TPointer Void, TPointer _) -> True (TPointer _, TPointer Void) -> True (TPointer (NonVoid a), TPointer (NonVoid b)) -> a `match` b (t1, t2) -> t1 == t2 isExpectedType :: Type -> EType -> Bool isExpectedType = \c et -> -- pTraceWith (\a -> "check " <> show a <> " " <> show c <> " " <> show et) $ go c (etSet et) where go c = \case ETExactly t -> t `match` c ETAny -> True ETStructWithField ix et -> case c of TStruct s -> fromMaybe False do let fields = structTypeFields s (_, mt) <- liftMaybe $ List.find (\(a, _) -> ix == a) fields t' <- liftMaybe mt pure $ go t' et _ow -> False ETComparable -> isNum c || isPointer c ETPointer t' -> case c of TPointer Void -> True TPointer (NonVoid c') -> go c' t' _ow -> False ETCastable TNum -> True a -> error (show a) etUnPointer :: EType -> Maybe EType etUnPointer t = -- pTraceWith (\t' -> "unpoint " <> show t <> " " <> show t') $ case etSet t of ETPointer t' -> Just t{etSet = t'} ETExactly (TPointer Void) -> Just t{etSet = ETAny} ETExactly (TPointer (NonVoid t')) -> Just t{etSet = ETExactly t'} ETComparable -> Just etAny _ow -> Nothing checkNotAssignable :: (MonadPlus m) => EType -> m () checkNotAssignable = guard . not . etAssignable msplit :: (MonadReduce Lab m) => Lab -> Maybe (m a) -> Maybe (m a) -> Maybe (m a) msplit l m1 m2 = do case m1 of Just a -> Just $ case m2 of Just b -> split l a b Nothing -> a Nothing -> m2 inferType :: Context -> C.CExpr -> Maybe Voidable inferType ctx = \case C.CVar i _ -> do case lookupVariable ctx i of IEInline e -> inferType ctx e IEKeep t -> pure (NonVoid t) IEDelete -> Nothing C.CUnary i e _ -> do t <- inferType ctx e case i of C.CIndOp -> case t of NonVoid (TPointer t') -> pure t' Void -> pure Void _ow -> Nothing C.CAdrOp -> pure (NonVoid (TPointer t)) _ow -> pure t C.CConst x -> pure . NonVoid $ case x of (C.CStrConst _ _) -> TPointer (NonVoid TNum) _ow -> TNum C.CIndex a x _ -> do t1 <- inferType ctx a t2 <- inferType ctx x case (t1, t2) of (NonVoid (TPointer x'), NonVoid TNum) -> pure x' _ow -> error (show ("index", t1, t2)) C.CMember a l t _ -> do t1 <- inferType ctx a s' <- case (t1, t) of (NonVoid (TPointer (NonVoid (TStruct s))), True) -> pure s (NonVoid (TStruct s), False) -> pure s _ow -> error (show ("member", a, l)) NonVoid <$> fieldLookup l s' C.CBinary o lhs _ _ -> do if o `elem` [C.CNeqOp, C.CEqOp, C.CGeqOp, C.CLeqOp, C.CGrOp, C.CLeOp] then pure (NonVoid TNum) else inferType ctx lhs C.CCast decl@(C.CDecl spec items _) _ _ -> do -- todo is this a good handling of this? (bt, _) <- evalStateT (updateCDeclarationSpecifiers keepAll spec) ctx case items of [C.CDeclarationItem (C.CDeclr Nothing dd Nothing [] _) _ _] -> do (t, _) <- evalStateT (updateCDerivedDeclarators bt (repeat True) dd) ctx pure t [] -> pure bt _ow -> notSupportedYet' decl C.CCall f _ ni -> do ft <- inferType ctx f case ft of NonVoid (TFun (FunType rt _)) -> pure rt a -> do error (show ("call", a, ni, pTraceWith show f)) C.CAssign _ lhs _ _ -> do inferType ctx lhs -- inferType ctx rhs -- if t1 == t2 then pure t1 else error (show ("assign", o, t1, t2)) C.CComma items _ -> do inferType ctx (List.last items) a -> notSupportedYet' a reduceCExpr :: forall m . (MonadReduce Lab m, HasCallStack) => C.CExpr -> EType -> Context -> Maybe (m C.CExpr) reduceCExpr expr t ctx = case expr of C.CBinary o elhs erhs ni -> do msplit ("reduce to left", C.posOf elhs) (reduceCExpr elhs t ctx) do msplit ("reduce to right", C.posOf erhs) (reduceCExpr erhs t ctx) do checkNotAssignable t when (o `elem` [C.CNeqOp, C.CEqOp, C.CGeqOp, C.CLeqOp, C.CGrOp, C.CLeOp]) do checkExpectedType (NonVoid TNum) t c <- inferType ctx elhs let t' = fromVoid etAny exactly c -- if -- then EType ETComparable False -- else exactly TNum -- in this case we change type, so we need to keep the operation rl <- reduceCExpr elhs t' ctx rr <- reduceCExpr erhs t' ctx Just do l' <- rl r' <- rr pure $ C.CBinary o l' r' ni C.CAssign o elhs erhs ni -> msplit ("reduce to left", C.posOf elhs) (reduceCExpr elhs t ctx) do msplit ("reduce to right", C.posOf erhs) (reduceCExpr erhs t ctx) do c <- inferType ctx elhs checkExpectedType c t let t' = fromVoid etAny exactly c -- in this case we change type, so we need to keep the operation rl <- reduceCExpr elhs t'{etAssignable = True} ctx rr <- reduceCExpr erhs t' ctx Just do l' <- rl r' <- rr pure $ C.CAssign o l' r' ni C.CVar i _ -> case lookupVariable ctx i of IEKeep c -> do checkExpectedType (NonVoid c) t Just (pure expr) IEInline mx' -> do guard (not $ DisallowVariableInlining `isIn` ctx) reduceCExpr mx' t ctx IEDelete -> Nothing C.CConst x -> do case x of C.CStrConst _ _ -> do checkNotAssignable t checkExpectedType (NonVoid (TPointer (NonVoid TNum))) t -- guard ( `match` etSet t) Just (pure expr) C.CIntConst (C.getCInteger -> 0) _ -> do checkNotAssignable t checkExpectedType (NonVoid (TPointer Void)) t <|> checkExpectedType (NonVoid TNum) t Just (pure expr) _ow -> do checkNotAssignable t checkExpectedType (NonVoid TNum) t Just (pure expr) C.CUnary o eopr ni -> do msplit ("reduce to operant", C.posOf eopr) (reduceCExpr eopr t ctx) do case o of C.CIndOp -> do ropr <- reduceCExpr eopr (t{etSet = ETPointer (etSet t), etAssignable = True}) ctx Just do eopr' <- ropr pure $ C.CUnary o eopr' ni C.CAdrOp -> do t' <- etUnPointer t -- pTraceShowM (t', void eopr) ropr <- reduceCExpr eopr (t'{etAssignable = True}) ctx Just do eopr' <- ropr pure $ C.CUnary o eopr' ni e | e `List.elem` [C.CPreIncOp, C.CPreDecOp, C.CPostIncOp, C.CPostDecOp] -> do reduceCExpr eopr t{etAssignable = True} ctx <&> \ropr -> do eopr' <- ropr pure $ C.CUnary o eopr' ni | otherwise -> do reduceCExpr eopr t ctx <&> \ropr -> do eopr' <- ropr pure $ C.CUnary o eopr' ni C.CCall ef args ni -> do (\fn a -> foldr fn a args) (\e -> msplit ("reduce to expression", C.posOf e) (reduceCExpr e t ctx)) do ct <- inferType ctx ef case ct of NonVoid ft@(TFun (FunType _ fargs)) -> do checkNotAssignable t -- unless (etSet t == ETAny) do -- rt <- fromVoid mzero pure mrt -- guard (rt `match` etSet t) -- TODO (should be function?) ref <- reduceCExpr ef (exactly ft) ctx let targs = case fargs of Params targs' v -> let cons = if v then repeat (Just ETAny) else [] in map (fmap ETExactly) targs' <> cons VoidParams -> repeat (Just ETAny) let pargs = mapMaybe (\(ta, a) -> (,a) <$> ta) (zip targs args) rargs <- forM pargs \(ta, a) -> reduceCExpr a (EType ta False) ctx Just do ef' <- ref args' <- sequence rargs pure $ C.CCall ef' args' ni ow -> do error $ "Original c code does not type-check: exepected function, got " <> show ow <> " at " <> show (C.posOf ef) C.CCond et (Just ec) ef ni -> do msplit ("reduce to true branch", C.posOf et) (reduceCExpr et t ctx) do msplit ("reduce to false branch", C.posOf ef) (reduceCExpr ef t ctx) do msplit ("reduce to condtion", C.posOf ef) (reduceCExpr ec t ctx) do checkNotAssignable t ret <- reduceCExpr et t ctx ref <- reduceCExpr ef t ctx rec <- reduceCExpr ec etAny ctx Just $ do et' <- ret ef' <- ref ec' <- rec pure $ C.CCond et' (Just ec') ef' ni C.CCast (C.CDecl spec items ni2) e ni -> do msplit ("do not cast", C.posOf ni) (reduceCExpr e t ctx) do (bt, spec') <- evalStateT (updateCDeclarationSpecifiers keepAll spec) ctx (items', re) <- case items of [C.CDeclarationItem (C.CDeclr Nothing dd Nothing [] a) b c] -> do (_, dd') <- evalStateT (updateCDerivedDeclarators bt (repeat True) dd) ctx ([C.CDeclarationItem (C.CDeclr Nothing dd' Nothing [] a) b c],) <$> do reduceCExpr e etAny ctx [] -> ([],) <$> case bt of Void -> reduceCExpr e etAny ctx NonVoid _ -> do -- checkExpectedType ct' t reduceCExpr e etAny ctx a -> notSupportedYet a ni Just do e' <- re pure (C.CCast (C.CDecl spec' items' ni2) e' ni) C.CIndex e1 e2 ni -> do msplit ("reduce to indexee", C.posOf e1) (reduceCExpr e1 t ctx) do msplit ("reduce to index", C.posOf e2) (reduceCExpr e2 t ctx) do re1 <- reduceCExpr e1 t{etSet = ETPointer (etSet t)} ctx Just do e1' <- re1 e2' <- fromMaybe (pure zeroExpr) $ reduceCExpr e2 etNum ctx pure $ C.CIndex e1' e2' ni C.CComma items ni -> do (x, rst) <- List.uncons (reverse items) (\fn a -> foldr fn a (reverse items)) (\e -> msplit ("reduce to expression", C.posOf e) (reduceCExpr e t ctx)) do rx <- reduceCExpr x t ctx Just do rst' <- flip collect rst \e -> do re <- liftMaybe (reduceCExpr e (EType ETAny False) ctx) e' <- re exceptIf ("remove expression", C.posOf e) pure (e' :: C.CExpr) x' <- rx pure $ C.CComma (reverse (x' : rst')) ni C.CMember e i l ni -> do re <- reduceCExpr e t{etSet = ETStructWithField i (etSet t)} ctx Just do e' <- re pure (C.CMember e' i l ni) a -> notSupportedYet' 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 -> notSupportedYet' a -- where -- shouldDeleteDeclItem = \case -- C.CDeclarationItem a _ _ -> shouldDeleteDeclartor a -- a -> notSupportedYet a decl -- -- 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 -> notSupportedYet' 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 -- Just (_, Just _) -> False -- Just (_, Nothing) -> True -- Nothing -> error ("could not find struct:" <> show idx) -- C.CTypeSpec (C.CSUType (C.CStruct _ _ (Just c) _ _) _) -> -- any (shouldDeleteDeclaration ctx) c -- _ow -> False lookupFunction :: (HasCallStack) => Context -> C.Ident -> Maybe Function lookupFunction ctx k = fromMaybe (error ("could not find function " <> C.identToString k)) $ functions ctx Map.!? k lookupVariable :: (HasCallStack) => Context -> C.Ident -> InlineExpr lookupVariable ctx k = fromMaybe (error ("could not find variable " <> C.identToString k)) $ inlineExprs ctx Map.!? k lookupStruct :: (HasCallStack) => Context -> C.Ident -> Maybe StructType 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 -> [] -- applyDerivedDeclarators :: [C.CDerivedDeclarator C.NodeInfo] -> Maybe CType -> Maybe CType -- applyDerivedDeclarators [] ct = ct -- applyDerivedDeclarators _ _ = Just (CTPointer undefined) -- -- \| Returns nothing if void is used -- functionParameters -- :: Context -- -> [C.CDerivedDeclarator C.NodeInfo] -- -> Maybe FunctionParams -- functionParameters ctx = \case -- (C.CFunDeclr (C.CFunParamsNew x b) _ _) : rst -> -- case x of -- [C.CDecl [C.CTypeSpec (C.CVoidType _)] _ _] -> -- Just VoidParams -- params -> -- Just (Params (fmap (Just . snd) . map (functionParameter ctx) $ params) b) -- _ow -> Nothing data Context = Context { keywords :: !(Set.Set Keyword) , typeDefs :: !(Map.Map C.Ident InlineType) , inlineExprs :: !(Map.Map C.Ident InlineExpr) , structs :: !(Map.Map C.Ident (Maybe StructType)) , functions :: !(Map.Map C.Ident (Maybe Function)) , returnType :: !Voidable } deriving (Show) data InlineType = ITKeep !Type | ITInline !Type ![C.CDeclarationSpecifier C.NodeInfo] | ITDelete deriving (Show, Eq) data InlineExpr = IEDelete | IEInline !C.CExpr | IEKeep !Type deriving (Show, Eq) data Keyword = LoseMain | DoNoops | ComputeFunctionFixpoint | InlineTypeDefs | NoSemantics | AllowEmptyDeclarations | DisallowVariableInlining | AllowInfiniteForLoops deriving (Show, Read, Enum, Eq, Ord) type Lab = (String, C.Position) addTypeDef :: C.Ident -> InlineType -> Context -> Context addTypeDef i cs ctx = ctx{typeDefs = Map.insert i cs $ typeDefs ctx} addInlineExpr :: C.Ident -> InlineExpr -> Context -> Context addInlineExpr i e Context{..} = Context{inlineExprs = Map.insert i e inlineExprs, ..} addStruct :: C.Identifier C.NodeInfo -> Maybe StructType -> Context -> Context addStruct i cs ctx = ctx{structs = Map.insert i cs $ structs ctx} defaultContext :: Context defaultContext = Context { keywords = Set.fromList [] , typeDefs = Map.empty , inlineExprs = Map.fromList [ (C.builtinIdent "__PRETTY_FUNCTION__", IEKeep (TPointer (NonVoid TNum))) , (C.builtinIdent "__FUNCTION__", IEKeep (TPointer (NonVoid TNum))) ] , structs = Map.empty , functions = Map.empty , returnType = Void } 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] , structPosition :: !C.Position } deriving (Show, Eq) findStructs :: forall m . (Monoid m) => (Struct -> m) -> C.CExternalDeclaration C.NodeInfo -> m findStructs inject = \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 _ mid mfields _attr ni) = fromMaybe mempty do fields <- mfields let fields' = Just <$> concatMap structField fields sid <- mid pure $ inject (Struct sid fields' (C.posOf ni)) structField = \case C.CDecl _ items _ -> map (\(C.CDeclarationItem decl _ _) -> fromMaybe (error "all struct fields should be named") (name decl)) items a@(C.CStaticAssert{}) -> notSupportedYet' a -- 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' 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 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 [Bool]) , funIsStatic :: !Bool , funSize :: !Int , funPosition :: !C.Position } deriving (Show, Eq) findFunctions :: (Monoid m) => (Function -> m) -> C.CExternalDeclaration C.NodeInfo -> m findFunctions inject = \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 decl@(C.CDeclr mid (C.CFunDeclr param _ _ : _) Nothing [] _) -> case mid of Just funName -> inject Function{..} where funIsStatic = isStaticFromSpecs spec funSize = fromMaybe 0 (C.lengthOfNode ni) funPosition = C.posOf ni funParams = case param of C.CFunParamsNew declr var -> case declr of [C.CDecl [C.CTypeSpec (C.CVoidType _)] [] _] -> Nothing _ | var -> Nothing | otherwise -> Just [True | _ <- declr] a -> notSupportedYet (void a) ni Nothing -> mempty _ow -> mempty -- nonVoidTypeOfFromContext -- :: (HasCallStack) => Context -> [C.CDeclarationSpecifier C.NodeInfo] -> C.CDeclarator C.NodeInfo -> Type -- nonVoidTypeOfFromContext ctx spec decl = -- fromVoid (notSupportedYet' decl) id $ -- typeOf -- (\t -> fst <$> Map.lookup t (structs ctx)) -- (\t -> fst <$> Map.lookup t (typeDefs ctx)) -- spec -- decl -- nonVoidExtendType -- :: (HasCallStack, MonadState Context m, MonadPlus m) -- => C.CDeclarator C.NodeInfo -- -> Voidable -- -> m Type -- nonVoidExtendType decl bt = do -- ctx <- get -- pure $ -- fromVoid (notSupportedYet' decl) id $ -- extendTypeWith -- (\t -> fst <$> Map.lookup t (structs ctx)) -- (\t -> case Map.lookup t (typeDefs ctx) of -- Nothing -> error ("could not find " <> show t) -- Just (ITKeep ) -- decl -- bt 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 -- filterParams -- :: Context -- -> [Maybe Type] -- -> [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 -- t' <- state (\(t : tps) -> (t, tps)) -- case t' of -- Just t -- | not (shouldDeleteDeclaration ctx decl) -> do -- let defs = [(idx', IEKeep t) | i <- items, idx' <- maybeToList (name i)] -- pure ([C.CDecl def items l], defs) -- _ow -> do -- let defs = [(idx', IEDelete) | i <- items, idx' <- maybeToList (name i)] -- pure ([], defs) -- a' -> notSupportedYet' a' -- pure (concat params', concat mapping) -- -- filterStorageModifiers :: Bool -> [C.CDeclarationSpecifier C.NodeInfo] -> [C.CDeclarationSpecifier C.NodeInfo] -- filterStorageModifiers isStatic = filter \case -- C.CStorageSpec (C.CStatic _) -> isStatic -- C.CFunSpec (C.CInlineQual _) -> isStatic -- _ow -> True