From 3de7b8d2a12a61f2f67c6133d2b1fcf2f0e7e1d7 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Wed, 24 Apr 2024 15:42:35 +0200 Subject: [PATCH 1/2] Support HasCallStack --- README.md | 19 +- .../src/Plugin/TraceForeignCalls.hs | 205 ++++++++++-------- .../Plugin/TraceForeignCalls/Instrument.hs | 41 ++-- .../src/Plugin/TraceForeignCalls/Options.hs | 24 +- .../test/Test/TraceForeignCalls/UsePlugin.hs | 8 +- 5 files changed, 173 insertions(+), 124 deletions(-) diff --git a/README.md b/README.md index 64427de..a488306 100644 --- a/README.md +++ b/README.md @@ -26,11 +26,12 @@ see something like this: ``` .. -379677: cap 0: running thread 1 -446746: cap 0: trace-foreign-calls: call someForeignFunInA (capi safe "cbits.h xkcdRandomNumber") -447526: cap 0: stopping thread 1 (making a foreign call) -447746: cap 0: running thread 1 -451726: cap 0: trace-foreign-calls: return someForeignFunInA +397876: cap 0: running thread 1 +491265: cap 0: trace-foreign-calls: call someForeignFunInA (capi safe "cbits.h xkcdRandomNumber") at CallStack (from HasCallStack): + someForeignFunInA, called at src/ExamplePkgB.hs:11:21 in example-pkg-B-0.1.0-inplace:ExamplePkgB +491815: cap 0: stopping thread 1 (making a foreign call) +492165: cap 0: running thread 1 +500755: cap 0: trace-foreign-calls: return someForeignFunInA .. ``` @@ -63,7 +64,7 @@ module header: {-# OPTIONS_GHC -fplugin=Plugin.TraceForeignCalls #-} ``` -## Debugging +## Plugin options If you want to see how the plugin transforms your code, you can add a plugin option @@ -73,6 +74,12 @@ option -fplugin-opt Plugin.TraceForeignCalls:dump-generated #-} ``` +You can disable `HasCallStack` support by setting + +``` +{-# OPTIONS_GHC -fplugin-opt Plugin.TraceForeignCalls:disable-callstack #-} +``` + ## Enabling the plugin on all (transitive) dependencies In an ideal world, we could just create a `cabal.project` file containing diff --git a/trace-foreign-calls/src/Plugin/TraceForeignCalls.hs b/trace-foreign-calls/src/Plugin/TraceForeignCalls.hs index b04bd81..e9fd526 100644 --- a/trace-foreign-calls/src/Plugin/TraceForeignCalls.hs +++ b/trace-foreign-calls/src/Plugin/TraceForeignCalls.hs @@ -103,48 +103,6 @@ reconstructForeignDecl ReplacedForeignImport { , fd_fi = rfiForeignImport } --- | 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 - ] - processForeignDecl :: LForeignDecl GhcRn -> Instrument (Either (LForeignDecl GhcRn) ReplacedForeignImport) @@ -205,9 +163,15 @@ mkWrapper :: ReplacedForeignImport -> Instrument (LSig GhcRn, LHsBind GhcRn) mkWrapper rfi@ReplacedForeignImport { rfiOriginalName , rfiSuffixedName - , rfiSigType + , rfiSigType = L _ sigType } = do - (args, body) <- mkWrapperBody rfi + (args, body) <- mkWrapperBody rfi + + mHasCallStack :: Maybe (LHsType GhcRn) <- + whenOption (not . optionsDisableCallStack) $ do + hasCallStack <- findName nameHasCallStack + return $ noLocA $ HsTyVar EpAnnNotUsed NotPromoted (noLocA hasCallStack) + return ( noLocA $ TypeSig @@ -215,7 +179,19 @@ mkWrapper rfi@ReplacedForeignImport { [rfiOriginalName] HsWC { hswc_ext = [] - , hswc_body = rfiSigType + , hswc_body = noLocA $ sigType { + -- Signature as the original import but with HasCallStack + sig_body = + case mHasCallStack of + Nothing -> + sig_body sigType + Just hasCallStack -> noLocA $ + HsQualTy { + hst_xqual = NoExtField + , hst_ctxt = noLocA [hasCallStack] + , hst_body = sig_body sigType + } + } } , noLocA $ FunBind { @@ -231,7 +207,7 @@ mkWrapper rfi@ReplacedForeignImport { , mc_fixity = Prefix , mc_strictness = NoSrcStrict } - , m_pats = map (noLocA . VarPat NoExtField) args + , m_pats = map namedVarPat args , m_grhss = GRHSs { grhssExt = emptyComments , grhssGRHSs = map noLocA [ @@ -253,71 +229,48 @@ mkWrapper rfi@ReplacedForeignImport { -- Also returns the arguments to the wrapper mkWrapperBody :: ReplacedForeignImport - -> Instrument ([LIdP GhcRn], LHsExpr GhcRn) + -> Instrument ([Name], LHsExpr GhcRn) mkWrapperBody rfi@ReplacedForeignImport {rfiSuffixedName, rfiSigType} = do traceEventIO <- findName nameTraceEventIO - let callTraceEventIO :: String -> ExprLStmt GhcRn + let callTraceEventIO :: LHsExpr GhcRn -> ExprLStmt GhcRn callTraceEventIO arg = noLocA $ BodyStmt NoExtField - ( noLocA $ - HsApp - EpAnnNotUsed - (noLocA $ HsVar NoExtField (noLocA traceEventIO)) - ( noLocA $ HsLit EpAnnNotUsed $ - HsString NoSourceText (fsLit arg) - ) - ) + (callNamedFn traceEventIO [arg]) regularBodyStmt NoSyntaxExprRn evaluate <- findName nameEvaluate let callEvaluate :: LHsExpr GhcRn -> LHsExpr GhcRn - callEvaluate arg = noLocA $ - HsApp - EpAnnNotUsed - (noLocA $ HsVar NoExtField (noLocA evaluate)) - arg + callEvaluate arg = callNamedFn evaluate [arg] unsafePerformIO <- findName nameUnsafePerformIO let callUnsafePerformIO :: LHsExpr GhcRn -> LHsExpr GhcRn - callUnsafePerformIO arg = noLocA $ - HsApp - EpAnnNotUsed - (noLocA $ HsVar NoExtField (noLocA unsafePerformIO)) - arg + callUnsafePerformIO arg = callNamedFn unsafePerformIO [arg] (args, resultTy) <- uniqArgsFor (sig_body $ unLoc rfiSigType) let callUninstrumented :: LHsExpr GhcRn - callUninstrumented = - mkHsApps - (noLocA $ HsVar NoExtField rfiSuffixedName) - (map (noLocA . HsVar NoExtField) args) + callUninstrumented = callLNamedFn rfiSuffixedName (map namedVar args) - result <- uniqInternalName "result" + result <- uniqInternalName "result" + eventLogCall <- mkEventLogCall rfi + eventLogReturn <- mkEventLogReturn rfi let doBlock :: LHsExpr GhcRn doBlock = noLocA $ HsDo NoExtField (DoExpr Nothing) $ noLocA [ - callTraceEventIO $ "trace-foreign-calls: call " - ++ eventLogCall rfi + callTraceEventIO eventLogCall , noLocA $ BindStmt regularBindStmt - (noLocA $ VarPat NoExtField result) + (namedVarPat result) ( case checkIsIO resultTy of Just _ -> callUninstrumented Nothing -> callEvaluate callUninstrumented ) - , callTraceEventIO $ "trace-foreign-calls: return " - ++ eventLogReturn rfi + , callTraceEventIO eventLogReturn , noLocA $ LastStmt NoExtField - ( noLocA $ - HsApp - EpAnnNotUsed - (noLocA $ HsVar NoExtField (noLocA returnMName)) - (noLocA $ HsVar NoExtField result) - ) + (callNamedFn returnMName [namedVar result]) Nothing NoSyntaxExprRn ] @@ -329,6 +282,69 @@ mkWrapperBody rfi@ReplacedForeignImport {rfiSuffixedName, rfiSigType} = do Nothing -> callUnsafePerformIO doBlock ) +{------------------------------------------------------------------------------- + Generate eventlog events +-------------------------------------------------------------------------------} + +-- | Eventlog description for calling the foreign function +mkEventLogCall :: ReplacedForeignImport -> Instrument (LHsExpr GhcRn) +mkEventLogCall ReplacedForeignImport{ + rfiOriginalName + , rfiForeignImport + } = do + noCallStack <- asksOption optionsDisableCallStack + + if noCallStack then + return $ stringExpr prefix + else do + callStack <- findName nameCallStack + prettyCalllStack <- findName namePrettyCallStack + return $ callNamedFn appendName [ + stringExpr (prefix ++ " at ") + , callNamedFn prettyCalllStack [namedVar callStack] + ] + where + prefix :: String + prefix = concat [ + "trace-foreign-calls: call " + , occNameString . nameOccName . unLoc $ rfiOriginalName + , " (" + , strCallConv + , " " + , strSafety + , " " + , show (strHeader ++ strCLabel) + , ")" + ] + + 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 +mkEventLogReturn :: ReplacedForeignImport -> Instrument (LHsExpr GhcRn) +mkEventLogReturn ReplacedForeignImport{rfiOriginalName} = do + return $ stringExpr $ concat [ + "trace-foreign-calls: return " + , occNameString . nameOccName . unLoc $ rfiOriginalName + ] + {------------------------------------------------------------------------------- Auxiliary -------------------------------------------------------------------------------} @@ -336,10 +352,10 @@ mkWrapperBody rfi@ReplacedForeignImport {rfiSuffixedName, rfiSigType} = do trivialBindingGroup :: LHsBind GhcRn -> (RecFlag, Bag (LHsBind GhcRn)) trivialBindingGroup binding = (NonRecursive, unitBag binding) -uniqInternalName :: String -> Instrument (LIdP GhcRn) +uniqInternalName :: String -> Instrument Name uniqInternalName n = do resultUniq <- getUniqueM - return $ noLocA $ mkInternalName resultUniq (mkVarOcc n) noSrcSpan + return $ mkInternalName resultUniq (mkVarOcc n) noSrcSpan regularBodyStmt :: SyntaxExprRn regularBodyStmt = SyntaxExprRn $ HsVar NoExtField (noLocA thenMName) @@ -354,13 +370,13 @@ regularBindStmt = -- | Create unique name for each argument of the function -- -- Also returns the result type. -uniqArgsFor :: LHsType GhcRn -> Instrument ([LIdP GhcRn], LHsType GhcRn) +uniqArgsFor :: LHsType GhcRn -> Instrument ([Name], LHsType GhcRn) uniqArgsFor = go [] where go :: - [LIdP GhcRn] + [Name] -> LHsType GhcRn - -> Instrument ([LIdP GhcRn], LHsType GhcRn) + -> Instrument ([Name], LHsType GhcRn) go acc (L _ HsForAllTy{hst_body}) = go acc hst_body go acc (L _ HsQualTy{hst_body}) = @@ -382,3 +398,18 @@ checkIsIO (L _ ty) = emptyWhereClause :: HsLocalBinds GhcRn emptyWhereClause = EmptyLocalBinds NoExtField + +stringExpr :: String -> LHsExpr GhcRn +stringExpr = noLocA . HsLit EpAnnNotUsed . HsString NoSourceText . fsLit + +callLNamedFn :: LIdP GhcRn -> [LHsExpr GhcRn] -> LHsExpr GhcRn +callLNamedFn fn args = mkHsApps (noLocA $ HsVar NoExtField fn) args + +callNamedFn :: Name -> [LHsExpr GhcRn] -> LHsExpr GhcRn +callNamedFn = callLNamedFn . noLocA + +namedVar :: Name -> LHsExpr GhcRn +namedVar = noLocA . HsVar NoExtField . noLocA + +namedVarPat :: Name -> LPat GhcRn +namedVarPat = noLocA . VarPat NoExtField . noLocA \ No newline at end of file diff --git a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Instrument.hs b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Instrument.hs index dd91b7c..d40660f 100644 --- a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Instrument.hs +++ b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Instrument.hs @@ -37,6 +37,7 @@ import Plugin.TraceForeignCalls.Util.GHC import Debug.Trace qualified import Control.Exception qualified import System.IO.Unsafe qualified +import GHC.Stack qualified {------------------------------------------------------------------------------- Definition @@ -71,12 +72,11 @@ liftTcM = Wrap . lift runInstrument :: forall a. [String] -> Instrument a -> TcM a runInstrument rawOptions ma = do tracerEnvOptions <- parseOptions rawOptions - tracerEnvNames <- initNames let tracerEnv :: TracerEnv tracerEnv = TracerEnv { tracerEnvOptions - , tracerEnvNames + , tracerEnvNames = mkNames } runReaderT (unwrap ma) tracerEnv @@ -111,24 +111,29 @@ whenOption_ f = void . whenOption f {------------------------------------------------------------------------------- Names + + We set things up in such a way that we only try to resolve a name when we + actually use it. We could add some caching, but it really doesn't matter. -------------------------------------------------------------------------------} data Names = Names { - nameTraceEventIO :: Name - , nameEvaluate :: Name - , nameUnsafePerformIO :: Name + nameTraceEventIO :: TcM Name + , nameEvaluate :: TcM Name + , nameUnsafePerformIO :: TcM Name + , nameHasCallStack :: TcM Name + , nameCallStack :: TcM Name + , namePrettyCallStack :: TcM Name + } + +mkNames :: Names +mkNames = Names { + nameTraceEventIO = resolveTHName 'Debug.Trace.traceEventIO + , nameEvaluate = resolveTHName 'Control.Exception.evaluate + , nameUnsafePerformIO = resolveTHName 'System.IO.Unsafe.unsafePerformIO + , nameHasCallStack = resolveTHName ''GHC.Stack.HasCallStack + , nameCallStack = resolveTHName 'GHC.Stack.callStack + , namePrettyCallStack = resolveTHName 'GHC.Stack.prettyCallStack } -initNames :: TcM Names -initNames = do - nameTraceEventIO <- resolveTHName 'Debug.Trace.traceEventIO - nameEvaluate <- resolveTHName 'Control.Exception.evaluate - nameUnsafePerformIO <- resolveTHName 'System.IO.Unsafe.unsafePerformIO - return Names { - nameTraceEventIO - , nameEvaluate - , nameUnsafePerformIO - } - -findName :: (Names -> a) -> Instrument a -findName f = Wrap $ asks (f . tracerEnvNames) \ No newline at end of file +findName :: (Names -> TcM Name) -> Instrument Name +findName f = Wrap $ ReaderT $ f . tracerEnvNames diff --git a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Options.hs b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Options.hs index f06cdd2..e812ecc 100644 --- a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Options.hs +++ b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Options.hs @@ -22,14 +22,18 @@ data Options = Options { -- | Dump the generated code optionsDumpGenerated :: Bool - -- | Debugging (of the plugin itself) - , optionsDebug :: Bool + -- | Disable generating HasCallStack constraints + -- + -- By default the generated wrappers have a 'HasCallStack' constraint, + -- which is used to add additional info into the eventlog. For some + -- applications however this may cause problems. + , optionsDisableCallStack :: Bool } defaultOptions :: Options defaultOptions = Options { - optionsDumpGenerated = False - , optionsDebug = False + optionsDumpGenerated = False + , optionsDisableCallStack = False } {------------------------------------------------------------------------------- @@ -40,10 +44,10 @@ parseOptions :: forall m. HasHscEnv m => [String] -> m Options parseOptions = ($ defaultOptions) . foldr (>=>) return . map aux where aux :: String -> Options -> m Options - aux "dump-generated" opts = return $ opts { optionsDumpGenerated = True } - aux "debug" opts = return $ opts { optionsDebug = True } - aux opt _ = throwSimpleError noSrcSpan $ hcat [ - "Unexpected option " - , fromString (show opt) - ] + aux "dump-generated" opts = return $ opts { optionsDumpGenerated = True } + aux "disable-callstack" opts = return $ opts { optionsDisableCallStack = True } + aux opt _ = throwSimpleError noSrcSpan $ hcat [ + "Unexpected option " + , fromString (show opt) + ] diff --git a/trace-foreign-calls/test/Test/TraceForeignCalls/UsePlugin.hs b/trace-foreign-calls/test/Test/TraceForeignCalls/UsePlugin.hs index 0abbb20..0dfbab4 100644 --- a/trace-foreign-calls/test/Test/TraceForeignCalls/UsePlugin.hs +++ b/trace-foreign-calls/test/Test/TraceForeignCalls/UsePlugin.hs @@ -1,6 +1,8 @@ --- {-# OPTIONS_GHC -fplugin=Plugin.TraceForeignCalls --- -fplugin-opt Plugin.TraceForeignCalls:dump-generated #-} -{-# OPTIONS_GHC -fplugin=Plugin.TraceForeignCalls #-} +{-# OPTIONS_GHC -fplugin=Plugin.TraceForeignCalls + -fplugin-opt Plugin.TraceForeignCalls:dump-generated +#-} +-- -fplugin-opt Plugin.TraceForeignCalls:disable-callstack +-- {-# OPTIONS_GHC -fplugin=Plugin.TraceForeignCalls #-} module Test.TraceForeignCalls.UsePlugin ( -- * IO functions From f1b2589c7948a4d9eb1ba1f323107e3e14b0f9bb Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Wed, 24 Apr 2024 15:44:08 +0200 Subject: [PATCH 2/2] Mention `cc-options` --- README.md | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/README.md b/README.md index a488306..763102d 100644 --- a/README.md +++ b/README.md @@ -157,7 +157,12 @@ Loading static libraries is not supported in this configuration. Try using a dynamic library instead. ``` -Currently the only known workaround is to simply remove this line from the -`.cabal` file; it does not appear to be necessary on Linux. See -[crypton#32](https://github.com/kazu-yamamoto/crypton/pull/32) for an example. +Currently the only known workaround is patch such packages and replace this with + +```cabal +cc-options: -pthread +``` + +An example is `crypton`, +[crypton#33](https://github.com/kazu-yamamoto/crypton/pull/33) for details.