Update SCC annotations so that compiler profiling reports costs by pass sensibly.

Author: axch

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.

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

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

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 ===
 

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 ===
 

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 $

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

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

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

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)