Newer
Older
s' <- reduceCStatementOrEmptyExpr s labs{stmtInLoop = True} ctx'
pure $ C.CFor (C.CForDecl (C.CDecl spec' items' ni')) e2'' e3' s' ni
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
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
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
-- | 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
ETAny -> True
ETStructWithField ix et -> case c of
TStruct s -> fromMaybe False do
(_, 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'
fieldsOfStruct :: (HasCallStack) => Context -> Either C.Ident StructType -> [(C.Ident, Maybe Type)]
fieldsOfStruct ctx (Left ix) =
case lookupStruct ctx ix of
ISKeep a -> structTypeFields a
etUnPointer :: EType -> Maybe EType
etUnPointer t =
-- pTraceWith (\t' -> "unpoint " <> show t <> " " <> show 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) => Context -> Lab -> Maybe (m a) -> Maybe (m a) -> Maybe (m a)
msplit ctx l m1 m2
| DontRepairExpressions `isIn` ctx = do
b <- m2
Just $ case m1 of
Just a -> split l a b
Nothing -> b
| otherwise = 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
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
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))
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?
case items of
[C.CDeclarationItem (C.CDeclr Nothing dd Nothing [] _) _ _] -> do
[] ->
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
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)
reduceCExpr ::
forall m.
(MonadReduce Lab m, HasCallStack) =>
C.CExpr ->
EType ->
Context ->
Maybe (m C.CExpr)
msplit ctx ("reduce to left", C.posOf elhs) (reduceCExpr elhs t ctx) do
msplit ctx ("reduce to right", C.posOf erhs) (reduceCExpr erhs t ctx) do
when (o `elem` [C.CNeqOp, C.CEqOp, C.CGeqOp, C.CLeqOp, C.CGrOp, C.CLeOp]) do
c <- inferType ctx elhs
let t' = fromVoid etAny exactly c
rl <- reduceCExpr elhs t' ctx
rr <- reduceCExpr erhs t' ctx
Just do
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
msplit ctx ("reduce to left", C.posOf elhs) (reduceCExpr elhs t ctx) do
msplit ctx ("reduce to right", C.posOf erhs) (reduceCExpr erhs t ctx) do
-- 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
case lookupVariable ctx i of
IEKeep c -> do
-- case i of
-- (C.Ident "test1char8" _ _) -> error (show (i, c))
-- _ -> pure ()
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
-- 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
Just (pure expr)
C.CUnary o eopr ni -> do
msplit ctx ("reduce to operant", C.posOf eopr) (reduceCExpr eopr t ctx) 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
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
C.CCall ef args ni -> orHoistSubExpression 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)
where
orHoistSubExpression a =
foldr (\e -> msplit ctx ("reduce to expression", C.posOf e) (reduceCExpr e t ctx)) a args
msplit ctx ("reduce to true branch", C.posOf et) (reduceCExpr et t ctx) do
msplit ctx ("reduce to false branch", C.posOf ef) (reduceCExpr ef t ctx) do
msplit ctx ("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
et' <- ret
ef' <- ref
ec' <- rec
pure $ C.CCond et' (Just ec') ef' ni
msplit ctx ("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')
msplit ctx ("reduce to indexee", C.posOf e1) (reduceCExpr e1 t ctx) do
msplit ctx ("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
(x, rst) <- List.uncons (reverse items)
(\fn a -> foldr fn a (reverse items))
(\e -> msplit ctx ("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
re <- reduceCExpr e t{etSet = ETStructWithField i (etSet t)} ctx
Just do
e' <- re
pure (C.CMember e' i l ni)
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
fromMaybe (error ("could not find struct " <> C.identToString 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 -> []
, structs :: !(Map.Map C.Ident InlineStruct)
, enums :: !(Map.Map C.Ident InlineEnum)
= ITKeep !Voidable
| ITInline !Voidable ![C.CDeclarationSpecifier C.NodeInfo]
data InlineStruct
= ISKeep !StructType
| ISDeclared !C.CStructTag
| ISDelete
deriving (Show, Eq)
data InlineEnum
= INKeep
| INDelete
deriving (Show, Eq)
deriving (Show, Eq)
data Keyword
= LoseMain
| DoNoops
| 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)))]
[ (C.builtinIdent "__PRETTY_FUNCTION__", IEKeep (TPointer (NonVoid TNum)))
, (C.builtinIdent "__FUNCTION__", IEKeep (TPointer (NonVoid TNum)))
}
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
, structPosition :: !C.Position
}
deriving (Show, Eq)
data Function = Function
{ funName :: !C.Ident
, funIsStatic :: !Bool
, funSize :: !Int
, funPosition :: !C.Position
}
deriving (Show, Eq)
findFunctions ::
(Monoid m) =>
(Function -> m) ->
C.CExternalDeclaration C.NodeInfo ->
m
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
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
| 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)
}
deriving (Show, Eq)
data Type
= TNum
| TStruct !(Either C.Ident StructType)
| TPointer !Voidable
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
| 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