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

Working version sligtly faster

parent 0645913b
No related branches found
No related tags found
No related merge requests found
Showing
with 179 additions and 54041 deletions
......@@ -59,11 +59,11 @@
"language-c": {
"flake": false,
"locked": {
"lastModified": 1702044640,
"narHash": "sha256-jCpGlWLH6qnsskMnEOCAnYCKCwknpZv46cq2BmA4/cw=",
"lastModified": 1709064289,
"narHash": "sha256-bNmJPUyP5xaUwEww/bnr3dmUArRcTPszfL77K8sVrtg=",
"owner": "kalhauge",
"repo": "language-c",
"rev": "cca7c0b315cb0594071a546587bea79292e0c3d7",
"rev": "c7ac94312b741e1b6678259e518343a5bab4691f",
"type": "github"
},
"original": {
......
......@@ -19,32 +19,26 @@
load = p: n:
p.callCabal2nixWithOptions n (nix-filter.lib {root = "${self}/${n}";}) "" {};
packages = final: p: let
lib =
final.haskell.lib;
in {
"language-c" = lib.overrideCabal (p.callCabal2nixWithOptions "language-c" inputs.language-c "" {}) {
doCheck = false;
};
packages = lib: p: {
"language-c" = p.callCabal2nixWithOptions "language-c" inputs.language-c "" {};
"hspec-glitter" = p.callCabal2nixWithOptions "hspec-glitter" inputs.hspec-glitter "" {};
"rtree" = lib.dontCheck (load p "rtree");
"rtree-c" = lib.dontCheck (load p "rtree-c");
};
overlays = final: prev: {
haskellPackages = prev.haskellPackages.extend (p: _: packages final p);
};
in
{
overlays.default = overlays;
}
// flake-utils.lib.eachDefaultSystem
flake-utils.lib.eachDefaultSystem
(system: let
pkgs = import nixpkgs {
inherit system;
overlays = [inputs.hspec-glitter.overlays.default overlays];
overlays = [];
};
lib = pkgs.haskell.lib;
hpkgs = pkgs.haskellPackages;
in rec {
hpkgs = pkgs.haskellPackages.override (hpArgs: {
overrides = pkgs.lib.composeExtensions (hpArgs.overrides or (_: _: {})) (
_hfinal: hprev: packages lib hprev
);
});
in {
packages = {
default = lib.justStaticExecutables (hpkgs.rtree-c);
rtree = hpkgs.rtree;
......@@ -57,13 +51,38 @@
haskell-language-server
hpack
fourmolu
hspec-golden
];
withHoogle = true;
profiles = hpkgs.override (hpArgs: {
overrides = pkgs.lib.composeExtensions (hpArgs.overrides or (_: _: {})) (
_hfinal: hprev: {
mkDerivation = args:
hprev.mkDerivation ({
doCheck = false;
doBenchmark = false;
doHoogle = true;
doHaddock = true;
enableLibraryProfiling = true;
enableExecutableProfiling = true;
}
// args);
aeson = hprev.aeson.override {
mkDerivation = args:
hprev.mkDerivation (
args
// {
doCheck = false;
enableExecutableProfiling = false;
}
);
};
}
);
});
in {
rtree = hpkgs.rtree;
default =
hpkgs.shellFor
profiles.shellFor
{
name = "rtree-shells";
packages = p: [
......@@ -71,7 +90,12 @@
(lib.doCheck p.rtree-c)
];
doBenchmark = true;
genericBuilderArgsModifier = args:
args
// {
doCheck = true;
doBenchmark = true;
};
inherit nativeBuildInputs withHoogle;
};
};
......
.hspec-failures
*.aux
*.hp
*.ps
rtree-c-bench.pdf
--failure-report .hspec-failures
--rerun
--fail-fast
--rerun-all-on-success
{-# LANGUAGE OverloadedStrings #-}
import Criterion.Main
import qualified Language.C as C
import qualified Language.C.System.GCC as C
import ReduceC
import qualified Control.Monad.IRTree as IRTree
import Data.Either
main :: IO ()
main = do
defaultMain
[ env (fromRight (error "not there") <$> C.parseCFile (C.newGCC "clang") Nothing [] "test/cases/large/clang-26760.c") $ \c ->
let r = defaultReduceC c
in bgroup
"clang-26760"
[ bench "extract" $ nf IRTree.extract r
, bench "probe 11" $ nf (`IRTree.probe` "11") r
]
]
cabal run rtree-c-profile -- -n 10 && hp2ps -M -e8in -c rtree-c-bench.hp && ps2pdf rtree-c-bench.ps
......@@ -190,7 +190,7 @@ run = do
liftIO exitSuccess
l <-
(if expmode then IRTree.reduceExpT id else IRTree.reduceT id)
(if expmode then IRTree.reduceExp else IRTree.reduce)
(check' file)
(ReduceC.defaultReduceC c)
......
......@@ -4,3 +4,5 @@ cradle:
component: "lib:rtree-c"
- path: "./test/src"
component: "test:rtree-c-test"
- path: "./bench"
component: "benchmark:rtree-c-bench"
......@@ -51,3 +51,36 @@ tests:
- filepath
- typed-process
- text
benchmarks:
rtree-c-bench:
source-dirs: bench/
main: Main.hs
ghc-options:
-O2
-threaded
dependencies:
- rtree
- rtree-c
- criterion
- directory
- filepath
- typed-process
- text
rtree-c-profile:
source-dirs: bench/
main: Main.hs
ghc-options:
-O2
-threaded
-fprof-auto
-fprof-late
"-with-rtsopts=-N -p -s -hc -i0.1 -L500"
dependencies:
- rtree
- rtree-c
- criterion
- directory
- filepath
- typed-process
- text
......@@ -85,3 +85,55 @@ test-suite rtree-c-test
, typed-process
, vector
default-language: Haskell2010
benchmark rtree-c-bench
type: exitcode-stdio-1.0
main-is: Main.hs
other-modules:
Paths_rtree_c
hs-source-dirs:
bench/
ghc-options: -Wall -fno-warn-incomplete-uni-patterns -O2 -threaded
build-depends:
base >=4.9 && <5
, containers
, criterion
, directory
, filepath
, language-c
, mtl
, pretty
, pretty-simple
, rtree
, rtree-c
, text
, transformers
, typed-process
, vector
default-language: Haskell2010
benchmark rtree-c-profile
type: exitcode-stdio-1.0
main-is: Main.hs
other-modules:
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"
build-depends:
base >=4.9 && <5
, containers
, criterion
, directory
, filepath
, language-c
, mtl
, pretty
, pretty-simple
, rtree
, rtree-c
, text
, transformers
, typed-process
, vector
default-language: Haskell2010
......@@ -14,7 +14,7 @@
module ReduceC (
defaultReduceC,
reduceCTranslUnit,
-- reduceCTranslUnit,
-- * Context
Context (..),
......@@ -36,6 +36,8 @@ import qualified Data.Set as Set
import Data.Vector.Internal.Check (HasCallStack)
-- import Debug.Trace
import qualified Control.Monad.IRTree as IRTree
import qualified Language.C as C
import qualified Language.C.Data.Ident as C
......@@ -64,6 +66,7 @@ type Lab = (String, C.Position)
defaultReduceC :: (MonadReduce (String, C.Position) m) => C.CTranslUnit -> m C.CTranslUnit
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 ids cs Context{..} =
......@@ -134,14 +137,14 @@ reduceCExternalDeclaration r cont ctx = do
case functionName fun of
Just fid -> do
split
("remove function " <> maybe "" C.identToString (functionName fun), C.posOf r)
("remove function " <> C.identToString fid, C.posOf r)
(cont (addInlineExpr fid ITDelete ctx))
do
r' <- C.CFDefExt <$> reduceCFunDef fun ctx
(r' :) <$> cont (addInlineExpr fid ITKeep ctx)
Nothing -> do
split
("remove function " <> maybe "" C.identToString (functionName fun), C.posOf r)
("remove function", C.posOf r)
(cont ctx)
do
r' <- C.CFDefExt <$> reduceCFunDef fun ctx
......@@ -212,9 +215,9 @@ reduceCCompoundBlockItem r cont ctx = do
[]
| AllowEmptyDeclarations `isIn` ctx' ->
split ("remove empty declaration", C.posOf r) (cont ctx') do
(C.CBlockDecl (inlineTypeDefs (C.CDecl rec decl' ni') ctx) :) <$> cont ctx'
(C.CBlockDecl (C.CDecl (inlineTypeDefs rec ctx) decl' ni') :) <$> cont ctx'
| otherwise -> cont ctx'
_ow -> (C.CBlockDecl (inlineTypeDefs (C.CDecl rec decl' ni') ctx) :) <$> cont ctx'
_ow -> (C.CBlockDecl (C.CDecl (inlineTypeDefs rec ctx) decl' ni') :) <$> cont ctx'
d -> don'tHandle d
a -> don'tHandle a
......@@ -234,7 +237,7 @@ reduceCDeclarationItem d ma = case d of
("inline variable " <> C.identToString i, C.posOf ni)
(pure (ds, addInlineExpr i (ITInline c') ctx))
( pure
( C.CDeclarationItem dr (Just (C.CInitExpr c' ni')) Nothing : ds
( inlineTypeDefs (C.CDeclarationItem dr (Just (C.CInitExpr c' ni')) Nothing) ctx : ds
, addInlineExpr i ITKeep ctx
)
)
......@@ -243,7 +246,7 @@ reduceCDeclarationItem d ma = case d of
split
("remove variable " <> C.identToString i, C.posOf ni)
(pure (ds, addInlineExpr i ITDelete ctx))
(pure (d : ds, addInlineExpr i ITKeep ctx))
(pure (inlineTypeDefs d ctx : ds, addInlineExpr i ITKeep ctx))
a@(C.CDeclarationItem (C.CDeclr _ _ _ _ ni) _ _) -> do
don'tHandleWithNodeInfo a ni
a -> don'tHandle a
......@@ -474,7 +477,7 @@ reduceCExpr expr ctx = case expr of
Just do
split ("don't cast", C.posOf ni) re do
e' <- re
pure (C.CCast decl e' ni)
pure (C.CCast (inlineTypeDefs decl ctx) e' ni)
C.CIndex e1 e2 ni -> do
-- TODO: Better reduction is posisble here.
re1 <- reduceCExpr e1 ctx
......
......@@ -421,7 +421,7 @@ static double safe_div_func_double_f_f(double sf1, double sf2)
}
static int safe_convert_func_float_to_int32_t(float sf1)
{
return sf1 <= -2147483647 - 1 || sf1 >= 2147483647 ? 2147483647 : (int32_t) sf1;
return sf1 <= -2147483647 - 1 || sf1 >= 2147483647 ? 2147483647 : (int) sf1;
}
static uint32_t crc32_tab[256];
static uint32_t crc32_context = 0xffffffffuL;
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
......@@ -62,7 +62,7 @@ specLargeCases = do
(expected </> "reduction")
( \a -> do
createDirectoryIfMissing True a
8 & fix \rec i -> case i of
4 & fix \rec i -> case i of
0 -> pure ()
n -> do
let idx = fromString (replicate n '1')
......
......@@ -55,18 +55,22 @@ indexChoice :: RPath -> Int -> Bool
indexChoice (RPath v) idx
| idx < 0 = True
| otherwise = fromMaybe False (v VU.!? idx)
{-# INLINE indexChoice #-}
-- | Get the number of choices in the RPath.
numberOfChoices :: RPath -> Int
numberOfChoices (RPath v) = VU.length v
{-# INLINE numberOfChoices #-}
-- | Create a reduction path from a list of choices
fromChoiceList :: [Bool] -> RPath
fromChoiceList = RPath . VU.fromList
{-# INLINE fromChoiceList #-}
-- | Get a list of choices from a reduction path.
toChoiceList :: RPath -> [Bool]
toChoiceList = VU.toList . rPathAsVector
{-# INLINE toChoiceList #-}
debugShowWithDepth :: RPath -> Int -> String
debugShowWithDepth rp i =
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment