From f3730fa9a4151c5b54c651fbfbd79af8ceaad4f6 Mon Sep 17 00:00:00 2001
From: Christian Gram Kalhauge <chrg@dtu.dk>
Date: Wed, 28 Feb 2024 12:04:49 +0100
Subject: [PATCH] Resonable performance gains
---
rtree-c/.gitignore | 2 +-
rtree-c/benchmark.sh | 2 +-
rtree-c/package.yaml | 2 +-
rtree-c/rtree-c.cabal | 2 +-
rtree-c/src/ReduceC.hs | 190 +++++++++++++++++++----------------------
5 files changed, 94 insertions(+), 104 deletions(-)
diff --git a/rtree-c/.gitignore b/rtree-c/.gitignore
index f8804b7..1cb2ec5 100644
--- a/rtree-c/.gitignore
+++ b/rtree-c/.gitignore
@@ -2,4 +2,4 @@
*.aux
*.hp
*.ps
-rtree-c-bench.pdf
+*.pdf
diff --git a/rtree-c/benchmark.sh b/rtree-c/benchmark.sh
index 4d8bc05..da96e96 100755
--- a/rtree-c/benchmark.sh
+++ b/rtree-c/benchmark.sh
@@ -1 +1 @@
-cabal run rtree-c-profile -- -n 10 && hp2ps -M -e8in -c rtree-c-bench.hp && ps2pdf rtree-c-bench.ps
+cabal run rtree-c-profile -- -n 1 && hp2ps -M -e8in -c rtree-c-profile.hp && ps2pdf rtree-c-profile.ps
diff --git a/rtree-c/package.yaml b/rtree-c/package.yaml
index d3030aa..7c882ef 100644
--- a/rtree-c/package.yaml
+++ b/rtree-c/package.yaml
@@ -71,7 +71,7 @@ benchmarks:
source-dirs: bench/
main: Main.hs
ghc-options:
- -O2
+ -O
-threaded
-fprof-auto
-fprof-late
diff --git a/rtree-c/rtree-c.cabal b/rtree-c/rtree-c.cabal
index 1921686..235b460 100644
--- a/rtree-c/rtree-c.cabal
+++ b/rtree-c/rtree-c.cabal
@@ -119,7 +119,7 @@ benchmark rtree-c-profile
Paths_rtree_c
hs-source-dirs:
bench/
- ghc-options: -Wall -fno-warn-incomplete-uni-patterns -O2 -threaded -fprof-auto -fprof-late "-with-rtsopts=-N -p -s -hc -i0.1 -L500"
+ ghc-options: -Wall -fno-warn-incomplete-uni-patterns -O -threaded -fprof-auto -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 f8027dc..26c5ae7 100644
--- a/rtree-c/src/ReduceC.hs
+++ b/rtree-c/src/ReduceC.hs
@@ -43,15 +43,20 @@ import qualified Language.C.Data.Ident as C
data Context = Context
{ keywords :: !(Set.Set Keyword)
- , typeDefs :: !(Map.Map C.Ident [C.CDeclarationSpecifier C.NodeInfo])
- , inlineExprs :: !(Map.Map C.Ident InlineType)
+ , typeDefs :: !(Map.Map C.Ident InlineType)
+ , inlineExprs :: !(Map.Map C.Ident InlineExpr)
}
deriving (Show)
data InlineType
- = ITDelete
- | ITInline !C.CExpr
- | ITKeep
+ = ITKeep
+ | ITInline ![C.CDeclarationSpecifier C.NodeInfo]
+ deriving (Show, Eq)
+
+data InlineExpr
+ = IEDelete
+ | IEInline !C.CExpr
+ | IEKeep
deriving (Show, Eq)
data Keyword
@@ -68,7 +73,7 @@ defaultReduceC :: (MonadReduce (String, C.Position) m) => C.CTranslUnit -> m C.C
defaultReduceC a = reduceCTranslUnit a defaultContext
{-# SPECIALIZE defaultReduceC :: C.CTranslUnit -> IRTree.IRTree (String, C.Position) C.CTranslUnit #-}
-addTypeDefs :: [C.Ident] -> [C.CDeclarationSpecifier C.NodeInfo] -> Context -> Context
+addTypeDefs :: [C.Ident] -> InlineType -> Context -> Context
addTypeDefs ids cs Context{..} =
Context
{ typeDefs =
@@ -76,7 +81,7 @@ addTypeDefs ids cs Context{..} =
, ..
}
-addInlineExpr :: C.Ident -> InlineType -> Context -> Context
+addInlineExpr :: C.Ident -> InlineExpr -> Context -> Context
addInlineExpr i e Context{..} =
Context
{ inlineExprs = Map.insert i e inlineExprs
@@ -138,10 +143,10 @@ reduceCExternalDeclaration r cont ctx = do
Just fid -> do
split
("remove function " <> C.identToString fid, C.posOf r)
- (cont (addInlineExpr fid ITDelete ctx))
+ (cont (addInlineExpr fid IEDelete ctx))
do
r' <- C.CFDefExt <$> reduceCFunDef fun ctx
- (r' :) <$> cont (addInlineExpr fid ITKeep ctx)
+ (r' :) <$> cont (addInlineExpr fid IEKeep ctx)
Nothing -> do
split
("remove function", C.posOf r)
@@ -150,14 +155,16 @@ reduceCExternalDeclaration r cont ctx = do
r' <- C.CFDefExt <$> reduceCFunDef fun ctx
(r' :) <$> cont ctx
C.CDeclExt result ->
- case inlineTypeDefs result ctx of
+ case result of
-- A typedef
- C.CDecl (C.CStorageSpec (C.CTypedef n) : rst) decl _ -> do
+ C.CDecl (C.CStorageSpec (C.CTypedef _) : rst) decl _ -> do
let [ids] = identifiers decl
split
("inline typedef " <> C.identToString ids, C.posOf r)
- (cont (addTypeDefs [ids] rst ctx))
- ((r :) <$> cont (addTypeDefs [ids] [C.CTypeSpec (C.CTypeDef ids n)] ctx))
+ (cont (addTypeDefs [ids] (ITInline rst) ctx))
+ ( (C.CDeclExt (inlineTypeDefsCDeclaration result ctx) :)
+ <$> cont (addTypeDefs [ids] ITKeep ctx)
+ )
-- A const
C.CDecl rec decl ni' -> do
(decl', ctx') <- foldr reduceCDeclarationItem (pure ([], ctx)) decl
@@ -165,9 +172,9 @@ reduceCExternalDeclaration r cont ctx = do
[]
| AllowEmptyDeclarations `isIn` ctx' ->
split ("remove empty declaration", C.posOf r) (cont ctx') do
- (C.CDeclExt (C.CDecl rec decl' ni') :) <$> cont ctx'
+ (C.CDeclExt (inlineTypeDefsCDeclaration (C.CDecl rec decl' ni') ctx) :) <$> cont ctx'
| otherwise -> cont ctx'
- _ow -> (C.CDeclExt (C.CDecl rec decl' ni') :) <$> cont ctx'
+ _ow -> (C.CDeclExt (inlineTypeDefsCDeclaration (C.CDecl rec decl' ni') ctx) :) <$> cont ctx'
a -> don'tHandle a
_r -> don'tHandle r
@@ -180,13 +187,13 @@ reduceCFunDef (C.CFunDef spc dec cdecls smt ni) ctx = do
smt' <- reduceCStatementOrEmptyBlock smt ctx'
pure $
C.CFunDef
- (inlineTypeDefs spc ctx)
- (inlineTypeDefs dec ctx)
- (inlineTypeDefs cdecls ctx)
+ (inlineTypeDefsSpecs spc ctx)
+ (inlineTypeDefsCDeclarator dec ctx)
+ (map (`inlineTypeDefsCDeclaration` ctx) cdecls)
smt'
ni
where
- !ctx' = foldr (`addInlineExpr` ITKeep) ctx (identifiers dec)
+ !ctx' = foldr (`addInlineExpr` IEKeep) ctx (identifiers dec)
reduceCCompoundBlockItem
:: (MonadReduce Lab m, HasCallStack)
@@ -215,9 +222,9 @@ reduceCCompoundBlockItem r cont ctx = do
[]
| AllowEmptyDeclarations `isIn` ctx' ->
split ("remove empty declaration", C.posOf r) (cont ctx') do
- (C.CBlockDecl (C.CDecl (inlineTypeDefs rec ctx) decl' ni') :) <$> cont ctx'
+ (C.CBlockDecl (inlineTypeDefsCDeclaration (C.CDecl rec decl' ni') ctx) :) <$> cont ctx'
| otherwise -> cont ctx'
- _ow -> (C.CBlockDecl (C.CDecl (inlineTypeDefs rec ctx) decl' ni') :) <$> cont ctx'
+ _ow -> (C.CBlockDecl (inlineTypeDefsCDeclaration (C.CDecl rec decl' ni') ctx) :) <$> cont ctx'
d -> don'tHandle d
a -> don'tHandle a
@@ -235,18 +242,18 @@ reduceCDeclarationItem d ma = case d of
c' <- fromMaybe (pure zeroExpr) (reduceCExpr c ctx)
split
("inline variable " <> C.identToString i, C.posOf ni)
- (pure (ds, addInlineExpr i (ITInline c') ctx))
+ (pure (ds, addInlineExpr i (IEInline c') ctx))
( pure
- ( inlineTypeDefs (C.CDeclarationItem dr (Just (C.CInitExpr c' ni')) Nothing) ctx : ds
- , addInlineExpr i ITKeep ctx
+ ( inlineTypeDefsCDI (C.CDeclarationItem dr (Just (C.CInitExpr c' ni')) Nothing) ctx : ds
+ , addInlineExpr i IEKeep ctx
)
)
C.CDeclarationItem (C.CDeclr (Just i) _ Nothing _ ni) _ Nothing -> do
(ds, ctx) <- ma
split
("remove variable " <> C.identToString i, C.posOf ni)
- (pure (ds, addInlineExpr i ITDelete ctx))
- (pure (inlineTypeDefs d ctx : ds, addInlineExpr i ITKeep ctx))
+ (pure (ds, addInlineExpr i IEDelete ctx))
+ (pure (inlineTypeDefsCDI d ctx : ds, addInlineExpr i IEKeep ctx))
a@(C.CDeclarationItem (C.CDeclr _ _ _ _ ni) _ _) -> do
don'tHandleWithNodeInfo a ni
a -> don'tHandle a
@@ -443,11 +450,11 @@ reduceCExpr expr ctx = case expr of
C.CVar i _ ->
case Map.lookup i . inlineExprs $ ctx of
Just mx -> case mx of
- ITKeep -> Just (pure expr)
- ITInline mx'
+ IEKeep -> Just (pure expr)
+ IEInline mx'
| DisallowVariableInlining `isIn` ctx -> Nothing
| otherwise -> Just (pure mx')
- ITDelete ->
+ IEDelete ->
Nothing
Nothing -> error ("Could not find " <> show i <> " at " <> show (C.posOf expr) <> "\n" <> show (inlineExprs ctx))
C.CConst x -> Just do
@@ -477,7 +484,7 @@ reduceCExpr expr ctx = case expr of
Just do
split ("don't cast", C.posOf ni) re do
e' <- re
- pure (C.CCast (inlineTypeDefs decl ctx) e' ni)
+ pure (C.CCast (inlineTypeDefsCDeclaration decl ctx) e' ni)
C.CIndex e1 e2 ni -> do
-- TODO: Better reduction is posisble here.
re1 <- reduceCExpr e1 ctx
@@ -502,85 +509,68 @@ reduceCExpr expr ctx = case expr of
else pure $ C.CComma (reverse (x' : rst')) ni
a -> don'tHandleWithPos a
--- pure $ C.CCond ec' et' ef' ni
--- C.CBinary o elhs erhs ni -> onBothExpr elhs erhs \lhs rhs ->
--- pure $ C.CBinary o lhs rhs ni
--- C.CUnary o elhs ni -> do
--- lhs <- reduce elhs
--- pure $ C.CUnary o lhs ni
--- C.CConst c -> do
--- -- TODO fix
--- pure $ C.CConst c
--- C.CMember e i b ni -> do
--- givenThat (Val.is i)
--- e' <- reduce e
--- pure $ C.CMember e' i b ni
--- e -> error (show e)
--- where
--- onBothExpr elhs erhs = onBoth (reduce elhs) (reduce erhs)
+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
+ a -> don'tHandle a
--- splitIf :: (MonadReduce l m) => Bool -> l -> m a -> m a -> m a
--- splitIf True s a b = split s a b
--- splitIf False _ _ b = b
---
--- splitOn :: (MonadReduce l m, MonadReader Context m) => Keyword -> l -> m a -> m a -> m a
--- splitOn k s a b = do
--- con <- keyword k
--- splitIf con s a b
---
--- maybeSplit
--- :: (MonadReduce l m)
--- => l
--- -> Maybe (m a)
--- -> Maybe (m a)
--- -> Maybe (m a)
--- maybeSplit s a b = case a of
--- Just a' -> case b of
--- Just b' -> Just do
--- split s a' b'
--- Nothing -> Just a'
--- Nothing -> b
---
--- maybeSplitOn
--- :: (MonadReduce l m)
--- => Keyword
--- -> l
--- -> ReaderT Context Maybe (m a)
--- -> ReaderT Context Maybe (m a)
--- -> ReaderT Context Maybe (m a)
--- maybeSplitOn k s a b = do
--- con <- keyword k
--- if con
--- then b
--- else ReaderT \ctx ->
--- case runReaderT a ctx of
--- Just a' -> case runReaderT b ctx of
--- Just b' -> Just $ split s a' b'
--- Nothing -> Just a'
--- Nothing -> runReaderT b 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
+ Just ITKeep -> [a]
+ Just (ITInline res) -> res
+ Nothing -> error ("could not find typedef:" <> show idx)
+ a -> [a]
+{-# NOINLINE inlineTypeDefsSpecs #-}
+
+inlineTypeDefsCDeclarator
+ :: C.CDeclarator C.NodeInfo
+ -> Context
+ -> C.CDeclarator C.NodeInfo
+inlineTypeDefsCDeclarator (C.CDeclr idn derivedd st atr ni) ctx =
+ C.CDeclr idn (inlineTypeDefs derivedd ctx) st atr ni
-inlineTypeDefs :: forall d. (Data d) => d -> Context -> d
-inlineTypeDefs r ctx = do
- case eqT @d @[C.CDeclarationSpecifier C.NodeInfo] of
- Just Refl ->
- r & concatMap \case
- C.CTypeSpec (C.CTypeDef idx _) -> do
- case Map.lookup idx . typeDefs $ ctx of
- Just args -> args
- Nothing -> error ("could not find typedef:" <> show idx)
- a -> [a]
- Nothing ->
- gmapT (`inlineTypeDefs` ctx) r
+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
--- instance CReducible C.CExtDecl where
--- reduceC (C.CFunDef spc dec cdecls smt ni) = do
--- pure $ C.CFunDef spc dec cdecls smt ni
+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
identifiers :: forall a. (Data a) => a -> [C.Ident]
identifiers d = case cast d of
Just l -> [l]
Nothing -> concat $ gmapQ identifiers d
+-- instance CReducible C.CExtDecl where
+-- reduceC (C.CFunDef spc dec cdecls smt ni) = do
+-- pure $ C.CFunDef spc dec cdecls smt ni
+
functionName :: C.CFunctionDef C.NodeInfo -> Maybe C.Ident
functionName = \case
C.CFunDef _ (C.CDeclr ix _ _ _ _) _ _ _ -> ix
--
GitLab