Select Git revision
chrg authored
Code owners
Assign users and groups as approvers for specific file changes. Learn more.
ReduceC.hs 53.28 KiB
{-# 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 Control.Applicative (Alternative (empty, (<|>)))
import Control.Monad (
MonadPlus (mzero),
foldM,
forM,
guard,
join,
mapAndUnzipM,
unless,
void,
when,
)
import qualified Control.Monad.IRTree as IRTree
import Control.Monad.Reduce (
MonadReduce (split),
check,
collect,
exceptIf,
liftMaybe,
)
import Control.Monad.State (
MonadState (get, state),
MonadTrans (lift),
State,
StateT (runStateT),
evalState,
evalStateT,
gets,
modify',
runState,
)
import Control.Monad.Trans.Maybe (MaybeT (runMaybeT))
import Data.Foldable
import Data.Function ((&))
import Data.Functor (($>), (<&>))
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map.Strict as Map
import Data.Maybe (
catMaybes,
fromMaybe,
isJust, isNothing,
mapMaybe,
)
import Data.Monoid
import qualified Data.Set as Set
import Data.Vector.Internal.Check (HasCallStack)
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
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
if C.identToString (funName f) /= "main" || LoseMain `isIn` ctx
then do
params <- case funParams f of
Just params -> do
Just <$> forM (zip [1 :: Int ..] params) \(i, p) ->
if p
then split ("remove parameter " <> show i <> " from " <> C.identToString (funName f), funPosition f) (pure False) (pure True)
else pure False
ow -> pure ow
pure f{funParams = params} else do
pure f
let builtins =
[ ("fabsf", FunType (NonVoid TNum) (Params [Just TNum] False))
, ("fabs", FunType (NonVoid TNum) (Params [Just TNum] False))
, ("__builtin_abort", FunType Void (Params [] 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 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
newtype 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. Also return a base type.
-}
updateCDeclarationSpecifiers ::
forall m.
( MonadReduce Lab m
, HasCallStack
) =>
SpecifierFilter ->
Context ->
[C.CDeclarationSpecifier C.NodeInfo] ->
Maybe (m (Voidable, [C.CDeclarationSpecifier C.NodeInfo]))
updateCDeclarationSpecifiers sf ctx spec = do
bt <- typeFromCDeclarationSpecifiers ctx spec
specfn <- mapM updateSpec spec
Just do
spec' <- sequence specfn
pure (bt, concat spec')
where
updateSpec ::
C.CDeclarationSpecifier C.NodeInfo ->
Maybe (m [C.CDeclarationSpecifier C.NodeInfo])
updateSpec a = case a of
C.CTypeSpec t -> case t of C.CSUType (C.CStruct st (Just i) (Just declrs) attr x) b -> do
fields <- case lookupStruct ctx i of
ISDelete -> empty
ISDeclared _ -> empty
ISKeep s -> do
pure $ structTypeFields s
Just do
declrs' <- filterStruct 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 _) -> Just $ pure [C.CTypeSpec t]
Just (ITInline _ res) -> Just $ pure res
Just ITDelete -> Nothing
Nothing -> error ("could not find typedef: " <> show idx)
_ow -> Just $ pure [C.CTypeSpec t]
C.CStorageSpec (C.CStatic _) -> Just $ pure [a | sfKeepStatic sf]
C.CFunSpec (C.CInlineQual _) -> Just $ pure [a | sfKeepStatic sf]
_ow -> Just $ pure [a]
filterStruct ::
[(a1, Maybe a2)] ->
[C.CDeclaration C.NodeInfo] ->
m [C.CDeclaration C.NodeInfo]
filterStruct fields declrs =
flip evalStateT fields do
declrs' <- forM declrs $ \case
C.CDecl spec2 items l -> runMaybeT do
items' <- forM items $ \case
C.CDeclarationItem (C.CDeclr mid dd sl attr ni2) enit ni1 -> runMaybeT do
_ <- liftMaybe =<< state (\((_, t) : tps) -> (t, tps))
(_, dd') <- evalStateT (updateCDerivedDeclarators Void (repeat True) dd) ctx
pure (C.CDeclarationItem (C.CDeclr mid dd' sl attr ni2) enit ni1)
a' -> notSupportedYet a' l
(_, spec2') <- joinLiftMaybe (updateCDeclarationSpecifiers keepAll ctx spec2)
let items'' = catMaybes items'
guard $ not (List.null items'')
pure (C.CDecl spec2' items'' l)
a' -> notSupportedYet' a'
pure $ catMaybes declrs'
typeFromCDeclarationSpecifiers ::
forall m.
( MonadPlus m
, HasCallStack
) =>
Context ->
[C.CDeclarationSpecifier C.NodeInfo] ->
m Voidable
typeFromCDeclarationSpecifiers ctx =
liftMaybe
. exactlyOne
. map \case
C.CVoidType _ -> Just Void
C.CSUType c _ -> NonVoid . TStruct <$> structId c
C.CCharType _ -> Just $ NonVoid TNum
C.CShortType _ -> Just $ NonVoid TNum
C.CIntType _ -> Just $ NonVoid TNum
C.CFloatType _ -> Just $ NonVoid TNum
C.CDoubleType _ -> Just $ NonVoid TNum
C.CSignedType _ -> Just $ NonVoid TNum
C.CUnsigType _ -> Just $ NonVoid TNum
C.CBoolType _ -> Just $ NonVoid TNum
C.CLongType _ -> Just $ NonVoid TNum
C.CInt128Type _ -> Just $ NonVoid TNum
C.CFloatNType{} -> Just $ NonVoid TNum
C.CEnumType (C.CEnum (Just ix) _ _ _) _ ->
NonVoid TNum
<$ guard (lookupEnum ctx ix == INKeep)
C.CEnumType (C.CEnum Nothing _ _ _) _ -> Just $ NonVoid TNum C.CTypeDef idx _ ->
case Map.lookup idx (typeDefs ctx) of
Just (ITKeep t') -> Just t'
Just ITDelete -> Nothing
Just (ITInline t' _) -> Just t'
Nothing -> error "error"
a -> notSupportedYet (void a) a
. typeSpecs
where
typeSpecs = mapMaybe \case
C.CTypeSpec ts -> Just ts
_ow -> Nothing
exactlyOne =
maybe
(error "no type in type-specs")
( \case
(t, []) -> NonEmpty.head t
(t, rs) -> error ("more than one type in type-specs: " <> show (t : rs))
)
. List.uncons
. NonEmpty.group
structId (C.CStruct t mi md _ ni) =
case mi of
Just ix -> case lookupStruct ctx ix of
ISDelete -> Nothing
_ow -> Just $ Left ix
Nothing ->
let p' =
maybe
(error $ "invalid struct at" <> show (C.posOf ni))
(concatMap namesAndTypeOf)
md
in pure $ Right (StructType t Nothing p')
namesAndTypeOf = \case
C.CDecl spec2 items ni ->
flip map items \case
C.CDeclarationItem decl@(C.CDeclr (Just ix) _ _ _ _) _ _ ->
(ix, nonVoid <$> typeOf spec2 decl)
a -> notSupportedYet (void a) ni
a -> notSupportedYet' a
typeOf spec2 decl = typeFromCDeclarationSpecifiers ctx spec2 >>= extendTypeWith decl
extendTypeWith (C.CDeclr _ dd _ _ _) t =
foldr applyDD (Just t) dd
where
applyDD = \case
C.CPtrDeclr _ _ -> fmap (NonVoid . TPointer)
C.CArrDeclr{} -> fmap (NonVoid . TPointer)
C.CFunDeclr params _ ni -> \c ->
case params of
C.CFunParamsNew params' varadic -> do
c' <- c
Just $ NonVoid $ TFun (FunType c' (findParams varadic params'))
b -> notSupportedYet b ni
findParams varadic = \case
[C.CDecl [C.CTypeSpec (C.CVoidType _)] [] _] -> VoidParams
rst -> flip Params varadic $ flip map rst \case
C.CDecl spec' [] _ ->
nonVoid <$> typeFromCDeclarationSpecifiers ctx spec'
C.CDecl spec' [C.CDeclarationItem decl _ _] _ ->
nonVoid <$> typeOf spec' decl
a -> notSupportedYet' a
typeFromCDerivedDeclarators ::
forall m. ( MonadPlus m
) =>
Voidable ->
Context ->
[C.CDerivedDeclarator C.NodeInfo] ->
m Voidable
typeFromCDerivedDeclarators bt ctx dd =
foldM applyDD bt (reverse dd)
where
applyDD ::
(r ~ Voidable) =>
r ->
C.CDerivedDeclarator C.NodeInfo ->
m r
applyDD t d = case d of
C.CPtrDeclr _ _ -> do
pure (NonVoid . TPointer $ t)
C.CArrDeclr{} -> do
pure (NonVoid . TPointer $ t)
C.CFunDeclr params _ ni -> do
case params of
C.CFunParamsNew params' varadic -> do
tp <- findParams varadic params'
let t' = NonVoid $ TFun (FunType t tp)
pure t'
b -> notSupportedYet b ni
findParams ::
Bool ->
[C.CDeclaration C.NodeInfo] ->
m Params
findParams varadic decls = case decls of
[C.CDecl [C.CTypeSpec (C.CVoidType _)] [] _] ->
pure VoidParams
_ow -> do
result <-
forM decls $ \case
C.CDecl spec items ni -> do
bt' <- typeFromCDeclarationSpecifiers ctx spec
case items of
[] -> do
pure $ nonVoid bt'
[C.CDeclarationItem (C.CDeclr _ dd2 Nothing [] _) Nothing _] -> do
(nonVoid -> t) <- typeFromCDerivedDeclarators bt' ctx dd2
pure t
_ow -> notSupportedYet items ni
a -> notSupportedYet' a
pure (Params (map Just result) varadic)
updateCDerivedDeclarators ::
forall m.
( MonadState Context m
, MonadReduce (String, C.Position) 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 r as ni -> do d' <- case as of
C.CArrSize _ _ -> do
-- b <- check ("remove array size", C.posOf ni)
let b = False
pure $ if b then C.CArrDeclr r (C.CNoArrSize False) ni else d
_ -> pure d
pure (NonVoid . TPointer $ t, d' : dd')
C.CFunDeclr params arr ni -> do
case params of
C.CFunParamsNew params' varadic -> do
(tp, params'') <- 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] ->
m (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
markDeleted items
ctx <- get
(bt', spec') <- join (liftMaybe $ updateCDeclarationSpecifiers keepAll ctx 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
(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 (ts, decls') = unzip $ flip map result \case
Just (t, d') -> (Just t, [d'])
Nothing -> (Nothing, [])
pure (Params ts varadic, concat decls')
joinLiftMaybe :: (MonadPlus m) => Maybe (m a) -> m a
joinLiftMaybe = join . liftMaybe
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
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
-- TODO handle this edgecase (struct declared in function declaration)
_ <- reduceStructDeclaration spec
ctx' <- get
(bt, spec') <- joinLiftMaybe $ updateCDeclarationSpecifiers keepAll{sfKeepStatic = keepStatic} ctx' spec
((t', dd'), ctx'') <- runStateT (updateCDerivedDeclarators bt (fromMaybe (repeat True) (mfun >>= funParams)) dd) ctx'
let t@(TFun (FunType rt _)) = nonVoid t'
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
(ix, dd, wrap) <- case item of
C.CDeclarationItem (C.CDeclr (Just ix) dd Nothing extras _) Nothing Nothing ->
case extras of
[] -> pure (ix, dd, id)
[C.CAttr (C.Ident "__vector_size__" _ _) [a] _] -> do
case a of
C.CBinary C.CMulOp (C.CConst (C.CIntConst (C.CInteger n _ _) _)) (C.CSizeofType _ _) _ ->
-- todo assuming this is a checked size
pure
( ix
, dd
, NonVoid . TVector (fromInteger n)
)
_ -> notSupportedYet a ni
a -> notSupportedYet (map void a) ni
i -> notSupportedYet (void i) ni
modify' (addTypeDef ix ITDelete)
keep <- reduceStructDeclaration rst
ctx <- get
(bt, rst') <- joinLiftMaybe $ updateCDeclarationSpecifiers keepAll ctx rst
(t, _) <- updateCDerivedDeclarators bt (repeat True) dd
unless keep do
modify' (addTypeDef ix (ITInline (wrap t) rst'))
exceptIf ("inline typedef " <> C.identToString ix, C.posOf ni)
modify' (addTypeDef ix (ITKeep (wrap 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 forceStatic =
getAny <$> flip foldMap items \case
(C.CDeclarationItem (C.CDeclr (Just fid) (C.CFunDeclr{} : _) _ _ _) _ _) -> do
Any . funIsStatic <$> lookupFunction ctx fid
_ow -> Nothing
keep <- reduceStructDeclaration spec
isStatic <- case forceStatic of
Just t -> pure t
Nothing ->
if any isStaticSpec spec
then not <$> check ("make declaration non-static", C.posOf ni)
else return False
ctx' <- get
(bt, spec') <- joinLiftMaybe $ updateCDeclarationSpecifiers keepAll{sfKeepStatic = isStatic} ctx' spec
-- Try to remove each declaration item
items' <-
flip collect items \case
di@(C.CDeclarationItem (C.CDeclr mid dd Nothing [] ni2) einit size) -> do
case dd of
C.CFunDeclr{} : _ -> 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') <-
updateCDerivedDeclarators bt ff dd
case mid of
Just fid -> do
modify' (addInlineExpr fid IEDelete)
exceptIf ("remove function declaration", C.posOf ni2)
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 True 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' || List.null items)
exceptIf ("remove declaration", C.posOf ni)
pure $ C.CDeclExt $ C.CDecl spec' items' ni
_r -> notSupportedYet' r
isStaticSpec :: C.CDeclarationSpecifier C.NodeInfo -> Bool
isStaticSpec = \case
C.CStorageSpec (C.CStatic _) -> True
_ -> False
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
reduceStructDeclaration =
fmap or . mapM \case
C.CTypeSpec (C.CEnumType (C.CEnum mid mf _ _) ni) -> do
case mid of
Just eid -> do
case mf of
Just times -> forM_ times \(C.CEnumVar ix _) -> do
modify' (addInlineExpr ix IEDelete)
Nothing -> pure ()
modify' (addEnum eid INDelete)
exceptIf ("delete enum " <> C.identToString eid, C.posOf ni)
modify' (addEnum eid INKeep)
case mf of
Just times -> forM_ times \(C.CEnumVar ix _) -> do
modify' (addInlineExpr ix (IEKeep TNum))
Nothing -> pure ()
pure True
Nothing -> do
pure False
C.CTypeSpec (C.CSUType (C.CStruct tag mid mfields _ _) ni) -> case mid of
Just sid -> do
struct <- gets (Map.lookup sid . structs)
let reduce fields = do
exceptIf ("remove struct " <> C.identToString sid, C.posOf ni)
modify' (addStruct sid (ISDeclared tag))
(ft, _) <- mapAndUnzipM (structField sid) fields
modify' (addStruct sid (ISKeep (StructType tag (Just sid) (concat ft))))
pure True
case struct of
Just (ISDeclared _) ->
case mfields of
Just fields -> reduce fields
Nothing -> pure False
Just (ISKeep _) -> do
pure False
Just ISDelete -> do
case mfields of
Just fields -> reduce fields
Nothing -> pure True
Nothing -> do
modify' (addStruct sid ISDelete)
case mfields of
Just fields -> reduce fields
Nothing -> do
exceptIf ("remove struct declaration " <> C.identToString sid, C.posOf ni)
modify' (addStruct sid (ISDeclared tag))
pure True
Nothing -> pure False
_ow -> pure False
where
structField sid = \case
C.CDecl spec items ni -> do
ctx <- get
case updateCDeclarationSpecifiers keepAll ctx spec of
Just fn -> do
(bt, spec') <- fn
(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 ->
Bool ->
C.CDeclarationItem C.NodeInfo ->
m (C.CDeclarationItem C.NodeInfo)
reduceCDeclarationItem bt nullable = \case
di@(C.CDeclarationItem (C.CDeclr mid dd Nothing [] ni) einit Nothing) -> do
case mid of
Just vid -> do
(nonVoid -> t, dd') <- updateCDerivedDeclarators bt (repeat True) dd
einit' <- case einit of
Just einit2 -> do
ctx <- get
einit' <-
whenSplit
nullable
("remove initialization", C.posOf ni)
(pure Nothing)
(Just <$> reduceCInitializer t einit2 ctx)
case getInlinable (fromMaybe einit2 einit') 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 einit'
Nothing -> do
exceptIf ("delete uninitilized variable", C.posOf ni)
initialize <- gets (InitializeVariables `isIn`)
whenSplit
(t == TNum && initialize)
("initilize variable", C.posOf ni)
(pure . Just $ C.CInitExpr zeroExpr C.undefNode)
(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
getInlinable :: C.CInitializer C.NodeInfo -> Maybe C.CExpr
getInlinable = \case
C.CInitExpr e _ -> case e of
C.CConst _ -> Just e
C.CVar _ _ -> Just e
_ -> Nothing
C.CInitList _ _ -> Nothing
reduceCInitializer ::
(MonadReduce Lab m) =>
Type ->
C.CInitializer C.NodeInfo ->
Context ->
m (C.CInitializer C.NodeInfo)
reduceCInitializer t einit ctx = case einit of
C.CInitExpr e ni2 -> do
let me = reduceCExpr e (exactly t) ctx
case (me, t) of
(Just es, _) -> do
e' <- es
pure $ C.CInitExpr e' ni2
(Nothing, TVector n _) -> do
let items' = [([], C.CInitExpr zeroExpr ni2) | _ <- replicate n ()]
pure $ C.CInitList (C.CInitializerList items') ni2
(Nothing, _) -> do
let e' = zeroExpr
pure $ C.CInitExpr e' ni2
C.CInitList (C.CInitializerList items) ni2 -> do
items' <- case t of
TStruct stct -> do
let fields = fieldsOfStruct ctx stct
let i'' = catMaybes $ zipWith (\(_, t') i -> (i,) <$> t') fields 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 ->
-- "Unexpected type of init list: " <> show t <> " at " <> show (C.posOf ni2)
pure items
pure $ C.CInitList (C.CInitializerList items') ni2
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 <- reduceStructDeclaration spec
(bt, spec') <- joinLiftMaybe $ updateCDeclarationSpecifiers keepAll ctx spec
-- Try to remove each declaration item
items' <- collect (reduceCDeclarationItem bt False) items
-- Somtimes we just declare a struct or a typedef.
when (not keep && List.null items') do guard (AllowEmptyDeclarations `isIn` ctx || List.null items)
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
exceptIf ("remove else branch", C.posOf e)
reduceCStatement els' labs ctx
ms' <- lift . runMaybeT $ do
exceptIf ("remove if branch", C.posOf e)
reduceCStatement s labs ctx
case (e', ms', els') of
(Nothing, Nothing, Nothing) -> empty
(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 -> case e1 of
C.CForDecl d@(C.CDecl spec items ni') -> split
("remove the for loop", C.posOf ni)
(reduceCStatement (C.CCompound [] [C.CBlockDecl d, C.CBlockStmt s] C.undefNode) labs ctx)
do
(bt, spec') <- joinLiftMaybe $ updateCDeclarationSpecifiers keepAll ctx spec
(items', ctx') <- flip runStateT ctx do
markDeleted items
collect (reduceCDeclarationItem bt False) items
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'
pure $ C.CFor (C.CForDecl (C.CDecl spec' items' ni')) e2'' e3' s' ni
C.CForInitializing e -> split
("remove the for loop", C.posOf ni)
( reduceCStatement
( C.CCompound
[]
[C.CBlockStmt (C.CExpr e C.undefNode), C.CBlockStmt s]
C.undefNode
)
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)
-- | The expected type
data EType = EType
{ etSet :: !ETSet
, etAssignable :: !Bool
}
deriving (Show, Eq)
data ETSet
= ETExactly !Type
| ETStructWithField !C.Ident !ETSet
| ETPointer !ETSet
| ETAny
deriving (Show, Eq)
checkExpectedType :: (MonadPlus m) => Context -> Voidable -> EType -> m ()
checkExpectedType ctx (NonVoid t) et = guard $ isExpectedType ctx 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 :: Context -> Type -> EType -> Bool
isExpectedType ctx = \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 = fieldsOfStruct ctx s
(_, mt) <- liftMaybe $ List.find (\(a, _) -> ix == a) fields
t' <- liftMaybe mt
pure $ go t' et
_ow -> False
ETPointer t' ->
case c of
TPointer Void -> True
TPointer (NonVoid c') -> go c' t'
TVector _ Void -> True
TVector _ (NonVoid c') -> go c' t'
_ow -> False
fieldsOfStruct :: (HasCallStack) => Context -> Either C.Ident StructType -> [(C.Ident, Maybe Type)]
fieldsOfStruct ctx (Left ix) =
case lookupStruct ctx ix of
ISKeep a -> structTypeFields a
_ow -> error "Something bad happend"
fieldsOfStruct _ (Right a) = structTypeFields a
etUnPointer :: EType -> Maybe EType
etUnPointer t =
-- pTraceWith (\t' -> "unpoint " <> show t <> " " <> show t') $
case etSet t of
ETAny -> Just t 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
{-# INLINE msplit #-}
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'
(NonVoid (TVector _ 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))
let fields = fieldsOfStruct ctx s'
NonVoid <$> (join . List.lookup l $ fields)
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 <- typeFromCDeclarationSpecifiers ctx spec
case items of
[C.CDeclarationItem (C.CDeclr Nothing dd Nothing [] _) _ _] -> do
typeFromCDerivedDeclarators bt ctx dd
[] ->
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))
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 ctx (NonVoid TNum) t
c <- inferType ctx elhs
let t' = fromVoid etAny exactly c
rl <- reduceCExpr elhs t' ctx
rr <- reduceCExpr erhs t' ctx
Just do
l' <- rl
r' <- rr
let r'' = case o of
C.CDivOp -> case r' of
C.CConst (C.CIntConst i _)
| i == C.cInteger 0 ->
C.CConst (C.CIntConst (C.cInteger 1) C.undefNode)
C.CUnary o' (C.CConst (C.CIntConst i _)) _
| i == C.cInteger 0 ->
C.CUnary o' (C.CConst (C.CIntConst (C.cInteger 1) C.undefNode)) C.undefNode
_ow -> r'
_ow -> r'
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 ctx 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 _ -> do
case lookupVariable ctx i of
IEKeep c -> do
-- case i of
-- (C.Ident "test1char8" _ _) -> error (show (i, c))
-- _ -> pure ()
checkExpectedType ctx (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 ctx (NonVoid (TPointer (NonVoid TNum))) t
-- guard ( `match` etSet t)
Just (pure expr)
C.CIntConst (C.getCInteger -> 0) _ -> do
checkNotAssignable t
checkExpectedType ctx (NonVoid (TPointer Void)) t
<|> checkExpectedType ctx (NonVoid TNum) t
Just (pure expr)
_ow -> do
checkNotAssignable t
checkExpectedType ctx (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 <- case etSet t of
ETAny -> reduceCExpr eopr t ctx
_ -> 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 rt fargs)) -> do
checkNotAssignable t
checkExpectedType ctx rt t
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
fn <- updateCDeclarationSpecifiers keepAll ctx spec
hole <- case items of
[C.CDeclarationItem (C.CDeclr Nothing dd Nothing [] a) b c] -> do
e' <- reduceCExpr e etAny ctx
Just do
(bt, spec') <- fn
(_, dd') <- evalStateT (updateCDerivedDeclarators bt (repeat True) dd) ctx
ee' <- e'
pure (spec', [C.CDeclarationItem (C.CDeclr Nothing dd' Nothing [] a) b c], ee')
[] -> do
e' <- reduceCExpr e etAny ctx
Just do
(_, spec') <- fn
ee' <- e'
pure (spec', [], ee')
a -> notSupportedYet a ni
Just do
(spec', items', e') <- hole
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), etAssignable = True} 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
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 -> InlineStruct
lookupStruct ctx k =
fromMaybe (error ("could not find struct " <> C.identToString k)) $
structs ctx Map.!? k
lookupEnum :: (HasCallStack) => Context -> C.Ident -> InlineEnum
lookupEnum ctx k =
fromMaybe (error ("could not find enum " <> C.identToString k)) $
enums 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 -> []
data Context = Context
{ keywords :: !(Set.Set Keyword)
, typeDefs :: !(Map.Map C.Ident InlineType)
, inlineExprs :: !(Map.Map C.Ident InlineExpr)
, structs :: !(Map.Map C.Ident InlineStruct)
, enums :: !(Map.Map C.Ident InlineEnum)
, functions :: !(Map.Map C.Ident (Maybe Function))
, returnType :: !Voidable
}
deriving (Show)
data InlineType
= ITKeep !Voidable
| ITInline !Voidable ![C.CDeclarationSpecifier C.NodeInfo]
| ITDelete
deriving (Show, Eq)
data InlineStruct
= ISKeep !StructType
| ISDeclared !C.CStructTag
| ISDelete
deriving (Show, Eq)
data InlineEnum
= INKeep
| INDelete
deriving (Show, Eq)
data InlineExpr
= IEKeep !Type
| IEInline !C.CExpr
| IEDelete
deriving (Show, Eq)
data Keyword
= LoseMain
| DoNoops
| ComputeFunctionFixpoint
| InlineTypeDefs
| InitializeVariables
| 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 -> InlineStruct -> Context -> Context
addStruct i cs ctx = ctx{structs = Map.insert i cs $ structs ctx}
addEnum :: C.Identifier C.NodeInfo -> InlineEnum -> Context -> Context
addEnum i cs ctx = ctx{enums = Map.insert i cs $ enums ctx}
defaultContext :: Context
defaultContext =
Context
{ keywords = Set.fromList []
, typeDefs = Map.fromList [(C.builtinIdent "__builtin_va_list", ITKeep (NonVoid (TPointer Void)))]
, inlineExprs =
Map.fromList
[ (C.builtinIdent "__PRETTY_FUNCTION__", IEKeep (TPointer (NonVoid TNum)))
, (C.builtinIdent "__FUNCTION__", IEKeep (TPointer (NonVoid TNum)))
]
, structs = Map.empty
, enums = 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)
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
(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
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
data Params
= VoidParams
| Params ![Maybe Type] !Bool
deriving (Show, Eq)
data FunType = FunType
{ funTypeReturn :: !Voidable
, funTypeParams :: !Params
}
deriving (Show, Eq)
data StructType = StructType
{ structTypeTag :: !C.CStructTag
, structTypeName :: !(Maybe C.Ident)
, structTypeFields :: ![(C.Ident, Maybe Type)]
}
deriving (Show, Eq)
data Type
= TNum
| TStruct !(Either C.Ident StructType)
| TPointer !Voidable
| TVector !Int !Voidable
| TFun !FunType
deriving (Show, Eq)
data Voidable
= Void
| NonVoid !Type
deriving (Show, Eq)
fromVoid :: a -> (Type -> a) -> Voidable -> a
fromVoid a fn = \case
Void -> a NonVoid t -> fn t
{-# INLINE fromVoid #-}
nonVoid :: (HasCallStack) => Voidable -> Type
nonVoid = fromVoid (error "expected non void type") id
{-# INLINE nonVoid #-}
notSupportedYet :: (HasCallStack, Show a, C.Pos n) => a -> n -> b
notSupportedYet a ni = error (show a <> " at " <> show (C.posOf ni))
notSupportedYet' :: (HasCallStack, Show (a ()), Functor a, C.Pos (a C.NodeInfo)) => a C.NodeInfo -> b
notSupportedYet' a = notSupportedYet (void a) a