ghc-dump-core 0.1.2.0 → 0.2.1.0

raw patch · 4 files changed

+193/−43 lines, 4 filesdep ~basedep ~ghcPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, ghc

API changes (from Hackage documentation)

Files

• GhcDump/Ast.hs +28/−1
• GhcDump/Convert.hs +108/−26
• GhcDump/Plugin.hs +43/−10
• ghc-dump-core.cabal +14/−6

@@ -1,5 +1,7 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+ module GhcDump.Ast where  import GHC.Generics@@ -10,7 +12,11 @@ import Codec.Serialise import qualified Data.Text as T +#if MIN_VERSION_ghc(9,0,0)+import GHC.Types.Unique (mkUnique)+#else import Unique (mkUnique)+#endif import Prelude  data Unique = Unique !Char !Int@@ -40,6 +46,10 @@                deriving (Eq, Ord, Generic, Show) instance Serialise Binder +isTyBinder :: Binder -> Bool+isTyBinder (Bndr (TyBinder{})) = True+isTyBinder _ = False+ binderUniqueName :: Binder -> T.Text binderUniqueName (Bndr b) =     binderName b <> T.pack "_" <> T.pack (show u)@@ -179,6 +189,7 @@     | ELam bndr (Expr' bndr var)     | ELet [(bndr, Expr' bndr var)] (Expr' bndr var)     | ECase (Expr' bndr var) bndr [Alt' bndr var]+    | ETick Tick (Expr' bndr var)     | EType (Type' bndr var)     | ECoercion     deriving (Eq, Ord, Generic, Show)@@ -199,6 +210,22 @@             | AltDefault             deriving (Eq, Ord, Generic, Show) instance Serialise AltCon++data LineCol = LineCol { row, column :: !Int }+            deriving (Eq, Ord, Generic, Show)+instance Serialise LineCol++data SrcSpan = SrcSpan { spanFile  :: !T.Text+                       , spanStart :: !LineCol+                       , spanEnd   :: !LineCol+                       }+                  deriving (Eq, Ord, Generic, Show)+instance Serialise SrcSpan++data Tick = SourceNote { sourceTickSpan :: !SrcSpan+                       }+                  deriving (Eq, Ord, Generic, Show)+instance Serialise Tick  type STopBinding = TopBinding' SBinder BinderId type TopBinding = TopBinding' Binder Binder

@@ -1,10 +1,47 @@ {-# LANGUAGE CPP #-}-module GhcDump.Convert where+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE NamedFieldPuns #-} +module GhcDump.Convert (cvtModule) where+ import Data.Bifunctor import qualified Data.Text as T import qualified Data.Text.Encoding as TE +#if MIN_VERSION_ghc(9,0,0)+import GHC.Types.Literal (Literal(..))+import qualified GHC.Types.Literal as Literal+import GHC.Types.Var (Var(..))+import qualified GHC.Types.Var as Var+import GHC.Types.Id (isFCallId)+import GHC.Unit.Module as Module (moduleName)+import GHC.Unit.Module.Name as Module (ModuleName, moduleNameFS)+import GHC.Types.Name (getOccName, occNameFS, OccName, getName, nameModule_maybe)+import qualified GHC.Types.Id.Info as IdInfo+import qualified GHC.Types.Basic as OccInfo (OccInfo(..), isStrongLoopBreaker)+import qualified GHC.Core.Stats as CoreStats+import qualified GHC.Core as CoreSyn+import GHC.Core (Expr(..), CoreExpr, Bind(..), CoreAlt, CoreBind, AltCon(..))+#if MIN_VERSION_ghc(9,2,0)+import GHC.Types.Tickish as CoreSyn (GenTickish(..))+import GHC.Unit.Module.ModGuts (ModGuts(..))+import GHC.Utils.Outputable (ppr, SDoc)+import GHC.Driver.Ppr (showSDoc)+#else+import GHC.Driver.Types (ModGuts(..))+import GHC.Utils.Outputable (ppr, showSDoc, SDoc)+#endif+import GHC.Data.FastString (FastString)+import qualified GHC.Data.FastString as FastString+import qualified GHC.Core.TyCo.Rep as Type+import GHC.Core.TyCon as TyCon (TyCon, tyConUnique)+import GHC.Types.Unique as Unique (Unique, getUnique, unpkUnique)+import GHC.Driver.Session (DynFlags)+import qualified GHC.Types.SrcLoc as SrcLoc++#else+ import Literal (Literal(..)) #if MIN_VERSION_ghc(8,6,0) import qualified Literal@@ -15,6 +52,7 @@ import Module (ModuleName, moduleNameFS, moduleName) import Unique (Unique, getUnique, unpkUnique) import Name (getOccName, occNameFS, OccName, getName, nameModule_maybe)+import qualified SrcLoc import qualified IdInfo import qualified BasicTypes as OccInfo (OccInfo(..), isStrongLoopBreaker) #if MIN_VERSION_ghc(8,0,0)@@ -23,7 +61,7 @@ import qualified CoreUtils as CoreStats #endif import qualified CoreSyn-import CoreSyn (Expr(..), CoreExpr, Bind(..), CoreAlt, CoreBind, AltCon(..))+import CoreSyn (Expr(..), CoreExpr, Bind(..), CoreAlt, CoreBind, AltCon(..), Tickish(..)) import HscTypes (ModGuts(..)) import FastString (FastString) import qualified FastString@@ -40,14 +78,21 @@ import TyCon (TyCon, tyConUnique)  import Outputable (ppr, showSDoc, SDoc)-import DynFlags (unsafeGlobalDynFlags)+import DynFlags (DynFlags)+#endif  import GhcDump.Ast as Ast -cvtSDoc :: SDoc -> T.Text-cvtSDoc = T.pack . showSDoc unsafeGlobalDynFlags+import Prelude hiding (span) -fastStringToText :: FastString -> T.Text+data Env = Env { dflags :: DynFlags }++type HasEnv = (?env :: Env)++cvtSDoc :: HasEnv => SDoc -> T.Text+cvtSDoc = T.pack . showSDoc (dflags ?env)++fastStringToText :: HasEnv => FastString -> T.Text fastStringToText = TE.decodeUtf8 #if MIN_VERSION_ghc(8,10,0)   . FastString.bytesFS@@ -55,7 +100,7 @@   . FastString.fastStringToByteString #endif -occNameToText :: OccName -> T.Text+occNameToText :: HasEnv => OccName -> T.Text occNameToText = fastStringToText . occNameFS  cvtUnique :: Unique.Unique -> Ast.Unique@@ -66,7 +111,7 @@ cvtVar :: Var -> BinderId cvtVar = BinderId . cvtUnique . Var.varUnique -cvtBinder :: Var -> SBinder+cvtBinder :: HasEnv => Var -> SBinder cvtBinder v   | Var.isId v =     SBndr $ Binder { binderName   = occNameToText $ getOccName v@@ -81,7 +126,7 @@                      , binderKind   = cvtType $ Var.varType v                      } -cvtIdInfo :: IdInfo.IdInfo -> Ast.IdInfo SBinder BinderId+cvtIdInfo :: HasEnv => IdInfo.IdInfo -> Ast.IdInfo SBinder BinderId cvtIdInfo i =     IdInfo { idiArity         = IdInfo.arityInfo i            , idiIsOneShot     = IdInfo.oneShotInfo i == IdInfo.OneShotLam@@ -101,7 +146,7 @@            , idiCallArity     = IdInfo.callArityInfo i            } -cvtUnfolding :: CoreSyn.Unfolding -> Ast.Unfolding SBinder BinderId+cvtUnfolding :: HasEnv => CoreSyn.Unfolding -> Ast.Unfolding SBinder BinderId cvtUnfolding CoreSyn.NoUnfolding = Ast.NoUnfolding #if MIN_VERSION_ghc(8,2,0) cvtUnfolding CoreSyn.BootUnfolding = Ast.BootUnfolding@@ -116,7 +161,7 @@                       , unfGuidance   = cvtSDoc $ ppr $ CoreSyn.uf_guidance u                       } -cvtIdDetails :: IdInfo.IdDetails -> Ast.IdDetails+cvtIdDetails :: HasEnv => IdInfo.IdDetails -> Ast.IdDetails cvtIdDetails d =     case d of       IdInfo.VanillaId -> Ast.VanillaId@@ -158,14 +203,14 @@ exprStats _ = CoreStats.CS 0 0 0 #endif -cvtTopBind :: CoreBind -> STopBinding+cvtTopBind :: HasEnv => CoreBind -> STopBinding cvtTopBind (NonRec b e) =     NonRecTopBinding (cvtBinder b) (cvtCoreStats $ exprStats e) (cvtExpr e) cvtTopBind (Rec bs) =     RecTopBinding $ map to bs   where to (b, e) = (cvtBinder b, cvtCoreStats $ exprStats e, cvtExpr e) -cvtExpr :: CoreExpr -> Ast.SExpr+cvtExpr :: HasEnv => CoreExpr -> Ast.SExpr cvtExpr expr =   case expr of     Var x@@ -186,19 +231,34 @@     Let (Rec bs) body -> ELet (map (bimap cvtBinder cvtExpr) bs) (cvtExpr body)     Case e x _ as     -> ECase (cvtExpr e) (cvtBinder x) (map cvtAlt as)     Cast x _          -> cvtExpr x-    Tick _ e          -> cvtExpr e+    Tick tick e+      | CoreSyn.SourceNote sspan _name <- tick+                      -> ETick (Ast.SourceNote $ cvtRealSrcSpan sspan) (cvtExpr e)+      | otherwise     -> cvtExpr e     Type t            -> EType $ cvtType t     Coercion _        -> ECoercion -cvtAlt :: CoreAlt -> Ast.SAlt-cvtAlt (con, bs, e) = Alt (cvtAltCon con) (map cvtBinder bs) (cvtExpr e)+cvtRealSrcSpan :: SrcLoc.RealSrcSpan -> SrcSpan+cvtRealSrcSpan span =+  Ast.SrcSpan { spanFile  = T.pack $ show $ SrcLoc.srcSpanFile span+              , spanStart = LineCol (SrcLoc.srcSpanStartLine span) (SrcLoc.srcSpanStartCol span)+              , spanEnd   = LineCol (SrcLoc.srcSpanEndLine span) (SrcLoc.srcSpanEndCol span)+              } -cvtAltCon :: CoreSyn.AltCon -> Ast.AltCon+cvtAlt :: HasEnv => CoreAlt -> Ast.SAlt+#if MIN_VERSION_ghc(9,2,0)+cvtAlt (CoreSyn.Alt con bs e) =+#else+cvtAlt (con, bs, e) =+#endif+    Alt (cvtAltCon con) (map cvtBinder bs) (cvtExpr e)++cvtAltCon :: HasEnv => CoreSyn.AltCon -> Ast.AltCon cvtAltCon (DataAlt altcon) = Ast.AltDataCon $ occNameToText $ getOccName altcon cvtAltCon (LitAlt l)       = Ast.AltLit $ cvtLit l cvtAltCon DEFAULT          = Ast.AltDefault -cvtLit :: Literal -> Ast.Lit+cvtLit :: HasEnv => Literal -> Ast.Lit cvtLit l =     case l of #if MIN_VERSION_ghc(8,8,0)@@ -208,7 +268,7 @@       Literal.LitFloat x -> Ast.MachFloat x       Literal.LitDouble x -> Ast.MachDouble x       Literal.LitLabel x _ _ -> Ast.MachLabel $ fastStringToText  x-      Literal.LitRubbish -> Ast.LitRubbish+      Literal.LitRubbish{} -> Ast.LitRubbish #else       Literal.MachChar x -> Ast.MachChar x       Literal.MachStr x -> Ast.MachStr x@@ -218,7 +278,11 @@       Literal.MachLabel x _ _ -> Ast.MachLabel $ fastStringToText  x #endif #if MIN_VERSION_ghc(8,6,0)+#if MIN_VERSION_ghc(9,0,0)+      Literal.LitNumber numty n ->+#else       Literal.LitNumber numty n _ ->+#endif         case numty of           Literal.LitNumInt -> Ast.MachInt n           Literal.LitNumInt64 -> Ast.MachInt64 n@@ -226,6 +290,16 @@           Literal.LitNumWord64 -> Ast.MachWord64 n           Literal.LitNumInteger -> Ast.LitInteger n           Literal.LitNumNatural -> Ast.LitNatural n+#if MIN_VERSION_ghc(9,2,0)+          -- Lossy+          Literal.LitNumInt8 -> Ast.MachInt n+          Literal.LitNumInt16 -> Ast.MachInt n+          Literal.LitNumInt32 -> Ast.MachInt n+          Literal.LitNumWord8 -> Ast.MachWord n+          Literal.LitNumWord16 -> Ast.MachWord n+          Literal.LitNumWord32 -> Ast.MachWord n+#endif+ #else       Literal.MachInt x -> Ast.MachInt x       Literal.MachInt64 x -> Ast.MachInt64 x@@ -234,16 +308,24 @@       Literal.LitInteger x _ -> Ast.LitInteger x #endif -cvtModule :: String -> ModGuts -> Ast.SModule-cvtModule phase guts =+cvtModule :: DynFlags -> String -> ModGuts -> Ast.SModule+cvtModule dflags phase guts =+    let ?env = Env {dflags}+    in cvtModule' phase guts++cvtModule' :: HasEnv => String -> ModGuts -> Ast.SModule+cvtModule' phase guts =     Ast.Module name (T.pack phase) (map cvtTopBind $ mg_binds guts)-  where name = cvtModuleName $ Module.moduleName $ mg_module guts+  where+    name = cvtModuleName $ Module.moduleName $ mg_module guts -cvtModuleName :: Module.ModuleName -> Ast.ModuleName+cvtModuleName :: HasEnv => Module.ModuleName -> Ast.ModuleName cvtModuleName = Ast.ModuleName . fastStringToText . moduleNameFS -cvtType :: Type.Type -> Ast.SType-#if MIN_VERSION_ghc(8,10,0)+cvtType :: HasEnv => Type.Type -> Ast.SType+#if MIN_VERSION_ghc(9,0,0)+cvtType (Type.FunTy _flag _ a b) = Ast.FunTy (cvtType a) (cvtType b)+#elif MIN_VERSION_ghc(8,10,0) cvtType (Type.FunTy _flag a b) = Ast.FunTy (cvtType a) (cvtType b) #elif MIN_VERSION_ghc(8,2,0) cvtType (Type.FunTy a b) = Ast.FunTy (cvtType a) (cvtType b)@@ -270,5 +352,5 @@ cvtType (Type.CoercionTy _)    = Ast.CoercionTy #endif -cvtTyCon :: TyCon.TyCon -> Ast.TyCon+cvtTyCon :: HasEnv => TyCon.TyCon -> Ast.TyCon cvtTyCon tc = TyCon (occNameToText $ getOccName tc) (cvtUnique $ tyConUnique tc)

@@ -2,17 +2,32 @@  module GhcDump.Plugin where -import Data.Maybe-import qualified Data.ByteString.Lazy as BSL-import qualified Codec.Serialise as Ser-import GhcPlugins hiding (TB)+#if MIN_VERSION_ghc(9,2,0)+import GHC (getLogger)+#endif++#if MIN_VERSION_ghc(9,0,0)+import GHC.Utils.Error (showPass)+import GHC.Plugins hiding (TB)+import qualified GHC.Utils.Outputable as Outputable ((<>))++#else+ #if !MIN_VERSION_ghc(8,8,0) import CoreMonad (pprPassDetails) #endif+import GhcPlugins hiding (TB)+import qualified GhcPlugins as Outputable ((<>)) import ErrUtils (showPass)+#endif++import Data.Maybe import Text.Printf+ import System.FilePath import System.Directory+import qualified Data.ByteString.Lazy as BSL+import qualified Codec.Serialise as Ser  import GhcDump.Convert @@ -24,21 +39,39 @@     dflags <- getDynFlags     return (intersperseDumps dflags todo) +showDump :: DynFlags -> SDoc -> String+#if MIN_VERSION_ghc(9,2,0)+showDump _dflags = showSDocDump defaultSDocContext+#else+showDump dflags = showSDocDump dflags+#endif+ intersperseDumps :: DynFlags -> [CoreToDo] -> [CoreToDo] intersperseDumps dflags = go 0 "desugar"   where     go n phase (todo : rest) = pass n phase : todo : go (n+1) phase' rest-      where phase' = showSDocDump dflags (ppr todo GhcPlugins.<> text ":" <+> pprPassDetails todo)+      where phase' = showDump dflags (ppr todo Outputable.<> text ":" <+> pprPassDetails todo)     go n phase [] = [pass n phase] -    pass n phase = CoreDoPluginPass "DumpCore" (liftIO . dumpIn dflags n phase)+    pass n phase = CoreDoPluginPass "DumpCore" (dumpIn dflags n phase) -dumpIn :: DynFlags -> Int -> String -> ModGuts -> IO ModGuts+-- Compatibility shim+showPass' :: String -> CoreM ()+showPass' s = do+    dflags <- getDynFlags+#if MIN_VERSION_ghc(9,2,0)+    logger <- getLogger+    liftIO $ showPass logger dflags s+#else+    liftIO $ showPass dflags s+#endif++dumpIn :: DynFlags -> Int -> String -> ModGuts -> CoreM ModGuts dumpIn dflags n phase guts = do     let prefix = fromMaybe "dump" $ dumpPrefix dflags         fname = printf "%spass-%04u.cbor" prefix n-    showPass dflags $ "GhcDump: Dumping core to "++fname+    showPass' $ "GhcDump: Dumping core to "++fname     let in_dump_dir = maybe id (</>) (dumpDir dflags)-    createDirectoryIfMissing True $ takeDirectory $ in_dump_dir fname-    BSL.writeFile (in_dump_dir fname) $ Ser.serialise (cvtModule phase guts)+    liftIO $ createDirectoryIfMissing True $ takeDirectory $ in_dump_dir fname+    liftIO $ BSL.writeFile (in_dump_dir fname) $ Ser.serialise (cvtModule dflags phase guts)     return guts

@@ -1,5 +1,6 @@+cabal-version:       3.0 name:                ghc-dump-core-version:             0.1.2.0+version:             0.2.1.0 synopsis:            An AST and compiler plugin for dumping GHC's Core representation. description:   @ghc-dump@ is a library, GHC plugin, and set of tools for recording and@@ -20,15 +21,22 @@   command-line. See the [README](https://github.com/bgamari/ghc-dump)   for further analysis tips. -license:             BSD3+license:             BSD-3-Clause license-file:        LICENSE author:              Ben Gamari maintainer:          ben@well-typed.com copyright:           (c) 2017 Ben Gamari category:            Development+tested-with:         GHC==7.10.3,+                     GHC==8.0.2,+                     GHC==8.2.2,+                     GHC==8.4.4,+                     GHC==8.6.5,+                     GHC==8.8.3,+                     GHC==8.10.4,+                     GHC==9.0.1,+                     GHC==9.2.1, build-type:          Simple-tested-with:         GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC==8.10.1-cabal-version:       >=1.10  source-repository head   type: git@@ -38,12 +46,12 @@   exposed-modules:     GhcDump.Convert, GhcDump.Ast, GhcDump.Plugin   ghc-options:         -Wall   other-extensions:    GeneralizedNewtypeDeriving-  build-depends:       base >=4.8 && <4.15,+  build-depends:       base >=4.8 && <4.17,                        bytestring >= 0.10,                        text >=1.2 && <1.3,                        filepath >= 1.4,                        serialise >= 0.2 && <0.3,-                       ghc >= 7.10 && < 8.11,+                       ghc >= 7.10 && < 9.3,                        directory < 1.4   default-language:    Haskell2010   if impl(ghc >= 8.0)