From 808f6e9127111c7f37f0b6c548a0840ce333c9f1 Mon Sep 17 00:00:00 2001 From: Alexey Radul Date: Tue, 11 Jul 2023 11:57:43 -0400 Subject: [PATCH] Update SCC annotations so that compiler profiling reports costs by pass sensibly. --- makefile | 5 +++++ src/lib/Imp.hs | 4 ++-- src/lib/ImpToLLVM.hs | 2 ++ src/lib/Inline.hs | 1 + src/lib/LLVM/Compile.hs | 5 +++-- src/lib/Optimize.hs | 2 +- src/lib/Runtime.hs | 2 +- src/lib/Simplify.hs | 7 +++---- src/lib/TopLevel.hs | 5 ----- src/lib/Vectorize.hs | 2 +- 10 files changed, 19 insertions(+), 16 deletions(-) diff --git a/makefile b/makefile index e89b7aa06..f9c9d8ae6 100644 --- a/makefile +++ b/makefile @@ -39,6 +39,11 @@ # center insertion. This way (i) you're profiling optimized rather # than unoptimized Dex, and (ii) the profile data is restricted to our # {-# SCC #-} annotations, and thus not as overwhelming. +# - As a reminder, runtime profiling is turned on by passing +RTS -p +# -RTS to `dexprof`; you can read the resulting .prof file directly, +# or postprocess it into a more legible form by for example +# running `profiteur` on it and browsing the HTML page so +# created. # # We keep the builds in separate .stack-work directories so they don't # step on each other's GHC-level compilation caches. diff --git a/src/lib/Imp.hs b/src/lib/Imp.hs index 9a9ab2e71..d74333f38 100644 --- a/src/lib/Imp.hs +++ b/src/lib/Imp.hs @@ -74,6 +74,7 @@ toImpFunction cc (TopLam True destTy lam) = do void $ translateBlock body return [] toImpFunction _ (TopLam False _ _) = error "expected a lambda in destination-passing form" +{-# SCC toImpFunction #-} getNaryLamImpArgTypesWithCC :: EnvReader m => CallingConvention -> PiType SimpIR n -> m n [BaseType] @@ -1431,8 +1432,7 @@ appSpecializedIxMethod d method args = do -- === Abstracting link-time objects === -abstractLinktimeObjects - :: forall m n. EnvReader m +abstractLinktimeObjects :: forall m n. EnvReader m => ImpFunction n -> m n (ClosedImpFunction n, [TopFunName n], [PtrName n]) abstractLinktimeObjects f = do let allVars = freeVarsE f diff --git a/src/lib/ImpToLLVM.hs b/src/lib/ImpToLLVM.hs index 3d1dd429c..b747c2c2c 100644 --- a/src/lib/ImpToLLVM.hs +++ b/src/lib/ImpToLLVM.hs @@ -182,6 +182,7 @@ impToLLVM logger fNameHint (ClosedImpFunction funBinders ptrBinders impFun) = do let sv = PtrSubstVal $ L.ConstantOperand $ globalReference ptrTy' v' return (defn, sv) return (defns, cnames, substVals) +{-# SCC impToLLVM #-} compileFunction :: (EnvReader m, MonadIO1 m) @@ -296,6 +297,7 @@ compileFunction logger fName env fun@(ImpFunction (IFunType cc argTys retTys) mainFun <- makeFunction fName argParams (Just $ i64Lit 0) extraSpecs <- gets funSpecs return ([L.GlobalDefinition mainFun], extraSpecs, []) +{-# SCC compileFunction #-} compileInstr :: Compiler m => ImpInstr i -> m i o [Operand] compileInstr instr = case instr of diff --git a/src/lib/Inline.hs b/src/lib/Inline.hs index bcf5bdc64..36cfc1c8e 100644 --- a/src/lib/Inline.hs +++ b/src/lib/Inline.hs @@ -26,6 +26,7 @@ inlineBindings :: (EnvReader m) => STopLam n -> m n (STopLam n) inlineBindings = liftLamExpr \(Abs decls ans) -> liftInlineM $ buildScoped $ inlineDecls decls $ inline Stop ans {-# INLINE inlineBindings #-} +{-# SCC inlineBindings #-} -- === Data Structure === diff --git a/src/lib/LLVM/Compile.hs b/src/lib/LLVM/Compile.hs index 2645c3f2a..c3d690ad9 100644 --- a/src/lib/LLVM/Compile.hs +++ b/src/lib/LLVM/Compile.hs @@ -49,11 +49,12 @@ compileLLVM :: PassLogger -> LLVMOptLevel -> L.Module -> String -> IO BS.ByteStr compileLLVM logger opt ast exportName = do tm <- LLVM.Shims.newDefaultHostTargetMachine withContext \c -> do - Mod.withModuleFromAST c ast \m -> do + {-# SCC "LLVM.Internal.Module.withModuleFromAST" #-} Mod.withModuleFromAST c ast \m -> do standardCompilationPipeline opt logger [exportName] tm m - Mod.moduleObject tm m + {-# SCC "LLVM.Internal.Module.moduleObject" #-} Mod.moduleObject tm m +{-# SCC compileLLVM #-} -- === LLVM passes === diff --git a/src/lib/Optimize.hs b/src/lib/Optimize.hs index e4331e484..490e7480b 100644 --- a/src/lib/Optimize.hs +++ b/src/lib/Optimize.hs @@ -36,7 +36,6 @@ optimize = dceTop -- Clean up user code >=> unrollLoops >=> dceTop -- Clean up peephole-optimized code after unrolling >=> hoistLoopInvariant -{-# SCC optimize #-} -- === Peephole optimizations === @@ -210,6 +209,7 @@ peepholeExpr expr = case expr of unrollLoops :: EnvReader m => STopLam n -> m n (STopLam n) unrollLoops = liftLamExpr unrollLoopsBlock +{-# SCC unrollLoops #-} unrollLoopsBlock :: EnvReader m => SBlock n -> m n (SBlock n) unrollLoopsBlock b = liftM fst $ diff --git a/src/lib/Runtime.hs b/src/lib/Runtime.hs index 4ee963014..1ea5dad66 100644 --- a/src/lib/Runtime.hs +++ b/src/lib/Runtime.hs @@ -82,6 +82,7 @@ callEntryFun LLVMCallable{nativeFun, benchRequired, logger, resultTypes} args = sync logSkippingFilter logger [EvalTime avgTime (Just (benchRuns, totalTime + evalTime))] return results +{-# SCC callEntryFun #-} checkedCallFunPtr :: FD -> Ptr () -> Ptr () -> DexExecutable -> IO Double checkedCallFunPtr fd argsPtr resultPtr fPtr = do @@ -91,7 +92,6 @@ checkedCallFunPtr fd argsPtr resultPtr fPtr = do return exitCode unless (exitCode == 0) $ throw RuntimeErr "" return duration -{-# SCC checkedCallFunPtr #-} withPipeToLogger :: PassLogger -> (FD -> IO a) -> IO a withPipeToLogger logger writeAction = do diff --git a/src/lib/Simplify.hs b/src/lib/Simplify.hs index 028e35981..86e395e80 100644 --- a/src/lib/Simplify.hs +++ b/src/lib/Simplify.hs @@ -246,19 +246,18 @@ data SimplifiedBlock n = SimplifiedBlock (SBlock n) (ReconstructAtom n) simplifyTopBlock :: (TopBuilder m, Mut n) => TopBlock CoreIR n -> m n (SimplifiedTopLam n) simplifyTopBlock (TopLam _ _ (LamExpr Empty body)) = do - SimplifiedBlock block recon <- liftSimplifyM $ buildSimplifiedBlock $ simplifyBlock body + SimplifiedBlock block recon <- liftSimplifyM do + {-# SCC "Simplify" #-} buildSimplifiedBlock $ simplifyBlock body topLam <- asTopLam $ LamExpr Empty block return $ SimplifiedTopLam topLam recon simplifyTopBlock _ = error "not a block (nullary lambda)" -{-# SCC simplifyTopBlock #-} simplifyTopFunction :: (TopBuilder m, Mut n) => CTopLam n -> m n (STopLam n) simplifyTopFunction (TopLam False _ f) = do asTopLam =<< liftSimplifyM do - (lam, CoerceReconAbs) <- simplifyLam f + (lam, CoerceReconAbs) <- {-# SCC "Simplify" #-} simplifyLam f return lam simplifyTopFunction _ = error "shouldn't be in destination-passing style already" -{-# SCC simplifyTopFunction #-} applyReconTop :: (EnvReader m, Fallible1 m) => ReconstructAtom n -> SAtom n -> m n (CAtom n) applyReconTop = applyRecon diff --git a/src/lib/TopLevel.hs b/src/lib/TopLevel.hs index caf3d591c..f2379f259 100644 --- a/src/lib/TopLevel.hs +++ b/src/lib/TopLevel.hs @@ -242,7 +242,6 @@ evalSourceBlock mname block = do _ -> return () _ -> return () return $ filterLogs block $ addResultCtx block result -{-# SCC evalSourceBlock #-} evalSourceBlock' :: (Topper m, Mut n) => ModuleSourceName -> SourceBlock -> m n () @@ -529,7 +528,6 @@ evalUExpr expr = do renamed <- logPass RenamePass $ renameSourceNamesUExpr expr typed <- checkPass TypePass $ inferTopUExpr renamed evalBlock typed -{-# SCC evalUExpr #-} whenOpt :: Topper m => a -> (a -> m n a) -> m n a whenOpt x act = getConfig <&> optLevel >>= \case @@ -638,7 +636,6 @@ execUDecl mname decl = do vs <- forM xs \x -> emitTopLet hint PlainLet (Atom x) applyRename (bs@@>(atomVarName <$> vs)) sm >>= emitSourceMap UDeclResultDone sourceMap' -> emitSourceMap sourceMap' -{-# SCC execUDecl #-} compileTopLevelFun :: (Topper m, Mut n) => CallingConvention -> STopLam n -> m n (ImpFunction n) @@ -647,7 +644,6 @@ compileTopLevelFun cc fSimp = do fLower <- checkPass LowerPass $ lowerFullySequential True fOpt flOpt <- loweredOptimizations fLower checkPass ImpPass $ toImpFunction cc flOpt -{-# SCC compileTopLevelFun #-} printCodegen :: (Topper m, Mut n) => CAtom n -> m n String printCodegen x = do @@ -716,7 +712,6 @@ packageLLVMCallable impFun = do logger <- getFilteredLogger let IFunType _ _ resultTypes = impFunType impFun return LLVMCallable{..} -{-# SCC packageLLVMCallable #-} compileToObjCode :: Topper m => WithCNameInterface LLVM.AST.Module -> m n FunObjCode compileToObjCode astWithNames = forM astWithNames \ast -> do diff --git a/src/lib/Vectorize.hs b/src/lib/Vectorize.hs index d9a62728a..42b36e1b1 100644 --- a/src/lib/Vectorize.hs +++ b/src/lib/Vectorize.hs @@ -99,6 +99,7 @@ vectorizeLoops width (TopLam d ty (LamExpr bsDestB body)) = liftEnvReaderM do (Abs b'' body'', errs) <- liftTopVectorizeM width $ vectorizeLoopsDestBlock body' return $ (TopLam d ty (LamExpr (bs' >>> UnaryNest b'') body''), errs) Nothing -> error "expected a trailing dest binder" +{-# SCC vectorizeLoops #-} liftTopVectorizeM :: (EnvReader m) => Word32 -> TopVectorizeM i i a -> m i (a, Errs) @@ -139,7 +140,6 @@ vectorizeLoopsDestBlock (Abs (destb:>destTy) body) = do withFreshBinder (getNameHint destb) destTy' \destb' -> do extendRenamer (destb @> binderName destb') do Abs destb' <$> buildBlock (vectorizeLoopsBlock body) -{-# SCC vectorizeLoopsDestBlock #-} vectorizeLoopsBlock :: (Emits o) => Block SimpIR i -> TopVectorizeM i o (SAtom o)