Newer
Older
[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
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
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
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
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 -> Maybe StructType
fromMaybe (error ("could not find struct " <> C.identToString k)) $
structs ctx Map.!? k
labelsOf :: C.CStatement C.NodeInfo -> [C.Ident]
labelsOf = \case
C.CLabel i s [] _ -> i : labelsOf s
C.CWhile _ s _ _ -> labelsOf s
C.CCase _ s _ -> labelsOf s
C.CDefault s _ -> labelsOf s
C.CCompound _ ss _ ->
ss & concatMap \case
C.CBlockStmt s -> labelsOf s
_ow -> []
C.CCases _ _ s _ -> labelsOf s
C.CIf _ l r _ -> labelsOf l <> maybe [] labelsOf r
C.CSwitch _ s _ -> labelsOf s
C.CFor _ _ _ s _ -> labelsOf s
_ow -> []
, structs :: !(Map.Map C.Ident (Maybe StructType))
= ITKeep !Voidable
| ITInline !Voidable ![C.CDeclarationSpecifier C.NodeInfo]
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 -> Maybe StructType -> Context -> Context
addStruct i cs ctx = ctx{structs = Map.insert i cs $ structs ctx}
defaultContext :: Context
defaultContext =
Context
{ keywords = Set.fromList []
, typeDefs = Map.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
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
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 :: !(Maybe [(C.Ident, Maybe Type)])
}
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