Skip to content

Commit

Permalink
Merge pull request #6 from well-typed/edsko/hascallstack
Browse files Browse the repository at this point in the history 
`HasCallStack` support
  • Loading branch information
@edsko
edsko authored Apr 24, 2024
2 parents f596891 + f1b2589 commit c6314e8
Show file tree
Hide file tree
Showing 5 changed files with 181 additions and 127 deletions.
30 changes: 21 additions & 9 deletions README.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
..
```

Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -150,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.

205 changes: 118 additions & 87 deletions trace-foreign-calls/src/Plugin/TraceForeignCalls.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 ->
"<dynamic target>"
CWrapper ->
"<wrapper>"
)

-- | 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)
Expand Down Expand Up @@ -205,17 +163,35 @@ 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
EpAnnNotUsed
[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 {
Expand All @@ -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 [
Expand All @@ -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
]
Expand All @@ -329,17 +282,80 @@ 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 ->
"<dynamic target>"
CWrapper ->
"<wrapper>"
)

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

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)
Expand All @@ -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}) =
Expand All @@ -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
Loading

0 comments on commit c6314e8

Please sign in to comment.