Resonable performance gains

rtree-c/.gitignore

@@ -2,4 +2,4 @@
 *.aux
 *.hp
 *.ps
-rtree-c-bench.pdf
+*.pdf

rtree-c/benchmark.sh

-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

rtree-c/package.yaml

@@ -71,7 +71,7 @@ benchmarks:
     source-dirs: bench/
     main: Main.hs
     ghc-options:
-        -O2
+        -O
         -threaded
         -fprof-auto
         -fprof-late

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

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)
-
--- 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
+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
 
-inlineTypeDefs :: forall d. (Data d) => d -> Context -> d
-inlineTypeDefs r ctx = do
-  case eqT @d @[C.CDeclarationSpecifier C.NodeInfo] of
-    Just Refl ->
+inlineTypeDefsSpecs :: [C.CDeclarationSpecifier C.NodeInfo] -> Context -> [C.CDeclarationSpecifier C.NodeInfo]
+inlineTypeDefsSpecs r ctx =
+  {-# SCC "inlineTypeDefsSpecs" #-}
   r & concatMap \case
-        C.CTypeSpec (C.CTypeDef idx _) -> do
+    a@(C.CTypeSpec (C.CTypeDef idx _)) -> do
       case Map.lookup idx . typeDefs $ ctx of
-            Just args -> args
+        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
+
+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 #-}
 
--- instance CReducible C.CExtDecl where
---  reduceC (C.CFunDef spc dec cdecls smt ni) = do
---    pure $ C.CFunDef spc dec cdecls smt ni
+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