diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index c91c6bd..45d7eef 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -33,6 +33,11 @@ jobs: compilerVersion: 9.12.1 setup-method: ghcup allow-failure: false + - compiler: ghc-9.10.1 + compilerKind: ghc + compilerVersion: 9.10.1 + setup-method: ghcup + allow-failure: false fail-fast: false steps: - name: apt-get install diff --git a/README.md b/README.md index 2e402d8..27f8c80 100644 --- a/README.md +++ b/README.md @@ -36,7 +36,8 @@ processing the event log yourself or by using ## Limitations and future work -* Requires GHC 9.12 +* Requires GHC 9.10 or 9.12 + (profiling of _pure_ foreign imports requires ghc 9.12). * Standard time profiling tools can _NOT_ be used on the eventlog. * It is not possible to profile Haskell functions and FFI functions at the same time. diff --git a/example-pkg-A/example-pkg-A.cabal b/example-pkg-A/example-pkg-A.cabal index 3ad4982..7bf3e4f 100644 --- a/example-pkg-A/example-pkg-A.cabal +++ b/example-pkg-A/example-pkg-A.cabal @@ -12,14 +12,14 @@ category: Development build-type: Simple extra-source-files: cbits/cbits.h cbits/cbits.c -tested-with: GHC ==9.12.1 +tested-with: GHC ==9.10.1 + GHC ==9.12.1 common lang ghc-options: -Wall build-depends: - -- For now we don't support ghc < 9.12 - base >= 4.21 && < 4.22 + base >= 4.20 && < 4.22 default-language: GHC2021 diff --git a/example-pkg-B/example-pkg-B.cabal b/example-pkg-B/example-pkg-B.cabal index 8fa2ea0..01f8749 100644 --- a/example-pkg-B/example-pkg-B.cabal +++ b/example-pkg-B/example-pkg-B.cabal @@ -12,14 +12,14 @@ author: Edsko de Vries maintainer: edsko@well-typed.com category: Development build-type: Simple -tested-with: GHC ==9.12.1 +tested-with: GHC ==9.10.1 + GHC ==9.12.1 common lang ghc-options: -Wall build-depends: - -- For now we don't support ghc < 9.12 - base >= 4.21 && < 4.22 + base >= 4.20 && < 4.22 default-language: GHC2021 diff --git a/trace-foreign-calls/src/Plugin/TraceForeignCalls.hs b/trace-foreign-calls/src/Plugin/TraceForeignCalls.hs index 159b3d9..d8f3697 100644 --- a/trace-foreign-calls/src/Plugin/TraceForeignCalls.hs +++ b/trace-foreign-calls/src/Plugin/TraceForeignCalls.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Plugin.TraceForeignCalls (plugin) where @@ -20,17 +21,20 @@ import GHC.Tc.Utils.Monad qualified as TC import GHC.Types.ForeignCall qualified as Foreign import GHC.Types.SourceFile (isHsBootOrSig) +import Plugin.TraceForeignCalls.GHC.Shim +import Plugin.TraceForeignCalls.GHC.Util import Plugin.TraceForeignCalls.Instrument import Plugin.TraceForeignCalls.Options -import Plugin.TraceForeignCalls.Util.GHC {------------------------------------------------------------------------------- Top-level References: - - https://downloads.haskell.org/ghc/9.12.1/docs/users_guide/extending_ghc.html#compiler-plugins + - https://hackage.haskell.org/package/ghc-9.10.1 - https://hackage.haskell.org/package/ghc-9.12.1 + + - https://downloads.haskell.org/ghc/9.12.1/docs/users_guide/extending_ghc.html#compiler-plugins - https://downloads.haskell.org/ghc/9.12.1/docs/users_guide/exts/ffi.html - https://www.haskell.org/onlinereport/haskell2010/haskellch8.html -------------------------------------------------------------------------------} @@ -69,7 +73,7 @@ processRenamed options tcGblEnv group processGroup :: HsGroup GhcRn -> Instrument (HsGroup GhcRn) processGroup group@HsGroup{ hs_fords - , hs_valds = XValBindsLR (NValBinds bindingGroups sigs) + , hs_valds = existingBindings } = do mTraceCCS <- findName nameTraceCCS @@ -90,13 +94,11 @@ processGroup group@HsGroup{ , map reconstructForeignDecl imports ] , hs_valds = - XValBindsLR $ - NValBinds - (map trivialBindingGroup newValues ++ bindingGroups) - ( newSigs ++ sigs ) + extendValBinds + (map trivialBindingGroup newValues) + newSigs + existingBindings } -processGroup HsGroup{hs_valds = ValBinds{}} = - error "impossible (ValBinds is only used before renaming)" {------------------------------------------------------------------------------- Foreign declarations @@ -256,7 +258,6 @@ renameForeignImport (L l n) = do mkWrapper :: ReplacedForeignImport -> Instrument (LSig GhcRn, LHsBind GhcRn) mkWrapper rfi@ReplacedForeignImport { rfiOriginalName - , rfiSuffixedName , rfiSigType = L _ sigType } = do (args, body) <- mkWrapperBody rfi @@ -272,36 +273,7 @@ mkWrapper rfi@ReplacedForeignImport { sig_body = sig_body sigType } } - , noLocValue $ - FunBind { - fun_ext = mkNameSet [unLoc rfiSuffixedName] - , fun_id = rfiOriginalName - , fun_matches = MG { - mg_ext = Generated OtherExpansion SkipPmc - , mg_alts = noLocValue . map noLocValue $ [ - Match { - m_ext = noValue - , m_ctxt = FunRhs { - mc_fun = rfiOriginalName - , mc_fixity = Prefix - , mc_strictness = NoSrcStrict - , mc_an = AnnFunRhs NoEpTok [] [] - } - , m_pats = noLocValue $ map namedVarPat args - , m_grhss = GRHSs { - grhssExt = emptyComments - , grhssGRHSs = map noLocValue [ - GRHS - noValue - [] -- guards - body - ] - , grhssLocalBinds = emptyWhereClause - } - } - ] - } - } + , mkSimpleFunBind rfiOriginalName [] args body ) -- | Make the body for the wrapper @@ -436,12 +408,9 @@ mkEventLogReturn ReplacedForeignImport{rfiOriginalName} = ] {------------------------------------------------------------------------------- - Auxiliary + Auxiliary: constructions with fresh names -------------------------------------------------------------------------------} -trivialBindingGroup :: LHsBind GhcRn -> (RecFlag, [LHsBind GhcRn]) -trivialBindingGroup binding = (NonRecursive, [binding]) - -- | Create unique name for each argument of the function uniqArgsFor :: LHsType GhcRn -> Instrument [Name] uniqArgsFor = go [] . unLoc @@ -455,57 +424,6 @@ uniqArgsFor = go [] . unLoc go acc _otherTy = return $ reverse acc --- | Check if a function signature returns something in the @IO@ monad -checkIsIO :: LHsSigType GhcRn -> Bool -checkIsIO = go . unLoc . sig_body . unLoc - where - go :: HsType GhcRn -> Bool - go HsForAllTy{hst_body} = go (unLoc hst_body) - go HsQualTy{hst_body} = go (unLoc hst_body) - go (HsFunTy _ _ _ rhs) = go (unLoc rhs) - go ty = - case ty of - HsAppTy _ (L _ (HsTyVar _ _ (L _ io))) _ | io == Names.ioTyConName -> - True - _otherwise -> - False - -emptyWhereClause :: HsLocalBinds GhcRn -emptyWhereClause = EmptyLocalBinds noValue - -ubstringExpr :: String -> LHsExpr GhcRn -ubstringExpr = noLocValue . HsLit noValue . mkHsStringPrimLit . fsLit - -callLNamedFn :: LIdP GhcRn -> [LHsExpr GhcRn] -> LHsExpr GhcRn -callLNamedFn fn args = - mkHsApps (noLocValue $ HsVar noValue fn) $ - map mkLHsPar args - -callNamedFn :: IdP GhcRn -> [LHsExpr GhcRn] -> LHsExpr GhcRn -callNamedFn = callLNamedFn . noLocValue - -namedLVar :: LIdP GhcRn -> LHsExpr GhcRn -namedLVar = noLocValue . HsVar noValue - -namedVar :: IdP GhcRn -> LHsExpr GhcRn -namedVar = namedLVar . noLocValue - -namedVarPat :: Name -> LPat GhcRn -namedVarPat = noLocValue . VarPat noValue . noLocValue - --- | @IO ()@ -ioUnit :: LHsType GhcRn -ioUnit = - nlHsAppTy - (nlHsTyVar NotPromoted Names.ioTyConName) - (nlHsTyVar NotPromoted (tyConName unitTyCon)) - -{------------------------------------------------------------------------------- - Auxiliary: construct IO calls --------------------------------------------------------------------------------} - -type RealWorld = LHsExpr GhcRn - -- | Bind to value without evaluating it -- -- Given @e@, constructs @@ -534,11 +452,16 @@ let_ xNameHint e k = do } return $ noLocValue $ HsLet noValue ( - HsValBinds noValue $ - XValBindsLR $ NValBinds [(NonRecursive, [binding])] [] + HsValBinds noValue $ mkValBinds [(NonRecursive, [binding])] [] ) $ cont +{------------------------------------------------------------------------------- + Auxiliary: construct IO calls +-------------------------------------------------------------------------------} + +type RealWorld = LHsExpr GhcRn + -- | Unwrap @IO@ action -- -- Given @io@ and continuation @k@, constructs @@ -580,7 +503,7 @@ wrapIO f = do body <- f (namedVar s) return $ mkHsApp (namedVar Names.ioDataConName) - $ mkHsLam (noLocValue [namedVarPat s]) + $ mkLambda [namedVarPat s] $ body -- | Similar to 'wrapIO', but in a pure context (essentially @unsafePerformIO@) @@ -599,7 +522,7 @@ runIO f = do runRW <- findName nameRunRW noDup <- findName nameNoDuplicate body <- f $ callNamedFn noDup [namedVar s] - let scrut = callNamedFn runRW [mkHsLam (noLocValue [namedVarPat s]) body] + let scrut = callNamedFn runRW [mkLambda [namedVarPat s] body] return $ noLocValue $ HsCase CaseAlt scrut $ mkMatchGroup (Generated OtherExpansion SkipPmc) . noLocValue . pure @@ -728,4 +651,3 @@ callNamedIO f args s = do fName <- findName f return $ callNamedFn fName (args ++ [s]) - diff --git a/trace-foreign-calls/src/Plugin/TraceForeignCalls/GHC/Shim.hs b/trace-foreign-calls/src/Plugin/TraceForeignCalls/GHC/Shim.hs new file mode 100644 index 0000000..d1f7930 --- /dev/null +++ b/trace-foreign-calls/src/Plugin/TraceForeignCalls/GHC/Shim.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} + +module Plugin.TraceForeignCalls.GHC.Shim ( + mkLambda + , mkSimpleFunRhs + , mkValBinds + , extendValBinds + , mkMatch + , mkSimpleFunBind + , checkHaveSeq + ) where + +import Data.Bifunctor (second) +import Data.Maybe (isJust) + +import GHC +import GHC.Builtin.Names qualified as Names +import GHC.Data.Bag (listToBag) +import GHC.Driver.Env (hsc_HUG) +import GHC.Tc.Utils.Monad (TcGblEnv) +import GHC.Tc.Utils.Monad qualified as TC +import GHC.Types.Basic +import GHC.Types.Name.Set (mkNameSet) +import GHC.Unit.Env (lookupHugByModule) +import GHC.Unit.Types (ghcInternalUnit) + +import Plugin.TraceForeignCalls.GHC.Util + +mkLambda :: [LPat GhcRn] -> LHsExpr GhcRn -> LHsExpr GhcRn +#if MIN_VERSION_ghc(9,12,1) +mkLambda = mkHsLam . noLocValue +#else +mkLambda = mkHsLam +#endif + +mkSimpleFunRhs :: LIdP GhcRn -> HsMatchContext (LIdP GhcRn) +mkSimpleFunRhs name = FunRhs { + mc_fun = name + , mc_fixity = Prefix + , mc_strictness = NoSrcStrict +#if MIN_VERSION_ghc(9,12,1) + , mc_an = AnnFunRhs NoEpTok [] [] +#endif + } + +mkValBinds :: [(RecFlag, [LHsBind GhcRn])] -> [LSig GhcRn] -> HsValBinds GhcRn +#if MIN_VERSION_ghc(9,12,1) +mkValBinds bindingGroups sigs = + XValBindsLR $ + NValBinds bindingGroups sigs +#else +mkValBinds bindingGroups sigs = + XValBindsLR $ + NValBinds (map (second listToBag) bindingGroups) sigs +#endif + +extendValBinds :: + [(RecFlag, [LHsBind GhcRn])] + -> [LSig GhcRn] + -> HsValBinds GhcRn -> HsValBinds GhcRn +#if MIN_VERSION_ghc(9,12,1) +extendValBinds newBindingGroups newSigs old = + case old of + XValBindsLR (NValBinds oldGroups oldSigs) -> + XValBindsLR $ + NValBinds + (oldGroups ++ newBindingGroups) + (oldSigs ++ newSigs) + ValBinds{} -> + error "impossible (ValBinds is only used before renaming)" +#else +extendValBinds newBindingGroups newSigs old = + case old of + XValBindsLR (NValBinds oldGroups oldSigs) -> + XValBindsLR $ + NValBinds + (oldGroups ++ map (second listToBag) newBindingGroups) + (oldSigs ++ newSigs) + ValBinds{} -> + error "impossible (ValBinds is only used before renaming)" +#endif + +mkSimpleFunBind :: + LIdP GhcRn -- ^ Name of the function + -> [Name] -- ^ Free variables in the body (excluding imports) + -> [Name] -- ^ Arguments + -> LHsExpr GhcRn -- ^ Body + -> LHsBind GhcRn +mkSimpleFunBind name freeVars args body = noLocValue $ FunBind { + fun_ext = mkNameSet freeVars + , fun_id = name + , fun_matches = MG { + mg_ext = Generated OtherExpansion SkipPmc + , mg_alts = noLocValue . map noLocValue $ [ + Match { +#if MIN_VERSION_ghc(9,12,1) + m_ext = noValue +#else + m_ext = noAnn +#endif + , m_ctxt = mkSimpleFunRhs name +#if MIN_VERSION_ghc(9,12,1) + , m_pats = noLocValue $ map namedVarPat args +#else + , m_pats = map namedVarPat args +#endif + , m_grhss = GRHSs { + grhssExt = emptyComments + , grhssGRHSs = map noLocValue [ + GRHS + noValue + [] -- guards + body + ] + , grhssLocalBinds = emptyWhereClause + } + } + ] + } + } + +-- | Check if @seq#@ is available +-- +-- For now we only support the use of @seq#@ (and hence profiling pure +-- functions) for GHC 9.12. +checkHaveSeq :: TcGblEnv -> HscEnv -> Bool +#if MIN_VERSION_ghc_internal(9,1201,0) +checkHaveSeq tcGblEnv hsc = + if moduleUnit (TC.tcg_mod tcGblEnv) == ghcInternalUnit + then isJust $ lookupHugByModule Names.gHC_INTERNAL_IO (hsc_HUG hsc) + else True +#else +checkHaveSeq _ _ = False +#endif + diff --git a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Util/GHC.hs b/trace-foreign-calls/src/Plugin/TraceForeignCalls/GHC/Util.hs similarity index 71% rename from trace-foreign-calls/src/Plugin/TraceForeignCalls/Util/GHC.hs rename to trace-foreign-calls/src/Plugin/TraceForeignCalls/GHC/Util.hs index 3669af5..985dc3c 100644 --- a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Util/GHC.hs +++ b/trace-foreign-calls/src/Plugin/TraceForeignCalls/GHC/Util.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} -module Plugin.TraceForeignCalls.Util.GHC ( +module Plugin.TraceForeignCalls.GHC.Util ( -- * Access to 'HscEnv' HasHscEnv(..) -- * Errors and warnings @@ -14,11 +14,23 @@ module Plugin.TraceForeignCalls.Util.GHC ( -- * Annotations , NoValue(..) , noLocValue + -- * Helpers for constructing bits of the AST + , trivialBindingGroup + , checkIsIO + , emptyWhereClause + , ubstringExpr + , callLNamedFn + , callNamedFn + , namedLVar + , namedVar + , namedVarPat + , ioUnit ) where import GHC hiding (getNamePprCtx) import GHC.Plugins hiding (getNamePprCtx, getHscEnv) +import GHC.Builtin.Names qualified as Names import GHC.Data.IOEnv import GHC.Driver.Config.Diagnostic import GHC.Driver.Errors @@ -163,3 +175,54 @@ instance NoValue AnnSig where instance NoValue EpaLocation where noValue = noAnn +{------------------------------------------------------------------------------- + Helpers for constructing bits of the AST +-------------------------------------------------------------------------------} + +trivialBindingGroup :: LHsBind GhcRn -> (RecFlag, [LHsBind GhcRn]) +trivialBindingGroup binding = (NonRecursive, [binding]) + +-- | Check if a function signature returns something in the @IO@ monad +checkIsIO :: LHsSigType GhcRn -> Bool +checkIsIO = go . unLoc . sig_body . unLoc + where + go :: HsType GhcRn -> Bool + go HsForAllTy{hst_body} = go (unLoc hst_body) + go HsQualTy{hst_body} = go (unLoc hst_body) + go (HsFunTy _ _ _ rhs) = go (unLoc rhs) + go ty = + case ty of + HsAppTy _ (L _ (HsTyVar _ _ (L _ io))) _ | io == Names.ioTyConName -> + True + _otherwise -> + False + +emptyWhereClause :: HsLocalBinds GhcRn +emptyWhereClause = EmptyLocalBinds noValue + +ubstringExpr :: String -> LHsExpr GhcRn +ubstringExpr = noLocValue . HsLit noValue . mkHsStringPrimLit . fsLit + +callLNamedFn :: LIdP GhcRn -> [LHsExpr GhcRn] -> LHsExpr GhcRn +callLNamedFn fn args = + mkHsApps (noLocValue $ HsVar noValue fn) $ + map mkLHsPar args + +callNamedFn :: IdP GhcRn -> [LHsExpr GhcRn] -> LHsExpr GhcRn +callNamedFn = callLNamedFn . noLocValue + +namedLVar :: LIdP GhcRn -> LHsExpr GhcRn +namedLVar = noLocValue . HsVar noValue + +namedVar :: IdP GhcRn -> LHsExpr GhcRn +namedVar = namedLVar . noLocValue + +namedVarPat :: Name -> LPat GhcRn +namedVarPat = noLocValue . VarPat noValue . noLocValue + +-- | @IO ()@ +ioUnit :: LHsType GhcRn +ioUnit = + nlHsAppTy + (nlHsTyVar NotPromoted Names.ioTyConName) + (nlHsTyVar NotPromoted (tyConName unitTyCon)) diff --git a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Instrument.hs b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Instrument.hs index 1782a27..d8ad9e4 100644 --- a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Instrument.hs +++ b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Instrument.hs @@ -13,20 +13,18 @@ module Plugin.TraceForeignCalls.Instrument ( import Control.Monad import Control.Monad.IO.Class -import Data.Maybe (isJust) import GHC import GHC.Plugins hiding (getHscEnv) -import GHC.Builtin.Names qualified as Names import GHC.Platform.Ways (Way(WayProf), hasWay) import GHC.Tc.Utils.Monad (TcM, TcGblEnv) import GHC.Tc.Utils.Monad qualified as TC -import GHC.Unit.Env (lookupHugByModule) import GHC.Utils.Logger (HasLogger(..)) +import Plugin.TraceForeignCalls.GHC.Util +import Plugin.TraceForeignCalls.GHC.Shim import Plugin.TraceForeignCalls.Options -import Plugin.TraceForeignCalls.Util.GHC {------------------------------------------------------------------------------- Definition @@ -175,11 +173,5 @@ mkNames tcGblEnv = do findName :: (Names -> a) -> Instrument a findName f = Wrap $ return . f . tracerEnvNames -checkHaveSeq :: TcGblEnv -> HscEnv -> Bool -checkHaveSeq tcGblEnv hsc = - if moduleUnit (TC.tcg_mod tcGblEnv) == ghcInternalUnit - then isJust $ lookupHugByModule Names.gHC_INTERNAL_IO (hsc_HUG hsc) - else True - checkProfiling :: DynFlags -> Bool checkProfiling df = sccProfilingEnabled df && ways df `hasWay` WayProf diff --git a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Options.hs b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Options.hs index 2447e03..a626ab3 100644 --- a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Options.hs +++ b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Options.hs @@ -12,7 +12,7 @@ import Data.String import GHC import GHC.Utils.Outputable -import Plugin.TraceForeignCalls.Util.GHC +import Plugin.TraceForeignCalls.GHC.Util {------------------------------------------------------------------------------- Definition diff --git a/trace-foreign-calls/trace-foreign-calls.cabal b/trace-foreign-calls/trace-foreign-calls.cabal index 085c53d..2f8a4a9 100644 --- a/trace-foreign-calls/trace-foreign-calls.cabal +++ b/trace-foreign-calls/trace-foreign-calls.cabal @@ -17,7 +17,8 @@ build-type: Simple extra-doc-files: CHANGELOG.md extra-source-files: test-cbits/test_cbits.h test-cbits/test_cbits.c -tested-with: GHC ==9.12.1 +tested-with: GHC ==9.10.1 + GHC ==9.12.1 source-repository head type: git @@ -25,8 +26,8 @@ source-repository head common lang build-depends: - -- For now we don't support ghc < 9.12 - base >= 4.21 && < 4.22 + -- ghc 9.10 or 9.12 + base >= 4.20 && < 4.22 default-language: GHC2021 ghc-options: @@ -34,7 +35,6 @@ common lang -Wredundant-constraints -Wprepositive-qualified-module -Widentities - -Wunused-packages library import: @@ -44,14 +44,16 @@ library other-modules: Plugin.TraceForeignCalls.Instrument Plugin.TraceForeignCalls.Options - Plugin.TraceForeignCalls.Util.GHC + Plugin.TraceForeignCalls.GHC.Util + Plugin.TraceForeignCalls.GHC.Shim hs-source-dirs: src build-depends: -- dependencies intentionally kept at a minimum -- (we want to be able to build the boot libs with this plugin) - , ghc >= 9.12 && < 9.14 + , ghc >= 9.10 && < 9.14 , ghc-boot + , ghc-internal test-suite test-trace-foreign-calls import: