Newer
Older
_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?
(bt, _) <- evalStateT (updateCDeclarationSpecifiers keepAll spec) ctx
case items of
[C.CDeclarationItem (C.CDeclr Nothing dd Nothing [] _) _ _] -> do
(t, _) <- evalStateT (updateCDerivedDeclarators bt (repeat True) dd) ctx
pure t
[] ->
pure bt
_ow -> notSupportedYet' decl
C.CCall f _ ni -> do
ft <- inferType ctx f
case ft of
NonVoid (TFun (FunType rt _)) -> pure rt
a -> do
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
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
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 ("reduce to left", C.posOf elhs) (reduceCExpr elhs t ctx) do
msplit ("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
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 ("reduce to operant", C.posOf eopr) (reduceCExpr eopr t ctx) do
case o of
C.CIndOp -> do
ropr <- reduceCExpr eopr (t{etSet = ETPointer (etSet t), etAssignable = True}) ctx
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
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
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
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
et' <- ret
ef' <- ref
ec' <- rec
pure $ C.CCond et' (Just ec') ef' ni
msplit ("do not cast", C.posOf ni) (reduceCExpr e t ctx) do
(bt, spec') <- evalStateT (updateCDeclarationSpecifiers keepAll spec) ctx
(items', re) <- case items of
[C.CDeclarationItem (C.CDeclr Nothing dd Nothing [] a) b c] -> do
(_, dd') <- evalStateT (updateCDerivedDeclarators bt (repeat True) dd) ctx
([C.CDeclarationItem (C.CDeclr Nothing dd' Nothing [] a) b c],) <$> do
[] ->
([],) <$> case bt of
Void ->
reduceCExpr e etAny ctx
NonVoid _ -> do
-- checkExpectedType ct' t
reduceCExpr e etAny ctx
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
(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
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
| InlineTypeDefs
| NoSemantics
| AllowEmptyDeclarations
| DisallowVariableInlining
| AllowInfiniteForLoops
deriving (Show, Read, Enum, Eq, Ord)
type Lab = (String, C.Position)
addTypeDef :: C.Ident -> InlineType -> Context -> Context
addTypeDef i cs ctx = ctx{typeDefs = Map.insert i cs $ typeDefs ctx}
addInlineExpr :: C.Ident -> InlineExpr -> Context -> Context
addInlineExpr i e Context{..} =
Context{inlineExprs = Map.insert i e inlineExprs, ..}
addStruct :: C.Identifier C.NodeInfo -> 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)
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
}
deriving (Show, Eq)
data Type
= TNum
| TStruct !(Either C.Ident StructType)
| TPointer !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