{-# LANGUAGE BlockArguments #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# 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.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 qualified Language.C as C import qualified Language.C.Data.Ident as C import qualified Language.C.Data.Node as C 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 (_functions, _structs) <- flip evalState ctx do (fs, sts) <- flip mapAndUnzipM es \e -> do includeTypeDef e funcs <- gets \ctx' -> findFunctions (: []) ctx' e structs <- state \ctx' -> let ss = findStructs (: []) ctx' e in ( ss , ctx' { structs = foldr ( \s -> Map.insert (structName s) (structType s, Nothing) ) (structs ctx') ss } ) pure (funcs, structs) pure (pure (concat fs, concat sts)) 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 let FunType rtype rparams = funType f params <- case rparams of Params params False -> do params' <- forM params \p -> runMaybeT do p' <- liftMaybe p exceptIf ("remove parameter", funPosition f) pure p' pure (Params params' False) ow -> pure ow pure f{funType = FunType rtype params} let functions''' = Map.fromList $ functions3 <> [ ( funName , Just $ Function { funIsStatic = False , funPosition = C.posOf funName , funSize = 0 , .. } ) | (C.builtinIdent -> funName, funReturns, funParams) <- [ ("fabsf", NonVoid TNum, Params [Just TNum] False) , ("fabs", NonVoid TNum, Params [Just TNum] False) ] , let funType = FunType funReturns funParams ] 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) pure s modify' (Map.insert (structName s) (structType s, ms)) let ctx' = ctx{functions = functions''', structs = structs'} res' <- evalStateT (mapM reduceCExternalDeclaration es) ctx' pure $ C.CTranslUnit (catMaybes res') ni 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 let (C.CFunDeclr (C.CFunParamsNew params b) attr ni3 : dd') = dd (FunType rtype pFilter, spec') <- case mid of Just fid -> do modify' (addInlineExpr fid IEDelete) guard (not $ any (shouldDeleteDeclSpec ctx) spec) f <- liftMaybe (lookupFunction ctx fid) modify' (addInlineExpr fid (IEKeep (TFun $ funType f))) pure (funType f, filterStorageModifiers (funIsStatic f) spec) Nothing -> do let TFun ft = nonVoidTypeOfFromContext ctx spec declr exceptIf ("remove function", C.posOf r) pure (ft, spec) let (params', idents) = case pFilter of Params flt False -> filterParams ctx flt params _ow -> (params, []) 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} $ (foldr (uncurry addInlineExpr) ctx idents){returnType = rtype} let dd'' = C.CFunDeclr (C.CFunParamsNew params' b) attr ni3 : dd' pure . C.CFDefExt $ C.CFunDef (inlineTypeDefsSpecs spec' ctx) (inlineTypeDefsCDeclarator (C.CDeclr mid dd'' Nothing [] ni2) ctx) [] stmt' ni -- Type definitions C.CDeclExt d@(C.CDecl (C.CStorageSpec (C.CTypedef _) : rst) [item] ni) -> runMaybeT do let C.CDeclarationItem decl@(C.CDeclr (Just ix) [] Nothing [] _) Nothing Nothing = item ctx <- get let t = nonVoidTypeOfFromContext ctx rst decl modify' (addTypeDef ix (t, ITInline rst)) exceptIf ("inline typedef" <> C.identToString ix, C.posOf ni) modify' (addTypeDef ix (t, ITKeep)) -- TODO delete typedefs gets (C.CDeclExt <$> inlineTypeDefsCDeclaration d) -- The rest. C.CDeclExt (C.CDecl spec items ni) -> runMaybeT do ctx <- get lift $ includeTypeDef r let keep = containsStructDeclaration ctx spec -- Try to remove each declaration item (items', or -> isStatic) <- unzip <$> 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', isStatic) <- case mid of Just fid -> do modify' (addInlineExpr fid IEDelete) f <- liftMaybe (lookupFunction ctx fid) modify' (addInlineExpr fid (IEKeep (TFun $ funType f))) params' <- case funTypeParams (funType f) of Params flt False -> do case params of C.CFunParamsNew params' b -> do let res = filterParams ctx flt params' pure . flip C.CFunParamsNew b . fst $ res C.CFunParamsOld _ -> notSupportedYet (void di) ni2 _ow -> pure params pure (C.CFunDeclr params' attr ni3 : rst, funIsStatic f) Nothing -> do exceptIf ("remove function", C.posOf ni2) pure (dd, isStaticFromSpecs spec) pure (C.CDeclarationItem (C.CDeclr mid dd' Nothing [] ni2) einit size, isStatic) _dd -> do di' <- reduceCDeclarationItem spec di pure (di', isStaticFromSpecs spec) 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 (filterStorageModifiers isStatic spec) items' ni)) pure (C.CDeclExt decl') _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 reduceCDeclarationItem :: ( MonadReduce Lab m , MonadState Context m , MonadPlus m ) => [C.CDeclarationSpecifier C.NodeInfo] -> C.CDeclarationItem C.NodeInfo -> m (C.CDeclarationItem C.NodeInfo) reduceCDeclarationItem spec = \case di@(C.CDeclarationItem decl@(C.CDeclr mid _ Nothing [] ni) einit Nothing) -> do ctx <- get case mid of Just vid -> do modify' (addInlineExpr vid IEDelete) let t = nonVoidTypeOfFromContext ctx spec decl guard (not $ any (shouldDeleteDeclSpec ctx) spec) einit' <- case einit of Just (C.CInitExpr e ni2) -> do e' <- fromMaybe (pure zeroExpr) $ reduceCExpr e (exactly t) ctx let inlinable = case e' of C.CConst _ -> True C.CVar _ _ -> True _ow -> False when inlinable do modify' (addInlineExpr vid (IEInline e')) exceptIf ("inline variable " <> C.identToString vid, C.posOf ni) modify' (addInlineExpr vid (IEKeep t)) pure (Just (C.CInitExpr e' ni2)) -- TODO handle later Just (C.CInitList i ni2) -> do exceptIf ("delete variable", C.posOf ni) modify' (addInlineExpr vid (IEKeep t)) pure (Just (C.CInitList i ni2)) Nothing -> do exceptIf ("delete uninitialized variable", C.posOf vid) modify' (addInlineExpr vid (IEKeep t)) pure Nothing pure (C.CDeclarationItem decl einit' Nothing) Nothing -> do guard (not $ any (shouldDeleteDeclSpec ctx) spec) exceptIf ("remove unnamed declaration item", C.posOf ni) pure di a -> notSupportedYet a C.undefNode 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 let keep = containsStructDeclaration ctx spec -- Try to remove each declaration item items' <- collect (reduceCDeclarationItem spec) 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) decl' <- gets (inlineTypeDefsCDeclaration (C.CDecl spec items' ni)) pure [C.CBlockDecl decl'] a -> notSupportedYet' a 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 let spec' = inlineTypeDefsSpecs spec ctx (items', ctx') <- runStateT (collect (reduceCDeclarationItem spec) 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) => Type -> EType -> m () checkExpectedType t et = guard $ isExpectedType t et isExpectedType :: Type -> EType -> Bool isExpectedType = \c et -> -- pTraceShowWith (\a -> ("check", a, c, et, a)) $ go c (etSet et) where go c = \case ETExactly t -> t == 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 = -- pTraceShowWith (\t' -> ("unpoint", t, 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'} _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 ctypeOf :: Context -> C.CExpr -> Maybe Type ctypeOf ctx = \case C.CVar i _ -> do f <- lookupFunction ctx i pure $ TFun (funType f) 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 let t' = if o `elem` [C.CNeqOp, C.CEqOp, C.CGeqOp, C.CLeqOp, C.CGrOp, C.CLeOp] 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 checkNotAssignable t let t' = if o == C.CAssignOp then etSet t else ETExactly TNum -- in this case we change type, so we need to keep the operation rl <- reduceCExpr elhs (EType t' True) ctx rr <- reduceCExpr erhs (EType t' False) 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 c t Just (pure expr) IEInline mx' -> do guard (DisallowVariableInlining `isIn` ctx || not (etAssignable t)) Just (pure mx') IEDelete -> Nothing C.CConst x -> do case x of C.CStrConst _ _ -> do checkNotAssignable t -- guard (TPointer (NonVoid TNum) `match` etSet t) Just (pure expr) _ow -> do checkNotAssignable t -- guard (TNum `match` etSet 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 checkNotAssignable t ropr <- reduceCExpr eopr (EType{etSet = ETPointer (etSet t), etAssignable = False}) 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 <- ctypeOf ctx ef case ct of 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 decl@(C.CDecl spec items _) e ni -> do msplit ("do not cast", C.posOf ni) (reduceCExpr e t ctx) do re <- case items of [C.CDeclarationItem dec _ _] -> do -- let ct = nonVoidTypeOfFromContext ctx spec dec reduceCExpr e etAny ctx [] -> case baseTypeOfFromContext ctx spec of Void -> reduceCExpr e etAny ctx NonVoid ct' -> do -- checkExpectedType ct' t reduceCExpr e etAny ctx a -> notSupportedYet a ni Just do e' <- re pure (C.CCast (inlineTypeDefsCDeclaration decl ctx) 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 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 -- 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 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 -> 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 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 Struct lookupStruct ctx k = maybe (error ("could not find struct " <> C.identToString k)) snd $ 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 structField :: Context -> C.CDeclaration C.NodeInfo -> [(C.Ident, Type)] structField ctx = \case C.CDecl spec items _ -> map ( \(C.CDeclarationItem decl _ _) -> (fromJust (name decl), nonVoidTypeOfFromContext ctx spec decl) ) items a@(C.CStaticAssert{}) -> notSupportedYet' a data Context = Context { keywords :: !(Set.Set Keyword) , typeDefs :: !(Map.Map C.Ident (Type, InlineType)) , inlineExprs :: !(Map.Map C.Ident InlineExpr) , structs :: !(Map.Map C.Ident (StructType, Maybe Struct)) , functions :: !(Map.Map C.Ident (Maybe Function)) , returnType :: !Voidable } deriving (Show) data InlineType = ITKeep | ITInline ![C.CDeclarationSpecifier C.NodeInfo] 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 -> (Type, 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, ..} 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 , structType :: !StructType , 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 (structField ctx) fields sid <- mid pure $ inject (Struct sid (StructType tag mid fields') (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' 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 , funType :: !FunType , 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 decl@(C.CDeclr mid _ Nothing [] _) -> case nonVoidTypeOfFromContext ctx spec decl of TFun funType -> case mid of Just funName -> inject Function{..} where funIsStatic = isStaticFromSpecs spec funSize = fromMaybe 0 (C.lengthOfNode ni) funPosition = C.posOf ni Nothing -> mempty _ow -> 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 baseTypeOfFromContext :: (HasCallStack) => Context -> [C.CDeclarationSpecifier C.NodeInfo] -> Voidable baseTypeOfFromContext ctx spec = baseTypeOf (\t -> fst <$> Map.lookup t (structs ctx)) (\t -> fst <$> Map.lookup t (typeDefs ctx)) spec 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) items _) -> do let [C.CDeclarationItem decl _ _] = items modify' ( \ctx -> addTypeDef (fromMaybe (error "expected typedef to have a name") $ name decl) (nonVoidTypeOfFromContext ctx rst decl, ITInline rst) ctx ) _ow -> pure () containsStructDeclaration :: Context -> [C.CDeclarationSpecifier C.NodeInfo] -> Bool containsStructDeclaration ctx = any \case -- Is a struct definition C.CTypeSpec (C.CSUType (C.CStruct _ mid (Just _) _ _) _) -> case mid of Just sid -> do -- Delete if struct is deleted. case lookupStruct ctx sid of Just _ -> True Nothing -> False Nothing -> False _ow -> False 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