Skip to content

Commit 836cce0

Browse files
plajjanplajjan
authored
Merge pull request #2813 from actonlang/compiler-bench-driver
Add compiler benchmark and avoid redundant CodeGen type rendering
2 parents 8debfe8 + a062bf2 commit 836cce0

3 files changed

Lines changed: 254 additions & 0 deletions

File tree

‎compiler/lib/bench/CompilerBench.hs‎

Lines changed: 243 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,243 @@
1+
import qualified Acton.CommandLineParser as C
2+
import qualified Acton.Compile as Compile
3+
import qualified Acton.Env as Env
4+
import qualified Acton.Kinds as Kinds
5+
import qualified Acton.NameInfo as NameInfo
6+
import qualified Acton.Parser as Parser
7+
import qualified Acton.Syntax as Syntax
8+
import qualified Acton.Types as Types
9+
10+
import Control.DeepSeq (rnf)
11+
import qualified Control.Exception as E
12+
import Control.Monad (forM_)
13+
import qualified Data.ByteString.Char8 as B
14+
import qualified Data.HashMap.Strict as HashMap
15+
import qualified Data.Map as Map
16+
import Data.Time.Clock (diffUTCTime, getCurrentTime)
17+
import GHC.Stats
18+
import System.Clock (TimeSpec, toNanoSecs)
19+
import System.Environment (getArgs)
20+
import System.FilePath (takeDirectory)
21+
import System.IO (BufferMode(LineBuffering), hSetBuffering, stdout)
22+
import qualified InterfaceFiles
23+
24+
-- Usage:
25+
-- stack build libacton:exe:compiler-bench
26+
-- stack exec compiler-bench -- --parse TYPES_PATH SOURCE.act +RTS -T -RTS
27+
-- stack exec compiler-bench -- --kinds TYPES_PATH SOURCE.act +RTS -T -RTS
28+
-- stack exec compiler-bench -- --types TYPES_PATH SOURCE.act +RTS -T -RTS
29+
-- stack exec compiler-bench -- --front TYPES_PATH SOURCE.act +RTS -T -RTS
30+
-- stack exec compiler-bench -- --front-docs TYPES_PATH SOURCE.act +RTS -T -RTS
31+
-- stack exec compiler-bench -- --pipeline TYPES_PATH SOURCE.act +RTS -T -RTS
32+
--
33+
-- The direct modes stop after the named pass. --front runs the normal compiler
34+
-- front pass without docs, --front-docs includes project front-pass work such
35+
-- as docs, and --pipeline runs front plus back passes.
36+
37+
data DirectMode = ParseOnly | KindsOnly | TypesOnly
38+
39+
elapsed label t0 t1 = putStrLn $ label ++ " " ++ show (diffUTCTime t1 t0)
40+
41+
printStats label before after =
42+
putStrLn $ label ++ " alloc " ++ show alloc
43+
++ " copied " ++ show copied
44+
++ " max_live " ++ show (max_live_bytes after)
45+
++ " max_mem " ++ show (max_mem_in_use_bytes after)
46+
++ " gc_elapsed " ++ show gcElapsed
47+
++ " gcs " ++ show collections
48+
where alloc = allocated_bytes after - allocated_bytes before
49+
copied = copied_bytes after - copied_bytes before
50+
gcElapsed = gc_elapsed_ns after - gc_elapsed_ns before
51+
collections = gcs after - gcs before
52+
53+
getStats enabled =
54+
if enabled then Just <$> getRTSStats else return Nothing
55+
56+
printStatsMaybe label (Just before) (Just after) = printStats label before after
57+
printStatsMaybe _ _ _ = return ()
58+
59+
forceHTEnv = HashMap.foldl' forceHNameInfo () where
60+
forceHNameInfo () (NameInfo.HNModule _ te _) = forceHTEnv te
61+
forceHNameInfo () hni = hni `seq` ()
62+
63+
fmtTime :: TimeSpec -> String
64+
fmtTime t = show seconds ++ "s"
65+
where seconds = (fromIntegral (toNanoSecs t) / 1000000000.0 :: Double)
66+
67+
printFrontTiming :: Compile.FrontTiming -> IO ()
68+
printFrontTiming ft =
69+
putStrLn $ "front_timing env " ++ fmtTime (Compile.ftEnv ft)
70+
++ " kinds " ++ fmtTime (Compile.ftKinds ft)
71+
++ " types " ++ fmtTime (Compile.ftTypes ft)
72+
73+
printBackTiming :: Compile.BackTiming -> IO ()
74+
printBackTiming bt =
75+
putStrLn $ "back_timing normalize " ++ fmtTime (Compile.btNormalize bt)
76+
++ " deactorize " ++ fmtTime (Compile.btDeactorize bt)
77+
++ " cps " ++ fmtTime (Compile.btCPS bt)
78+
++ " llift " ++ fmtTime (Compile.btLLift bt)
79+
++ " boxing " ++ fmtTime (Compile.btBoxing bt)
80+
++ " codegen " ++ fmtTime (Compile.btCodeGen bt)
81+
++ " render " ++ fmtTime (Compile.btRender bt)
82+
++ maybe "" (\t -> " write " ++ fmtTime t) (Compile.btWrite bt)
83+
84+
sysRootFromTypesPath :: FilePath -> FilePath
85+
sysRootFromTypesPath = takeDirectory . takeDirectory . takeDirectory
86+
87+
benchGopts :: C.GlobalOptions
88+
benchGopts = C.GlobalOptions
89+
{ C.color = C.Never
90+
, C.quiet = False
91+
, C.noProgress = True
92+
, C.timing = True
93+
, C.tty = False
94+
, C.verbose = False
95+
, C.verboseZig = False
96+
, C.jobs = 0
97+
}
98+
99+
benchOpts :: FilePath -> Bool -> C.CompileOptions
100+
benchOpts typesPath skipBuild =
101+
Compile.defaultCompileOptions
102+
{ C.ignore_compiler_version = True
103+
, C.skip_build = skipBuild
104+
, C.syspath = sysRootFromTypesPath typesPath
105+
}
106+
107+
nameHashMapFromHeader :: [InterfaceFiles.NameHashInfo] -> Map.Map Syntax.Name InterfaceFiles.NameHashInfo
108+
nameHashMapFromHeader infos =
109+
Map.fromList [ (InterfaceFiles.nhName info, info) | info <- infos ]
110+
111+
resolveNameHashMap :: Compile.Paths -> Syntax.ModName -> IO (Maybe (Map.Map Syntax.Name InterfaceFiles.NameHashInfo))
112+
resolveNameHashMap paths mn = do
113+
mty <- Env.findTyFile (Compile.searchPath paths) mn
114+
case mty of
115+
Nothing -> return Nothing
116+
Just ty -> do
117+
mh <- InterfaceFiles.readHeaderMaybe ty
118+
return $ case mh of
119+
Just (_, _, _, _, _, nameHashes, _, _, _) -> Just (nameHashMapFromHeader nameHashes)
120+
Nothing -> Nothing
121+
122+
runDirect :: DirectMode -> FilePath -> FilePath -> IO ()
123+
runDirect mode typesPath sourcePath = do
124+
statsEnabled <- getRTSStatsEnabled
125+
src <- readFile sourcePath
126+
let opts = benchOpts typesPath True
127+
paths <- Compile.findPaths sourcePath opts
128+
env0 <- Env.initEnv typesPath False
129+
let modName = Compile.modName paths
130+
131+
s0 <- getStats statsEnabled
132+
t0 <- getCurrentTime
133+
parsed <- Parser.parseModule modName sourcePath src Nothing
134+
E.evaluate (rnf parsed)
135+
t1 <- getCurrentTime
136+
s1 <- getStats statsEnabled
137+
elapsed "parse" t0 t1
138+
printStatsMaybe "parse_stats" s0 s1
139+
140+
case mode of
141+
ParseOnly -> return ()
142+
_ -> do
143+
env <- Env.mkEnv [typesPath] env0 parsed
144+
E.evaluate (forceHTEnv (Env.hnames env))
145+
E.evaluate (forceHTEnv (Env.hmodules env))
146+
t2 <- getCurrentTime
147+
s2 <- getStats statsEnabled
148+
elapsed "env" t1 t2
149+
printStatsMaybe "env_stats" s1 s2
150+
151+
kchecked <- Kinds.check env parsed
152+
E.evaluate (rnf kchecked)
153+
t3 <- getCurrentTime
154+
s3 <- getStats statsEnabled
155+
elapsed "kinds" t2 t3
156+
printStatsMaybe "kinds_stats" s2 s3
157+
158+
case mode of
159+
KindsOnly -> return ()
160+
_ -> do
161+
(nmod, tchecked, typeEnv, tests) <- Types.reconstruct Nothing Nothing env kchecked
162+
E.evaluate (rnf nmod)
163+
E.evaluate (rnf tchecked)
164+
E.evaluate (forceHTEnv (Env.hnames typeEnv))
165+
E.evaluate (forceHTEnv (Env.hmodules typeEnv))
166+
E.evaluate (length tests)
167+
t4 <- getCurrentTime
168+
s4 <- getStats statsEnabled
169+
elapsed "types" t3 t4
170+
printStatsMaybe "types_stats" s3 s4
171+
172+
runCompilerFront :: Bool -> Bool -> FilePath -> FilePath -> IO ()
173+
runCompilerFront buildFront runBack typesPath sourcePath = do
174+
statsEnabled <- getRTSStatsEnabled
175+
src <- readFile sourcePath
176+
srcBytes <- B.readFile sourcePath
177+
let opts = benchOpts typesPath (not buildFront)
178+
paths <- Compile.findPaths sourcePath opts
179+
env0 <- Env.initEnv typesPath False
180+
let modName = Compile.modName paths
181+
182+
s0 <- getStats statsEnabled
183+
t0 <- getCurrentTime
184+
parsed <- Parser.parseModule modName sourcePath src Nothing
185+
E.evaluate (rnf parsed)
186+
t1 <- getCurrentTime
187+
s1 <- getStats statsEnabled
188+
elapsed "parse" t0 t1
189+
printStatsMaybe "parse_stats" s0 s1
190+
191+
res <- Compile.runFrontPasses
192+
benchGopts
193+
opts
194+
paths
195+
env0
196+
parsed
197+
src
198+
srcBytes
199+
Nothing
200+
(Compile.getPubHashCached paths)
201+
(resolveNameHashMap paths)
202+
(\_ -> return ())
203+
fr <- case res of
204+
Left diags -> error ("front pass failed with " ++ show (length diags) ++ " diagnostics")
205+
Right fr -> return fr
206+
E.evaluate (length (Compile.frIfaceTE fr) + length (Compile.frImps fr) + length (Compile.frNameHashes fr))
207+
t2 <- getCurrentTime
208+
s2 <- getStats statsEnabled
209+
elapsed "front" t1 t2
210+
printStatsMaybe "front_stats" s1 s2
211+
forM_ (Compile.frFrontTiming fr) printFrontTiming
212+
213+
case (runBack, Compile.frBackJob fr) of
214+
(True, Just job) -> do
215+
s3 <- getStats statsEnabled
216+
t3 <- getCurrentTime
217+
(_mtime, mtiming) <- Compile.runBackPasses benchGopts (Compile.bjOpts job) (Compile.bjPaths job) (Compile.bjInput job) (return True)
218+
t4 <- getCurrentTime
219+
s4 <- getStats statsEnabled
220+
elapsed "back" t3 t4
221+
printStatsMaybe "back_stats" s3 s4
222+
forM_ mtiming printBackTiming
223+
(True, Nothing) -> error "front pass did not return a back job"
224+
(False, _) -> return ()
225+
226+
main = do
227+
hSetBuffering stdout LineBuffering
228+
args <- getArgs
229+
case args of
230+
["--parse", typesPath, sourcePath] ->
231+
runDirect ParseOnly typesPath sourcePath
232+
["--kinds", typesPath, sourcePath] ->
233+
runDirect KindsOnly typesPath sourcePath
234+
["--types", typesPath, sourcePath] ->
235+
runDirect TypesOnly typesPath sourcePath
236+
["--front", typesPath, sourcePath] ->
237+
runCompilerFront False False typesPath sourcePath
238+
["--front-docs", typesPath, sourcePath] ->
239+
runCompilerFront True False typesPath sourcePath
240+
["--pipeline", typesPath, sourcePath] ->
241+
runCompilerFront True True typesPath sourcePath
242+
_ ->
243+
error "usage: compiler-bench (--parse|--kinds|--types|--front|--front-docs|--pipeline) TYPES_PATH SOURCE.act"

‎compiler/lib/package.yaml.in‎

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -105,6 +105,16 @@ tests:
105105
- -with-rtsopts=-N
106106

107107
executables:
108+
compiler-bench:
109+
main: CompilerBench.hs
110+
source-dirs: bench
111+
other-modules: []
112+
dependencies:
113+
- libacton
114+
ghc-options:
115+
- -threaded
116+
- -rtsopts
117+
- '"-with-rtsopts=-N -A64M"'
108118
kinds-bench:
109119
main: KindsBench.hs
110120
source-dirs: bench

‎compiler/lib/src/Acton/CodeGen.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -810,6 +810,7 @@ targetType env e = typeOf env e -- Must be a
810810
dotCast env ent ts (Var _ x) n
811811
| GName m _ <- x, m == mPrim = id
812812
dotCast env ent ts e n
813+
| t == t1 = id
813814
| gen_t == gen env t1 = id
814815
| otherwise = parens . (parens gen_t <>)
815816
where t0 = typeOf env e

0 commit comments

Comments
 (0)