Improve performance even more

rtree-c/package.yaml

@@ -5,7 +5,7 @@ name: rtree-c
 # category: categories
 # extra-source-files: []
 
-ghc-options: -Wall -fno-warn-incomplete-uni-patterns 
+ghc-options: -Wall -fno-warn-incomplete-uni-patterns -fprof-auto
 
 dependencies:
   - base >= 4.9 && < 5
@@ -71,11 +71,10 @@ benchmarks:
     source-dirs: bench/
     main: Main.hs
     ghc-options:
-        -O
-        -threaded
-        -fprof-auto
-        -fprof-late
-        "-with-rtsopts=-N -p -s -hc -i0.1 -L500"
+      -O
+      -threaded
+      -fprof-late
+      "-with-rtsopts=-N -p -s -hc -i0.1 -L500"
     dependencies:
       - rtree
       - rtree-c

rtree-c/rtree-c.cabal

@@ -15,7 +15,7 @@ library
       Paths_rtree_c
   hs-source-dirs:
       src
-  ghc-options: -Wall -fno-warn-incomplete-uni-patterns
+  ghc-options: -Wall -fno-warn-incomplete-uni-patterns -fprof-auto
   build-depends:
       base >=4.9 && <5
     , containers
@@ -34,7 +34,7 @@ executable rtree-c
       Paths_rtree_c
   hs-source-dirs:
       bin/
-  ghc-options: -Wall -fno-warn-incomplete-uni-patterns
+  ghc-options: -Wall -fno-warn-incomplete-uni-patterns -fprof-auto
   build-depends:
       base >=4.9 && <5
     , co-log
@@ -64,7 +64,7 @@ test-suite rtree-c-test
       Paths_rtree_c
   hs-source-dirs:
       test/src
-  ghc-options: -Wall -fno-warn-incomplete-uni-patterns
+  ghc-options: -Wall -fno-warn-incomplete-uni-patterns -fprof-auto
   build-depends:
       base >=4.9 && <5
     , containers
@@ -93,7 +93,7 @@ benchmark rtree-c-bench
       Paths_rtree_c
   hs-source-dirs:
       bench/
-  ghc-options: -Wall -fno-warn-incomplete-uni-patterns -O2 -threaded
+  ghc-options: -Wall -fno-warn-incomplete-uni-patterns -fprof-auto -O2 -threaded
   build-depends:
       base >=4.9 && <5
     , containers
@@ -119,7 +119,7 @@ benchmark rtree-c-profile
       Paths_rtree_c
   hs-source-dirs:
       bench/
-  ghc-options: -Wall -fno-warn-incomplete-uni-patterns -O -threaded -fprof-auto -fprof-late "-with-rtsopts=-N -p -s -hc -i0.1 -L500"
+  ghc-options: -Wall -fno-warn-incomplete-uni-patterns -fprof-auto -O -threaded -fprof-late "-with-rtsopts=-N -p -s -hc -i0.1 -L500"
   build-depends:
       base >=4.9 && <5
     , containers

rtree-c/src/ReduceC.hs

@@ -38,6 +38,7 @@ import Data.Vector.Internal.Check (HasCallStack)
 -- import Debug.Trace
 
 import qualified Control.Monad.IRTree as IRTree
+import Data.Monoid
 import qualified Language.C as C
 import qualified Language.C.Data.Ident as C
 
@@ -193,7 +194,19 @@ reduceCFunDef (C.CFunDef spc dec cdecls smt ni) ctx = do
       smt'
       ni
  where
-  !ctx' = foldr (`addInlineExpr` IEKeep) ctx (identifiers dec)
+  !ctx' = foldr (`addInlineExpr` IEKeep) ctx ids
+  ids = params dec
+
+params :: C.CDeclarator C.NodeInfo -> [C.Ident]
+params = \case
+  C.CDeclr _ [C.CFunDeclr (C.CFunParamsNew decls _) _ _] _ _ _ ->
+    decls & concatMap \case
+      C.CDecl _ items _ ->
+        items & concatMap \case
+          C.CDeclarationItem (C.CDeclr (Just idx) _ _ _ _) _ _ -> [idx]
+          _ow -> []
+      a -> don'tHandle a
+  a -> don'tHandle a
 
 reduceCCompoundBlockItem
   :: (MonadReduce Lab m, HasCallStack)
@@ -511,7 +524,6 @@ reduceCExpr expr ctx = case expr of
 
 inlineTypeDefsCDeclaration :: C.CDeclaration C.NodeInfo -> Context -> C.CDeclaration C.NodeInfo
 inlineTypeDefsCDeclaration decl ctx =
-  {-# SCC "inlineTypeDefsCDeclaration" #-}
   case decl of
     C.CDecl items decli ni ->
       C.CDecl (inlineTypeDefsSpecs items ctx) (map (`inlineTypeDefsCDI` ctx) decli) ni
@@ -519,7 +531,6 @@ inlineTypeDefsCDeclaration decl ctx =
 
 inlineTypeDefsSpecs :: [C.CDeclarationSpecifier C.NodeInfo] -> Context -> [C.CDeclarationSpecifier C.NodeInfo]
 inlineTypeDefsSpecs r ctx =
-  {-# SCC "inlineTypeDefsSpecs" #-}
   r & concatMap \case
     a@(C.CTypeSpec (C.CTypeDef idx _)) -> do
       case Map.lookup idx . typeDefs $ ctx of
@@ -534,38 +545,49 @@ inlineTypeDefsCDeclarator
   -> Context
   -> C.CDeclarator C.NodeInfo
 inlineTypeDefsCDeclarator (C.CDeclr idn derivedd st atr ni) ctx =
-  C.CDeclr idn (inlineTypeDefs derivedd ctx) st atr ni
+  C.CDeclr idn (map (inlineTypeDefsX ctx) derivedd) st atr ni
+
+inlineTypeDefsX :: Context -> C.CDerivedDeclarator C.NodeInfo -> C.CDerivedDeclarator C.NodeInfo
+inlineTypeDefsX ctx = \case
+  C.CFunDeclr (C.CFunParamsNew x y) b c ->
+    C.CFunDeclr (C.CFunParamsNew (map (`inlineTypeDefsCDeclaration` ctx) x) y) b c
+  C.CArrDeclr a b c -> C.CArrDeclr a b c
+  C.CPtrDeclr a b -> C.CPtrDeclr a b
+  a -> don'tHandle a
 
 inlineTypeDefsCDI :: C.CDeclarationItem C.NodeInfo -> Context -> C.CDeclarationItem C.NodeInfo
 inlineTypeDefsCDI di ctx = case di of
   C.CDeclarationItem a b ni -> C.CDeclarationItem (inlineTypeDefsCDeclarator a ctx) b ni
   a -> don'tHandle a
 
-inlineTypeDefs :: forall d. (Data d) => d -> Context -> d
-inlineTypeDefs r ctx
-  | hasReplacementTypeDef ctx r =
-      {-# SCC "inlineTypeDefs" #-}
-      case eqT @d @[C.CDeclarationSpecifier C.NodeInfo] of
-        Just Refl -> inlineTypeDefsSpecs r ctx
-        Nothing ->
-          gmapT (`inlineTypeDefs` ctx) r
-  | otherwise = r
-{-# NOINLINE inlineTypeDefs #-}
-
-hasReplacementTypeDef :: forall a. (Data a) => Context -> a -> Bool
-hasReplacementTypeDef ctx d = case cast d of
-  Just (C.CTypeSpec (C.CTypeDef idx _)) ->
-    case Map.lookup idx . typeDefs $ ctx of
-      Just ITKeep -> False
-      Just (ITInline _) -> True
-      Nothing -> error ("could not find typedef:" <> show idx)
-  Just _ -> False
-  Nothing -> gmapQl (||) False (hasReplacementTypeDef ctx) d
+-- inlineTypeDefs :: forall d. (Data d) => d -> Context -> d
+-- inlineTypeDefs r ctx
+--   | hasReplacementTypeDef ctx r =
+--       case eqT @d @[C.CDeclarationSpecifier C.NodeInfo] of
+--         Just Refl -> inlineTypeDefsSpecs r ctx
+--         Nothing ->
+--           gmapT (`inlineTypeDefs` ctx) r
+--   | otherwise = r
+-- {-# NOINLINE inlineTypeDefs #-}
+--
+-- hasReplacementTypeDef :: forall a. (Data a) => Context -> a -> Bool
+-- hasReplacementTypeDef ctx d = case cast d of
+--   Just (C.CTypeSpec (C.CTypeDef idx _)) ->
+--     case Map.lookup idx . typeDefs $ ctx of
+--       Just ITKeep -> False
+--       Just (ITInline _) -> True
+--       Nothing -> error ("could not find typedef:" <> show idx)
+--   Just _ -> False
+--   Nothing -> gmapQl (||) False (hasReplacementTypeDef ctx) d
+-- {-# NOINLINE hasReplacementTypeDef #-}
 
 identifiers :: forall a. (Data a) => a -> [C.Ident]
-identifiers d = case cast d of
-  Just l -> [l]
-  Nothing -> concat $ gmapQ identifiers d
+identifiers d = appEndo (go d) []
+ where
+  go :: forall a'. (Data a') => a' -> Endo [C.Ident]
+  go d' = case cast d' of
+    Just l -> Endo (l :)
+    Nothing -> gmapQl (<>) mempty go d'
 
 -- instance CReducible C.CExtDecl where
 --  reduceC (C.CFunDef spc dec cdecls smt ni) = do