Semiworking version

rtree-c/.hspec

 --failure-report .hspec-failures
---fail-fast

rtree-c/bench/Main.hs

@@ -17,11 +17,12 @@ main = do
         let r = defaultReduceC c
          in bgroup
               "clang-26760"
-              [ bench "extract" $ nf IRTree.extract r
-              , bench "probe 11" $ nf (\r -> let (i, _, _) = IRTree.probe r "11" in i) r
-              , bench "reduce true" $
+              [ bench "reduce" $
                   nfAppIO
-                    (IRTree.reduceAdaptive (\_ i -> i `deepseq` pure True))
+                    ( do
+                        deepseq (IRTree.extract r) (pure True)
+                        IRTree.reduceAdaptive (\_ i -> i `deepseq` pure True)
+                    )
                     r
               ]
     ]

rtree-c/rtree-c.cabal

@@ -10,7 +10,6 @@ build-type:     Simple
 
 library
   exposed-modules:
-      CType
       ReduceC
   other-modules:
       Paths_rtree_c

rtree-c/src/CType.hs

-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE LambdaCase #-}
-
--- | A module for typing of c expressions.
-module CType where
-
-import Control.Monad
-import Data.Function
-import qualified Data.List as List
-import qualified Data.List.NonEmpty as NonEmpty
-import Data.Maybe
-import GHC.Stack
-import Language.C (Pos (posOf))
-import qualified Language.C as C
-
-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)
-
-fieldLookup :: C.Ident -> StructType -> Maybe Type
-fieldLookup i = join . List.lookup i . structTypeFields
-
-data Type
-  = TNum
-  | TStruct !StructType
-  | TPointer !Voidable
-  | TFun !FunType
-  deriving (Show, Eq)
-
-isNum, isStruct, isPointer, isFun :: Type -> Bool
-isNum = \case TNum -> True; _ow -> False
-isStruct = \case TStruct _ -> True; _ow -> False
-isPointer = \case TPointer _ -> True; _ow -> False
-isFun = \case TFun _ -> True; _ow -> False
-
-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 #-}
-
-type TypeDefLookup = (C.Ident -> Maybe Type)
-type StructLookup = (C.Ident -> Maybe StructType)
-
-typeOf
-  :: (HasCallStack)
-  => StructLookup
-  -> TypeDefLookup
-  -> [C.CDeclarationSpecifier C.NodeInfo]
-  -> C.CDeclarator C.NodeInfo
-  -> Maybe Voidable
-typeOf structLookup typeDefLookup spec decl =
-  baseTypeOf structLookup typeDefLookup spec
-    >>= extendTypeWith
-      structLookup
-      typeDefLookup
-      decl
-
-extendTypeWith
-  :: (HasCallStack)
-  => StructLookup
-  -> TypeDefLookup
-  -> C.CDeclarator C.NodeInfo
-  -> Voidable
-  -> Maybe Voidable
-extendTypeWith structLookup typeDefLookup (C.CDeclr _ dd _ _ _) t =
-  foldr applyDD (Just t) dd
- where
-  applyDD :: C.CDerivedDeclarator C.NodeInfo -> Maybe Voidable -> Maybe Voidable
-  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 :: Bool -> [C.CDeclaration C.NodeInfo] -> Params
-  findParams varadic = \case
-    [C.CDecl [C.CTypeSpec (C.CVoidType _)] [] _] -> VoidParams
-    rst -> flip Params varadic $ flip map rst \case
-      C.CDecl spec' [] _ ->
-        nonVoid <$> baseTypeOf structLookup typeDefLookup spec'
-      C.CDecl spec' [C.CDeclarationItem decl _ _] _ ->
-        nonVoid <$> typeOf structLookup typeDefLookup spec' decl
-      a -> notSupportedYet' a
-
-typeSpecs :: [C.CDeclarationSpecifier a] -> [C.CTypeSpecifier a]
-typeSpecs = mapMaybe \case
-  C.CTypeSpec ts -> Just ts
-  _ow -> Nothing
-
-baseTypeOf
-  :: (HasCallStack)
-  => StructLookup
-  -> TypeDefLookup
-  -> [C.CDeclarationSpecifier C.NodeInfo]
-  -> Maybe Voidable
-baseTypeOf structLookup typeDefLookup =
-  fmap
-    ( 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
-    )
-    . mapM \case
-      C.CVoidType _ -> Just Void
-      C.CSUType c _ -> NonVoid . TStruct <$> structTypeOf structLookup typeDefLookup 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 _ _ -> Just $ NonVoid TNum
-      C.CTypeDef idx _ -> NonVoid <$> typeDefLookup idx
-      a -> notSupportedYet (void a) a
-    . typeSpecs
-
-structTypeOf
-  :: (HasCallStack)
-  => StructLookup
-  -> TypeDefLookup
-  -> C.CStructureUnion C.NodeInfo
-  -> Maybe StructType
-structTypeOf structLookup typeDefLookup (C.CStruct t mi md _ ni) =
-  case mi of
-    Just ix -> structLookup ix
-    Nothing ->
-      let p' =
-            maybe
-              (error $ "invalid struct at" <> show (C.posOf ni))
-              (concatMap (namesAndTypeOf structLookup typeDefLookup))
-              md
-       in Just $
-            StructType
-              { structTypeTag = t
-              , structTypeName = mi
-              , structTypeFields = p'
-              }
-
-namesAndTypeOf
-  :: (HasCallStack)
-  => StructLookup
-  -> TypeDefLookup
-  -> C.CDeclaration C.NodeInfo
-  -> [(C.Ident, Maybe Type)]
-namesAndTypeOf structLookup typeDefLookup = \case
-  C.CDecl spec items ni ->
-    flip map items \case
-      C.CDeclarationItem decl@(C.CDeclr (Just ix) _ _ _ _) _ _ ->
-        (ix, nonVoid <$> typeOf structLookup typeDefLookup spec decl)
-      a -> notSupportedYet (void a) ni
-  a -> notSupportedYet' a
-
-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

rtree-c/test/cases/small/fparam.c

+struct S0 {} b = {};
+void f(int b, struct S0 a) {
+}
+int main () { 
+  f(0, b);
+}

rtree-c/test/cases/small/selfstruct.c

+struct X;
+struct X { 
+  struct X *x;
+};
+
+int main() {}

rtree-c/test/cases/small/struct2.c

+struct qube { int w; short h; float d;};
+struct qube qube = { 1, 2, 3};
+int main () {
+}

rtree-c/test/expected/add/reduction/r000000.c

 // 0 remove function add (25) at ("test/cases/small/add.c": line 1)
-// 0 remove parameter at ("test/cases/small/add.c": line 1)
-// 0 remove parameter at ("test/cases/small/add.c": line 1)
+// 0 remove parameter 1 from add at ("test/cases/small/add.c": line 1)
+// 0 remove parameter 2 from add at ("test/cases/small/add.c": line 1)
 // 0 remove return statement at ("test/cases/small/add.c": line 5)
 // 0 reduce to expression at ("test/cases/small/add.c": line 5)
 // 0 reduce to expression at ("test/cases/small/add.c": line 5)

rtree-c/test/expected/add/reduction/r000001.c

 // 0 remove function add (25) at ("test/cases/small/add.c": line 1)
-// 0 remove parameter at ("test/cases/small/add.c": line 1)
-// 0 remove parameter at ("test/cases/small/add.c": line 1)
+// 0 remove parameter 1 from add at ("test/cases/small/add.c": line 1)
+// 0 remove parameter 2 from add at ("test/cases/small/add.c": line 1)
 // 0 remove return statement at ("test/cases/small/add.c": line 5)
 // 0 reduce to expression at ("test/cases/small/add.c": line 5)
 // 1 reduce to expression at ("test/cases/small/add.c": line 5)

rtree-c/test/expected/add/reduction/r00001.c

 // 0 remove function add (25) at ("test/cases/small/add.c": line 1)
-// 0 remove parameter at ("test/cases/small/add.c": line 1)
-// 0 remove parameter at ("test/cases/small/add.c": line 1)
+// 0 remove parameter 1 from add at ("test/cases/small/add.c": line 1)
+// 0 remove parameter 2 from add at ("test/cases/small/add.c": line 1)
 // 0 remove return statement at ("test/cases/small/add.c": line 5)
 // 1 reduce to expression at ("test/cases/small/add.c": line 5)
 

rtree-c/test/expected/add/reduction/r0001.c

 // 0 remove function add (25) at ("test/cases/small/add.c": line 1)
-// 0 remove parameter at ("test/cases/small/add.c": line 1)
-// 0 remove parameter at ("test/cases/small/add.c": line 1)
+// 0 remove parameter 1 from add at ("test/cases/small/add.c": line 1)
+// 0 remove parameter 2 from add at ("test/cases/small/add.c": line 1)
 // 1 remove return statement at ("test/cases/small/add.c": line 5)
 
 int add(int a, int b)

rtree-c/test/expected/add/reduction/r001000.c

 // 0 remove function add (25) at ("test/cases/small/add.c": line 1)
-// 0 remove parameter at ("test/cases/small/add.c": line 1)
-// 1 remove parameter at ("test/cases/small/add.c": line 1)
+// 0 remove parameter 1 from add at ("test/cases/small/add.c": line 1)
+// 1 remove parameter 2 from add at ("test/cases/small/add.c": line 1)
 // 0 remove return statement at ("test/cases/small/add.c": line 5)
 // 0 reduce to expression at ("test/cases/small/add.c": line 5)
 // 0 reduce to expression at ("test/cases/small/add.c": line 5)

rtree-c/test/expected/add/reduction/r001001.c

 // 0 remove function add (25) at ("test/cases/small/add.c": line 1)
-// 0 remove parameter at ("test/cases/small/add.c": line 1)
-// 1 remove parameter at ("test/cases/small/add.c": line 1)
+// 0 remove parameter 1 from add at ("test/cases/small/add.c": line 1)
+// 1 remove parameter 2 from add at ("test/cases/small/add.c": line 1)
 // 0 remove return statement at ("test/cases/small/add.c": line 5)
 // 0 reduce to expression at ("test/cases/small/add.c": line 5)
 // 1 reduce to expression at ("test/cases/small/add.c": line 5)

rtree-c/test/expected/add/reduction/r00101.c

 // 0 remove function add (25) at ("test/cases/small/add.c": line 1)
-// 0 remove parameter at ("test/cases/small/add.c": line 1)
-// 1 remove parameter at ("test/cases/small/add.c": line 1)
+// 0 remove parameter 1 from add at ("test/cases/small/add.c": line 1)
+// 1 remove parameter 2 from add at ("test/cases/small/add.c": line 1)
 // 0 remove return statement at ("test/cases/small/add.c": line 5)
 // 1 reduce to expression at ("test/cases/small/add.c": line 5)
 

rtree-c/test/expected/add/reduction/r0011.c

 // 0 remove function add (25) at ("test/cases/small/add.c": line 1)
-// 0 remove parameter at ("test/cases/small/add.c": line 1)
-// 1 remove parameter at ("test/cases/small/add.c": line 1)
+// 0 remove parameter 1 from add at ("test/cases/small/add.c": line 1)
+// 1 remove parameter 2 from add at ("test/cases/small/add.c": line 1)
 // 1 remove return statement at ("test/cases/small/add.c": line 5)
 
 int add(int a)

rtree-c/test/expected/add/reduction/r010000.c

 // 0 remove function add (25) at ("test/cases/small/add.c": line 1)
-// 1 remove parameter at ("test/cases/small/add.c": line 1)
-// 0 remove parameter at ("test/cases/small/add.c": line 1)
+// 1 remove parameter 1 from add at ("test/cases/small/add.c": line 1)
+// 0 remove parameter 2 from add at ("test/cases/small/add.c": line 1)
 // 0 remove return statement at ("test/cases/small/add.c": line 5)
 // 0 reduce to expression at ("test/cases/small/add.c": line 5)
 // 0 reduce to expression at ("test/cases/small/add.c": line 5)
@@ -10,5 +10,5 @@ int add(int b)
 }
 int main()
 {
-    return add(10);
+    return add(23);
 }