From f0ee3241bec18ca770a4ba4673bf6b8b5145458f Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Tue, 23 Apr 2024 17:15:18 +0200 Subject: [PATCH] More information in the eventlog --- src/Plugin/TraceForeignCalls.hs | 57 +++++++++++++++++++++++++++------ trace-foreign-calls.cabal | 1 - 2 files changed, 47 insertions(+), 11 deletions(-) diff --git a/src/Plugin/TraceForeignCalls.hs b/src/Plugin/TraceForeignCalls.hs index 7d82fc1..feaa903 100644 --- a/src/Plugin/TraceForeignCalls.hs +++ b/src/Plugin/TraceForeignCalls.hs @@ -18,6 +18,7 @@ import GHC.Types.SourceText import Plugin.TraceForeignCalls.Instrument import Plugin.TraceForeignCalls.Options import Plugin.TraceForeignCalls.Util.GHC +import GHC.Types.ForeignCall {------------------------------------------------------------------------------- Top-level @@ -101,11 +102,45 @@ reconstructForeignDecl ReplacedForeignImport { , fd_fi = rfiForeignImport } --- | Description of the foreign function to include in the eventlog --- --- TODO: include more info -eventLogDescription :: ReplacedForeignImport -> String -eventLogDescription ReplacedForeignImport{rfiOriginalName} = concat [ +-- | Eventlog description for calling the foreign function +eventLogCall :: ReplacedForeignImport -> String +eventLogCall ReplacedForeignImport{ + rfiOriginalName + , rfiForeignImport + } = concat [ + occNameString . nameOccName . unLoc $ rfiOriginalName + , " (" + , strCallConv + , " " + , strSafety + , " " + , show (strHeader ++ strCLabel) + , ")" + ] + where + strCallConv, strSafety, strHeader, strCLabel :: String + (strCallConv, strSafety, strHeader, strCLabel) = + case rfiForeignImport of + CImport _sourceText cCallConv safety mHeader cImportSpec -> ( + showSDocUnsafe $ ppr cCallConv + , showSDocUnsafe $ ppr safety + , case mHeader of + Just (Header _sourceText hdr) -> unpackFS hdr ++ " " + Nothing -> "" + , case cImportSpec of + CLabel cLabel -> + unpackFS cLabel + CFunction (StaticTarget _sourceText cLabel _ _) -> + unpackFS cLabel + CFunction DynamicTarget -> + "" + CWrapper -> + "" + ) + +-- | Eventlog description for the return of the foreign function +eventLogReturn :: ReplacedForeignImport -> String +eventLogReturn ReplacedForeignImport{rfiOriginalName} = concat [ occNameString . nameOccName . unLoc $ rfiOriginalName ] @@ -221,15 +256,15 @@ mkWrapperBody :: mkWrapperBody rfi@ReplacedForeignImport {rfiSuffixedName, rfiSigType} = do traceEventIO <- findName nameTraceEventIO let callTraceEventIO :: String -> ExprLStmt GhcRn - callTraceEventIO label = noLocA $ + callTraceEventIO arg = noLocA $ BodyStmt NoExtField ( noLocA $ HsApp EpAnnNotUsed (noLocA $ HsVar NoExtField (noLocA traceEventIO)) - ( noLocA $ HsLit EpAnnNotUsed $ HsString NoSourceText $ - fsLit $ label ++ eventLogDescription rfi + ( noLocA $ HsLit EpAnnNotUsed $ + HsString NoSourceText (fsLit arg) ) ) regularBodyStmt @@ -261,7 +296,8 @@ mkWrapperBody rfi@ReplacedForeignImport {rfiSuffixedName, rfiSigType} = do result <- uniqInternalName "result" let doBlock :: LHsExpr GhcRn doBlock = noLocA $ HsDo NoExtField (DoExpr Nothing) $ noLocA [ - callTraceEventIO "start foreign call " + callTraceEventIO $ "trace-foreign-calls: call " + ++ eventLogCall rfi , noLocA $ BindStmt regularBindStmt @@ -270,7 +306,8 @@ mkWrapperBody rfi@ReplacedForeignImport {rfiSuffixedName, rfiSigType} = do Just _ -> callUninstrumented Nothing -> callEvaluate callUninstrumented ) - , callTraceEventIO "stop foreign call " + , callTraceEventIO $ "trace-foreign-calls: return " + ++ eventLogReturn rfi , noLocA $ LastStmt NoExtField diff --git a/trace-foreign-calls.cabal b/trace-foreign-calls.cabal index 45bb981..b3a3012 100644 --- a/trace-foreign-calls.cabal +++ b/trace-foreign-calls.cabal @@ -58,7 +58,6 @@ library , ghc >= 9.6 && < 9.7 , template-haskell >= 2.20 && < 2.21 , transformers >= 0.6 && < 0.7 - , recover-rtti test-suite test-trace-foreign-calls import: