diff --git a/GhcDump/Ast.hs b/GhcDump/Ast.hs --- a/GhcDump/Ast.hs +++ b/GhcDump/Ast.hs @@ -4,12 +4,14 @@ import GHC.Generics -import Data.Monoid +import Data.Monoid hiding ((<>)) +import Data.Semigroup as Sem import qualified Data.ByteString as BS import Codec.Serialise import qualified Data.Text as T import Unique (mkUnique) +import Prelude data Unique = Unique !Char !Int deriving (Eq, Ord, Generic) @@ -115,6 +117,7 @@ | MachDouble Rational | MachLabel T.Text | LitInteger Integer + | LitNatural Integer deriving (Eq, Ord, Generic, Show) instance Serialise Lit @@ -219,10 +222,13 @@ deriving (Generic, Show) instance Serialise CoreStats +instance Sem.Semigroup CoreStats where + CoreStats a b c d e <> CoreStats a' b' c' d' e' = + CoreStats (a+a') (b+b') (c+c') (d+d') (e+e') + instance Monoid CoreStats where mempty = CoreStats 0 0 0 0 0 - CoreStats a b c d e `mappend` CoreStats a' b' c' d' e' = - CoreStats (a+a') (b+b') (c+c') (d+d') (e+e') + mappend = (<>) {- data Rule' bndr var diff --git a/GhcDump/Convert.hs b/GhcDump/Convert.hs --- a/GhcDump/Convert.hs +++ b/GhcDump/Convert.hs @@ -6,6 +6,7 @@ import qualified Data.Text.Encoding as TE import Literal (Literal(..)) +import qualified Literal import Var (Var) import qualified Var import Id (isFCallId) @@ -23,12 +24,16 @@ import CoreSyn (Expr(..), CoreExpr, Bind(..), CoreAlt, CoreBind, AltCon(..)) import HscTypes (ModGuts(..)) import FastString (FastString, fastStringToByteString) -#if MIN_VERSION_ghc(8,0,0) +#if MIN_VERSION_ghc(8,2,0) +import TyCoRep as Type (Type(..)) +#elif MIN_VERSION_ghc(8,0,0) import TyCoRep as Type (Type(..), TyBinder(..)) #else import TypeRep as Type (Type(..)) #endif +#if !(MIN_VERSION_ghc(8,2,0)) import Type (splitFunTy_maybe) +#endif import TyCon (TyCon, tyConUnique) import Outputable (ppr, showSDoc, SDoc) @@ -75,7 +80,7 @@ , idiUnfolding = cvtUnfolding $ IdInfo.unfoldingInfo i , idiInlinePragma = cvtSDoc $ ppr $ IdInfo.inlinePragInfo i , idiOccInfo = case IdInfo.occInfo i of -#if MIN_VERSION_ghc(8,1,0) +#if MIN_VERSION_ghc(8,2,0) OccInfo.ManyOccs{} -> OccManyOccs #else OccInfo.NoOccInfo -> OccManyOccs @@ -191,14 +196,25 @@ Literal.MachChar x -> Ast.MachChar x Literal.MachStr x -> Ast.MachStr x Literal.MachNullAddr -> Ast.MachNullAddr +#if MIN_VERSION_ghc(8,6,0) + Literal.LitNumber numty n _ -> + case numty of + Literal.LitNumInt -> Ast.MachInt n + Literal.LitNumInt64 -> Ast.MachInt64 n + Literal.LitNumWord -> Ast.MachWord n + Literal.LitNumWord64 -> Ast.MachWord64 n + Literal.LitNumInteger -> Ast.LitInteger n + Literal.LitNumNatural -> Ast.LitNatural n +#else Literal.MachInt x -> Ast.MachInt x Literal.MachInt64 x -> Ast.MachInt64 x Literal.MachWord x -> Ast.MachWord x Literal.MachWord64 x -> Ast.MachWord64 x + Literal.LitInteger x _ -> Ast.LitInteger x +#endif Literal.MachFloat x -> Ast.MachFloat x Literal.MachDouble x -> Ast.MachDouble x Literal.MachLabel x _ _ -> Ast.MachLabel $ fastStringToText x - Literal.LitInteger x _ -> Ast.LitInteger x cvtModule :: String -> ModGuts -> Ast.SModule cvtModule phase guts = @@ -209,8 +225,12 @@ cvtModuleName = Ast.ModuleName . fastStringToText . moduleNameFS cvtType :: Type.Type -> Ast.SType +#if MIN_VERSION_ghc(8,2,0) +cvtType (Type.FunTy a b) = Ast.FunTy (cvtType a) (cvtType b) +#else cvtType t | Just (a,b) <- splitFunTy_maybe t = Ast.FunTy (cvtType a) (cvtType b) +#endif cvtType (Type.TyVarTy v) = Ast.VarTy (cvtVar v) cvtType (Type.AppTy a b) = Ast.AppTy (cvtType a) (cvtType b) cvtType (Type.TyConApp tc tys) = Ast.TyConApp (cvtTyCon tc) (map cvtType tys) diff --git a/GhcDump/Plugin.hs b/GhcDump/Plugin.hs --- a/GhcDump/Plugin.hs +++ b/GhcDump/Plugin.hs @@ -10,6 +10,7 @@ import ErrUtils (showPass) import Text.Printf import System.FilePath +import System.Directory import GhcDump.Convert @@ -25,7 +26,7 @@ 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 <> text ":" <+> pprPassDetails todo) + where phase' = showSDocDump dflags (ppr todo GhcPlugins.<> text ":" <+> pprPassDetails todo) go n phase [] = [pass n phase] pass n phase = CoreDoPluginPass "DumpCore" (liftIO . dumpIn dflags n phase) @@ -36,5 +37,6 @@ fname = printf "%spass-%04u.cbor" prefix n showPass dflags $ "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) return guts diff --git a/ghc-dump-core.cabal b/ghc-dump-core.cabal --- a/ghc-dump-core.cabal +++ b/ghc-dump-core.cabal @@ -1,5 +1,5 @@ name: ghc-dump-core -version: 0.1.0.0 +version: 0.1.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 @@ -27,17 +27,27 @@ copyright: (c) 2017 Ben Gamari category: Development build-type: Simple -tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2 +tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.4 cabal-version: >=1.10 +source-repository head + type: git + location: https://github.com/bgamari/ghc-dump + library exposed-modules: GhcDump.Convert, GhcDump.Ast, GhcDump.Plugin ghc-options: -Wall other-extensions: GeneralizedNewtypeDeriving - build-depends: base >=4.8 && <4.11, + build-depends: base >=4.8 && <4.13, bytestring >= 0.10, text >=1.2 && <1.3, filepath >= 1.4, serialise >= 0.2 && <0.3, - ghc >= 7.10 && < 8.4 + ghc >= 7.10 && < 8.8, + directory < 1.4 default-language: Haskell2010 + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances + else + -- provide/emulate `Control.Monad.Fail` and `Data.Semigroups` API for pre-GHC8 + build-depends: fail == 4.9.*, semigroups == 0.18.*