From c387e382d56be772f187c1d2b12d270bbda297e9 Mon Sep 17 00:00:00 2001
From: Christian Gram Kalhauge <chrg@dtu.dk>
Date: Wed, 28 Feb 2024 12:40:18 +0100
Subject: [PATCH] Improve performance even more
---
rtree-c/package.yaml | 11 +++---
rtree-c/rtree-c.cabal | 10 +++---
rtree-c/src/ReduceC.hs | 76 +++++++++++++++++++++++++++---------------
3 files changed, 59 insertions(+), 38 deletions(-)
diff --git a/rtree-c/package.yaml b/rtree-c/package.yaml
index 7c882ef..050992a 100644
--- a/rtree-c/package.yaml
+++ b/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
diff --git a/rtree-c/rtree-c.cabal b/rtree-c/rtree-c.cabal
index 235b460..a39fc45 100644
--- a/rtree-c/rtree-c.cabal
+++ b/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
diff --git a/rtree-c/src/ReduceC.hs b/rtree-c/src/ReduceC.hs
index 26c5ae7..380106e 100644
--- a/rtree-c/src/ReduceC.hs
+++ b/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
--
GitLab