Skip to content
Snippets Groups Projects
Commit c387e382 authored by chrg's avatar chrg
Browse files

Improve performance even more

parent f3730fa9
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ name: rtree-c ...@@ -5,7 +5,7 @@ name: rtree-c
# category: categories # category: categories
# extra-source-files: [] # extra-source-files: []
ghc-options: -Wall -fno-warn-incomplete-uni-patterns ghc-options: -Wall -fno-warn-incomplete-uni-patterns -fprof-auto
dependencies: dependencies:
- base >= 4.9 && < 5 - base >= 4.9 && < 5
...@@ -73,7 +73,6 @@ benchmarks: ...@@ -73,7 +73,6 @@ benchmarks:
ghc-options: ghc-options:
-O -O
-threaded -threaded
-fprof-auto
-fprof-late -fprof-late
"-with-rtsopts=-N -p -s -hc -i0.1 -L500" "-with-rtsopts=-N -p -s -hc -i0.1 -L500"
dependencies: dependencies:
......
...@@ -15,7 +15,7 @@ library ...@@ -15,7 +15,7 @@ library
Paths_rtree_c Paths_rtree_c
hs-source-dirs: hs-source-dirs:
src src
ghc-options: -Wall -fno-warn-incomplete-uni-patterns ghc-options: -Wall -fno-warn-incomplete-uni-patterns -fprof-auto
build-depends: build-depends:
base >=4.9 && <5 base >=4.9 && <5
, containers , containers
...@@ -34,7 +34,7 @@ executable rtree-c ...@@ -34,7 +34,7 @@ executable rtree-c
Paths_rtree_c Paths_rtree_c
hs-source-dirs: hs-source-dirs:
bin/ bin/
ghc-options: -Wall -fno-warn-incomplete-uni-patterns ghc-options: -Wall -fno-warn-incomplete-uni-patterns -fprof-auto
build-depends: build-depends:
base >=4.9 && <5 base >=4.9 && <5
, co-log , co-log
...@@ -64,7 +64,7 @@ test-suite rtree-c-test ...@@ -64,7 +64,7 @@ test-suite rtree-c-test
Paths_rtree_c Paths_rtree_c
hs-source-dirs: hs-source-dirs:
test/src test/src
ghc-options: -Wall -fno-warn-incomplete-uni-patterns ghc-options: -Wall -fno-warn-incomplete-uni-patterns -fprof-auto
build-depends: build-depends:
base >=4.9 && <5 base >=4.9 && <5
, containers , containers
...@@ -93,7 +93,7 @@ benchmark rtree-c-bench ...@@ -93,7 +93,7 @@ benchmark rtree-c-bench
Paths_rtree_c Paths_rtree_c
hs-source-dirs: hs-source-dirs:
bench/ 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: build-depends:
base >=4.9 && <5 base >=4.9 && <5
, containers , containers
...@@ -119,7 +119,7 @@ benchmark rtree-c-profile ...@@ -119,7 +119,7 @@ benchmark rtree-c-profile
Paths_rtree_c Paths_rtree_c
hs-source-dirs: hs-source-dirs:
bench/ 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: build-depends:
base >=4.9 && <5 base >=4.9 && <5
, containers , containers
......
...@@ -38,6 +38,7 @@ import Data.Vector.Internal.Check (HasCallStack) ...@@ -38,6 +38,7 @@ import Data.Vector.Internal.Check (HasCallStack)
-- import Debug.Trace -- import Debug.Trace
import qualified Control.Monad.IRTree as IRTree import qualified Control.Monad.IRTree as IRTree
import Data.Monoid
import qualified Language.C as C import qualified Language.C as C
import qualified Language.C.Data.Ident as C import qualified Language.C.Data.Ident as C
...@@ -193,7 +194,19 @@ reduceCFunDef (C.CFunDef spc dec cdecls smt ni) ctx = do ...@@ -193,7 +194,19 @@ reduceCFunDef (C.CFunDef spc dec cdecls smt ni) ctx = do
smt' smt'
ni ni
where 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 reduceCCompoundBlockItem
:: (MonadReduce Lab m, HasCallStack) :: (MonadReduce Lab m, HasCallStack)
...@@ -511,7 +524,6 @@ reduceCExpr expr ctx = case expr of ...@@ -511,7 +524,6 @@ reduceCExpr expr ctx = case expr of
inlineTypeDefsCDeclaration :: C.CDeclaration C.NodeInfo -> Context -> C.CDeclaration C.NodeInfo inlineTypeDefsCDeclaration :: C.CDeclaration C.NodeInfo -> Context -> C.CDeclaration C.NodeInfo
inlineTypeDefsCDeclaration decl ctx = inlineTypeDefsCDeclaration decl ctx =
{-# SCC "inlineTypeDefsCDeclaration" #-}
case decl of case decl of
C.CDecl items decli ni -> C.CDecl items decli ni ->
C.CDecl (inlineTypeDefsSpecs items ctx) (map (`inlineTypeDefsCDI` ctx) decli) ni C.CDecl (inlineTypeDefsSpecs items ctx) (map (`inlineTypeDefsCDI` ctx) decli) ni
...@@ -519,7 +531,6 @@ inlineTypeDefsCDeclaration decl ctx = ...@@ -519,7 +531,6 @@ inlineTypeDefsCDeclaration decl ctx =
inlineTypeDefsSpecs :: [C.CDeclarationSpecifier C.NodeInfo] -> Context -> [C.CDeclarationSpecifier C.NodeInfo] inlineTypeDefsSpecs :: [C.CDeclarationSpecifier C.NodeInfo] -> Context -> [C.CDeclarationSpecifier C.NodeInfo]
inlineTypeDefsSpecs r ctx = inlineTypeDefsSpecs r ctx =
{-# SCC "inlineTypeDefsSpecs" #-}
r & concatMap \case r & concatMap \case
a@(C.CTypeSpec (C.CTypeDef idx _)) -> do a@(C.CTypeSpec (C.CTypeDef idx _)) -> do
case Map.lookup idx . typeDefs $ ctx of case Map.lookup idx . typeDefs $ ctx of
...@@ -534,38 +545,49 @@ inlineTypeDefsCDeclarator ...@@ -534,38 +545,49 @@ inlineTypeDefsCDeclarator
-> Context -> Context
-> C.CDeclarator C.NodeInfo -> C.CDeclarator C.NodeInfo
inlineTypeDefsCDeclarator (C.CDeclr idn derivedd st atr ni) ctx = 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 :: C.CDeclarationItem C.NodeInfo -> Context -> C.CDeclarationItem C.NodeInfo
inlineTypeDefsCDI di ctx = case di of inlineTypeDefsCDI di ctx = case di of
C.CDeclarationItem a b ni -> C.CDeclarationItem (inlineTypeDefsCDeclarator a ctx) b ni C.CDeclarationItem a b ni -> C.CDeclarationItem (inlineTypeDefsCDeclarator a ctx) b ni
a -> don'tHandle a a -> don'tHandle a
inlineTypeDefs :: forall d. (Data d) => d -> Context -> d -- inlineTypeDefs :: forall d. (Data d) => d -> Context -> d
inlineTypeDefs r ctx -- inlineTypeDefs r ctx
| hasReplacementTypeDef ctx r = -- | hasReplacementTypeDef ctx r =
{-# SCC "inlineTypeDefs" #-} -- case eqT @d @[C.CDeclarationSpecifier C.NodeInfo] of
case eqT @d @[C.CDeclarationSpecifier C.NodeInfo] of -- Just Refl -> inlineTypeDefsSpecs r ctx
Just Refl -> inlineTypeDefsSpecs r ctx -- Nothing ->
Nothing -> -- gmapT (`inlineTypeDefs` ctx) r
gmapT (`inlineTypeDefs` ctx) r -- | otherwise = r
| otherwise = r -- {-# NOINLINE inlineTypeDefs #-}
{-# NOINLINE inlineTypeDefs #-} --
-- hasReplacementTypeDef :: forall a. (Data a) => Context -> a -> Bool
hasReplacementTypeDef :: forall a. (Data a) => Context -> a -> Bool -- hasReplacementTypeDef ctx d = case cast d of
hasReplacementTypeDef ctx d = case cast d of -- Just (C.CTypeSpec (C.CTypeDef idx _)) ->
Just (C.CTypeSpec (C.CTypeDef idx _)) -> -- case Map.lookup idx . typeDefs $ ctx of
case Map.lookup idx . typeDefs $ ctx of -- Just ITKeep -> False
Just ITKeep -> False -- Just (ITInline _) -> True
Just (ITInline _) -> True -- Nothing -> error ("could not find typedef:" <> show idx)
Nothing -> error ("could not find typedef:" <> show idx) -- Just _ -> False
Just _ -> False -- Nothing -> gmapQl (||) False (hasReplacementTypeDef ctx) d
Nothing -> gmapQl (||) False (hasReplacementTypeDef ctx) d -- {-# NOINLINE hasReplacementTypeDef #-}
identifiers :: forall a. (Data a) => a -> [C.Ident] identifiers :: forall a. (Data a) => a -> [C.Ident]
identifiers d = case cast d of identifiers d = appEndo (go d) []
Just l -> [l] where
Nothing -> concat $ gmapQ identifiers d 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 -- instance CReducible C.CExtDecl where
-- reduceC (C.CFunDef spc dec cdecls smt ni) = do -- reduceC (C.CFunDef spc dec cdecls smt ni) = do
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment