diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml new file mode 100644 index 000000000..3b5ee4fb9 --- /dev/null +++ b/.github/workflows/ci.yml @@ -0,0 +1,40 @@ +name: concat +on: + push: + branches: + - master + pull_request: + types: + - opened + - synchronize +jobs: + build: + runs-on: ubuntu-latest + strategy: + matrix: + ghc: + # - "8.0.2" # We've (temporarily?) lost support for these, but still + # - "8.2.2" # have conditional compilation for them. We should either + # - "8.4.1" # fix (some) of them or remove the CPP. + - "8.6.1" + - "8.8.1" + - "8.10.1" + - "9.0.1" + - "9.2.1" + steps: + - uses: actions/checkout@v2 + - uses: haskell/actions/setup@v1 + id: setup-haskell-cabal + with: + ghc-version: ${{ matrix.ghc }} + cabal-version: "3.6.0.0" + - run: cabal v2-update + - run: cabal v2-freeze $CONFIG + - uses: actions/cache@v2 + with: + path: | + ${{ steps.setup-haskell-cabal.outputs.cabal-store }} + dist-newstyle + key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} + - run: cabal new-build all + - run: cabal new-test gold-tests diff --git a/cabal.project b/cabal.project index 9115b3df6..b98dc1059 100644 --- a/cabal.project +++ b/cabal.project @@ -16,11 +16,6 @@ source-repository-package tag: master subdir: verilog -source-repository-package - type: git - location: https://github.com/expipiplus1/vector-sized.git - tag: master - packages: ./inline/concat-inline.cabal ./plugin/concat-plugin.cabal diff --git a/classes/src/ConCat/Category.hs b/classes/src/ConCat/Category.hs index 2176d8314..11c17c835 100644 --- a/classes/src/ConCat/Category.hs +++ b/classes/src/ConCat/Category.hs @@ -1815,7 +1815,7 @@ class BottomCat k a b where -- bottomC = bottomC &&& bottomC instance (BottomCat k a b, ClosedCat k, Ok4 k z b a (z -> b)) => BottomCat k a (z -> b) where - bottomC = curry (bottomC . exl) <+ okProd @k @a @ z + bottomC = curry (bottomC . exl) <+ okProd @k @a @z instance BottomCat (->) a b where bottomC = error "bottomC for (->) evaluated" @@ -2075,7 +2075,7 @@ class ({- Pointed h, -} OkFunctor k h, Ok k a) => PointedCat k h a where -- class (Ok k a, Num a) => SumCat k h a where -- sumC :: h a `k` a -class (Ok k a, Additive a) => AddCat k h a where +class Ok k a => AddCat k h a where sumAC :: h a `k` a -- class IxSummable n => IxSummableCat k n where diff --git a/examples/concat-examples.cabal b/examples/concat-examples.cabal index 60f6147be..a063bc135 100644 --- a/examples/concat-examples.cabal +++ b/examples/concat-examples.cabal @@ -61,7 +61,6 @@ library , concat-inline , concat-known , concat-classes - , concat-plugin if flag(smt) build-depends: z3 cpp-options: -DCONCAT_SMT @@ -114,70 +113,6 @@ library ghc-options: -O2 cpp-options: -DVectorSized --- Stack apparently only allows per-package flags, not per-component, so the --- whole library gets recompiled. For now, duplicate the test-suite. See --- - -Test-Suite misc-examples - type: exitcode-stdio-1.0 - default-language: Haskell98 - hs-Source-Dirs: test - main-is: Examples.hs - other-modules: Miscellany - Build-Depends: base<5 - , Cabal >= 1.24.0.0 - , ghc-prim - , constraints >= 0.8 - , newtype-generics >= 0.5.3 - , pointed, keys - , distributive, adjunctions - , concat-inline - , concat-classes - , concat-plugin - , concat-examples - , ghc-prim - , integer-gmp - , distributive, adjunctions - , constraints >= 0.8 - -- Array/vector experiments - , finite-typelits, vector-sized >= 1.0.0.0 - ghc-options: -O2 - -fplugin=ConCat.Plugin - if flag(smt) - cpp-options: -DCONCAT_SMT - cpp-options: -DVectorSized - -Test-Suite misc-trace - type: exitcode-stdio-1.0 - default-language: Haskell98 - hs-Source-Dirs: test - main-is: Examples.hs - other-modules: Miscellany - Build-Depends: base<5 - , Cabal >= 1.24.0.0 - , ghc-prim - , constraints >= 0.8 - , newtype-generics >= 0.5.3 - , pointed, keys - , distributive, adjunctions - , concat-inline - , concat-classes - , concat-plugin - , concat-examples - , ghc-prim - , integer-gmp - , keys - , distributive, adjunctions - , constraints >= 0.8 - -- Array/vector experiments - , finite-typelits, vector-sized - ghc-options: -O2 - -fplugin=ConCat.Plugin - -fplugin-opt=ConCat.Plugin:trace - if flag(smt) - cpp-options: -DCONCAT_SMT - cpp-options: -DVectorSized - -- Test-Suite testHasFins -- type: exitcode-stdio-1.0 -- default-language: Haskell98 @@ -189,58 +124,3 @@ Test-Suite misc-trace -- , concat-examples -- , concat-classes -- , ghc-typelits-knownnat - -Test-Suite gold-tests - type: exitcode-stdio-1.0 - default-language: Haskell98 - hs-Source-Dirs: test - main-is: GoldTests.hs - other-modules: BasicTests, Miscellany, Utils - Build-Depends: base<5 - , Cabal >= 1.24.0.0 - , ghc-prim - , constraints >= 0.8 - , newtype-generics >= 0.5.3 - , pointed, keys - , distributive, adjunctions - , vector - , concat-inline - , concat-classes - , concat-plugin - , concat-examples - , ghc-prim - , integer-gmp - , distributive, adjunctions - , constraints >= 0.8 - , bytestring - , tasty - , tasty-golden - -- Array/vector experiments - , finite-typelits, vector-sized >= 1.0.0.0 - ghc-options: -O2 - -fplugin=ConCat.Plugin --- -fplugin-opt=ConCat.Plugin:showCcc --- -dppr-debug -dverbose-core2core -dinline-check satisfy -ddump-inlinings - if flag(smt) - cpp-options: -DCONCAT_SMT - cpp-options: -DVectorSized - --- executable ad_rev --- hs-source-dirs: app --- main-is: ad_rev.lhs --- build-depends: base >= 4.7 && < 5 --- , optparse-generic --- , concat-classes --- , concat-examples --- , concat-plugin --- default-language: Haskell2010 --- ghc-options: -O2 --- -funbox-strict-fields --- -threaded --- -optc-ffast-math --- -optc-O3 --- -- -fplugin=ConCat.Plugin --- -- -fplugin-opt=ConCat.Plugin:trace --- -- -fplugin-opt=ConCat.Plugin:maxSteps=200 --- -- -fforce-recomp - diff --git a/examples/src/ConCat/Dual.hs b/examples/src/ConCat/Dual.hs index 1f16bcc15..3949ce093 100644 --- a/examples/src/ConCat/Dual.hs +++ b/examples/src/ConCat/Dual.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TupleSections #-} @@ -224,7 +225,7 @@ instance (PointedCat k h a, Additive a) => AddCat (Dual k) h a where sumAC = abst pointC {-# INLINE sumAC #-} -instance (AddCat k h a, OkF k h) => PointedCat (Dual k) h a where +instance (AddCat k h a, Additive a, OkF k h) => PointedCat (Dual k) h a where pointC = abst sumAC {-# INLINE pointC #-} diff --git a/examples/src/ConCat/StackVM.hs b/examples/src/ConCat/StackVM.hs index 92b5d2270..9ad118cd5 100644 --- a/examples/src/ConCat/StackVM.hs +++ b/examples/src/ConCat/StackVM.hs @@ -58,8 +58,8 @@ evalStackFun (SF f) = rcounit . f . runit instance Category StackFun where id = stackFun id - -- SF g . SF f = SF (g . f) - (.) = inSF2 (.) + SF g . SF f = SF (g . f) + -- (.) = inSF2 (.) {-# INLINE id #-} {-# INLINE (.) #-} @@ -70,9 +70,9 @@ instance AssociativePCat StackFun where {-# INLINE rassocP #-} instance MonoidalPCat StackFun where - first = inSF inRassocP -- okay + -- first = inSF inRassocP -- okay -- first (SF f) = SF (inRassocP f) - -- first (SF f) = SF (lassocP . f . rassocP) + first (SF f) = SF (lassocP . f . rassocP) -- first (SF f) = SF lassocP . SF f . SF rassocP -- doesn't type-check second = secondFirst f *** g = second g . first f diff --git a/examples/src/ConCat/TArr.hs b/examples/src/ConCat/TArr.hs index fea08629d..4469c68d9 100644 --- a/examples/src/ConCat/TArr.hs +++ b/examples/src/ConCat/TArr.hs @@ -45,7 +45,9 @@ import Prelude hiding (id, (.), const, curry, uncurry) -- Coming from ConCat.Al import Data.Monoid import Data.Foldable import GHC.TypeLits +#if !MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) import GHC.Types (Nat) +#endif import GHC.Generics (U1(..),Par1(..),(:*:)(..),(:.:)(..)) import GHC.Exts (Coercible,coerce) diff --git a/inline/src/ConCat/Inline/Plugin.hs b/inline/src/ConCat/Inline/Plugin.hs index df58c7184..8cd2cfa5a 100644 --- a/inline/src/ConCat/Inline/Plugin.hs +++ b/inline/src/ConCat/Inline/Plugin.hs @@ -12,10 +12,21 @@ import qualified ConCat.Inline.ClassOp as CO import Data.List (elemIndex) -- GHC API +#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) +import qualified GHC.Driver.Backend as Backend +import GHC.Types.TyThing (lookupId, lookupTyCon) +#endif +#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) +import GHC.Core.Class (classAllSelIds) +import GHC.Plugins +import GHC.Types.Id.Make (mkDictSelRhs) +import GHC.Runtime.Loader +#else import GhcPlugins import Class (classAllSelIds) import MkId (mkDictSelRhs) import DynamicLoading +#endif plugin :: Plugin plugin = defaultPlugin { installCoreToDos = install @@ -29,9 +40,14 @@ install _opts todos = do dflags <- getDynFlags -- Unfortunately, the plugin doesn't work in GHCi. Until fixed, -- disable under GHCi, so we can at least type-check conveniently. +#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) + if backend dflags == Backend.Interpreter then + return todos +#else if hscTarget dflags == HscInterpreted then return todos - else +#endif + else do #if !MIN_VERSION_GLASGOW_HASKELL(8,2,0,0) reinitializeGlobals diff --git a/plugin/concat-plugin.cabal b/plugin/concat-plugin.cabal index baffe004f..3665a57a4 100644 --- a/plugin/concat-plugin.cabal +++ b/plugin/concat-plugin.cabal @@ -18,6 +18,10 @@ source-repository head type: git location: git://github.com/conal/concat +Flag smt + Description: Enable SMT + Default: False + library default-language: Haskell2010 hs-source-dirs: src @@ -42,3 +46,121 @@ library -- Do I want to depend on integer-gmp? Maybe conditionally depend on integer-gmp -- or integer-simple. + +-- Stack apparently only allows per-package flags, not per-component, so the +-- whole library gets recompiled. For now, duplicate the test-suite. See +-- + +Test-Suite misc-examples + type: exitcode-stdio-1.0 + default-language: Haskell98 + hs-Source-Dirs: test + main-is: Examples.hs + other-modules: Miscellany + Build-Depends: base<5 + , Cabal >= 1.24.0.0 + , ghc-prim + , constraints >= 0.8 + , newtype-generics >= 0.5.3 + , pointed, keys + , distributive, adjunctions + , concat-inline + , concat-classes + , concat-plugin + , concat-examples + , ghc-prim + , integer-gmp + , distributive, adjunctions + , constraints >= 0.8 + -- Array/vector experiments + , finite-typelits, vector-sized >= 1.0.0.0 + ghc-options: -O2 + -fplugin=ConCat.Plugin + if flag(smt) + cpp-options: -DCONCAT_SMT + cpp-options: -DVectorSized + +Test-Suite misc-trace + type: exitcode-stdio-1.0 + default-language: Haskell98 + hs-Source-Dirs: test + main-is: Examples.hs + other-modules: Miscellany + Build-Depends: base<5 + , Cabal >= 1.24.0.0 + , ghc-prim + , constraints >= 0.8 + , newtype-generics >= 0.5.3 + , pointed, keys + , distributive, adjunctions + , concat-inline + , concat-classes + , concat-plugin + , concat-examples + , ghc-prim + , integer-gmp + , keys + , distributive, adjunctions + , constraints >= 0.8 + -- Array/vector experiments + , finite-typelits, vector-sized + ghc-options: -O2 + -fplugin=ConCat.Plugin + -fplugin-opt=ConCat.Plugin:trace + if flag(smt) + cpp-options: -DCONCAT_SMT + cpp-options: -DVectorSized + +Test-Suite gold-tests + type: exitcode-stdio-1.0 + default-language: Haskell98 + hs-Source-Dirs: test + main-is: GoldTests.hs + other-modules: BasicTests, Miscellany, Utils + Build-Depends: base<5 + , Cabal >= 1.24.0.0 + , ghc-prim + , constraints >= 0.8 + , newtype-generics >= 0.5.3 + , pointed, keys + , distributive, adjunctions + , vector + , concat-inline + , concat-classes + , concat-plugin + , concat-examples + , ghc-prim + , integer-gmp + , distributive, adjunctions + , constraints >= 0.8 + , bytestring + , tasty + , tasty-golden + -- Array/vector experiments + , finite-typelits, vector-sized >= 1.0.0.0 + ghc-options: -O2 + -fplugin=ConCat.Plugin +-- -fplugin-opt=ConCat.Plugin:showCcc +-- -dppr-debug -dverbose-core2core -dinline-check satisfy -ddump-inlinings + if flag(smt) + cpp-options: -DCONCAT_SMT + cpp-options: -DVectorSized + +-- executable ad_rev +-- hs-source-dirs: app +-- main-is: ad_rev.lhs +-- build-depends: base >= 4.7 && < 5 +-- , optparse-generic +-- , concat-classes +-- , concat-examples +-- , concat-plugin +-- default-language: Haskell2010 +-- ghc-options: -O2 +-- -funbox-strict-fields +-- -threaded +-- -optc-ffast-math +-- -optc-O3 +-- -- -fplugin=ConCat.Plugin +-- -- -fplugin-opt=ConCat.Plugin:trace +-- -- -fplugin-opt=ConCat.Plugin:maxSteps=200 +-- -- -fforce-recomp diff --git a/plugin/src/ConCat/Plugin.hs b/plugin/src/ConCat/Plugin.hs index 94d979acb..c63086b48 100644 --- a/plugin/src/ConCat/Plugin.hs +++ b/plugin/src/ConCat/Plugin.hs @@ -36,13 +36,36 @@ import qualified Data.Sequence as Seq import qualified Data.Set as OrdSet --import qualified Data.Map (Map) as OrdMap import qualified Data.Map as OrdMap -#if MIN_VERSION_GLASGOW_HASKELL(8,2,0,0) -import qualified UniqDFM as DFMap -#endif import Text.Printf (printf) import System.IO.Unsafe (unsafePerformIO) import Data.IORef +#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) +import GHC.Builtin.Names (leftDataConName,rightDataConName + ,floatTyConKey,doubleTyConKey,integerTyConKey + ,intTyConKey,boolTyConKey) +import GHC.Builtin.Types.Prim (intPrimTyCon) +import GHC.Core.Class (classAllSelIds) +-- For normaliseType etc +import GHC.Core.FamInstEnv +import GHC.Core.Lint (lintExpr) +import GHC.Core.Opt.Arity (etaExpand) +import GHC.Core.SimpleOpt (simpleOptExpr) +import GHC.Core.TyCo.Rep +import GHC.Core.Type (coreView) +import GHC.Data.Pair (Pair(..)) +import GHC.Plugins as GHC hiding (substTy,cat) +import GHC.Runtime.Loader +import GHC.Tc.Utils.TcType (isFloatTy,isDoubleTy,isIntegerTy,isIntTy,isBoolTy,isUnitTy + ,tcSplitTyConApp_maybe) +import GHC.Types.Id.Make (mkDictSelRhs,coerceId) +#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) +import GHC.Builtin.Uniques (mkBuiltinUnique) +#else +import GHC.Types.Unique (mkBuiltinUnique) +#endif +import qualified GHC.Types.Unique.DFM as DFMap +#else import GhcPlugins as GHC hiding (substTy,cat) import Class (classAllSelIds) import CoreArity (etaExpand) @@ -57,32 +80,55 @@ import Type (coreView) import TcType (isFloatTy,isDoubleTy,isIntegerTy,isIntTy,isBoolTy,isUnitTy ,tcSplitTyConApp_maybe) import TysPrim (intPrimTyCon) -import FamInstEnv (normaliseType) +-- For normaliseType etc +import FamInstEnv #if MIN_VERSION_GLASGOW_HASKELL(8,2,0,0) import CoreOpt (simpleOptExpr) +import qualified UniqDFM as DFMap #endif import TyCoRep -import GHC.Classes import Unique (mkBuiltinUnique) --- For normaliseType etc -import FamInstEnv +#endif +import GHC.Classes import ConCat.Misc (Unop,Binop,Ternop,PseudoFun(..),(~>)) import ConCat.BuildDictionary -- import ConCat.Simplify --- GHC 8.10 FunTy as an extra operand -#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) -pattern FunTy' a r <- - FunTy _ a r - +pattern FunCo' :: Role -> Coercion -> Coercion -> Coercion +mkFunCo' :: Role -> Coercion -> Coercion -> Coercion +pattern FunTy' :: Type -> Type -> Type mkFunTy' :: Type -> Type -> Type -mkFunTy' a b = FunTy VisArg a b -#else +#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) +pattern FunCo' r a b <- FunCo r _ a b +mkFunCo' r = FunCo r (multToCo One) +pattern FunTy' a r <- FunTy _ _ a r +mkFunTy' = FunTy VisArg One +-- GHC 8.10 FunTy as an extra operand +#elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) +pattern FunCo' r a b = FunCo r a b +mkFunCo' = FunCo +pattern FunTy' a r <- FunTy _ a r +mkFunTy' = FunTy VisArg +#elif MIN_VERSION_GLASGOW_HASKELL(8,2,0,0) +pattern FunCo' r a b = FunCo r a b +mkFunCo' = FunCo pattern FunTy' a r = FunTy a r +mkFunTy' = FunTy +#else +pattern FunCo' r dom ran <- TyConAppCo r (isFunTyCon -> True) [dom,ran] + where FunCo' = mkFunCo +pattern FunTy' dom ran <- (splitFunTy_maybe -> Just (dom,ran)) + where FunTy' = mkFunTy +-- TODO: Replace explicit uses of splitFunTy_maybe +-- TODO: Look for other useful pattern synonyms +#endif -mkFunTy' :: Type -> Type -> Type -mkFunTy' a b = FunTy a b +splitFunTy_maybe' :: Type -> Maybe (Type, Type) +#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) +splitFunTy_maybe' = fmap (\(_, a, b) -> (a, b)) . splitFunTy_maybe +#else +splitFunTy_maybe' = splitFunTy_maybe #endif -- Information needed for reification. We construct this info in @@ -121,8 +167,10 @@ data CccEnv = CccEnv { dtrace :: forall a. String -> SDoc -> a -> a -- , hasRepFromAbstCo :: Coercion -> CoreExpr , prePostV :: Id -- , lazyV :: Id -#if MIN_VERSION_GLASGOW_HASKELL(8,2,0,0) - , boxers :: DFMap.UniqDFM {- TyCo-} Id -- to remove +#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) + , boxers :: DFMap.UniqDFM TyCon Id -- to remove +#elif MIN_VERSION_GLASGOW_HASKELL(8,2,0,0) + , boxers :: DFMap.UniqDFM Id -- to remove #else , boxers :: OrdMap.Map TyCon Id #endif @@ -191,7 +239,7 @@ ccc (CccEnv {..}) (Ops {..}) cat = Trying("top flipForkT") -- f | pprTrace "flipForkT tests" -- (ppr ( splitFunTy (exprType f) - -- , second splitFunTy_maybe (splitFunTy (exprType f)) + -- , second splitFunTy_maybe' (splitFunTy (exprType f)) -- , not catClosed)) False = undefined f | z `FunTy` (a `FunTy` b) <- exprType f , not catClosed @@ -269,7 +317,7 @@ ccc (CccEnv {..}) (Ops {..}) cat = -- I think GHC is undoing this transformation, so continue eagerly -- (`Cast` co') <$> go e Trying("top const cast") - Cast (Lam v e) (FunCo _r _ co'@(coercionKind -> Pair b b')) + Cast (Lam v e) (FunCo' _r _ co'@(coercionKind -> Pair b b')) | not (v `isFreeIn` e) -- , dtrace "top const cast" (ppr (varWithType castConstTV)) True , Just mk <- onDictMaybe <=< onDictMaybe $ @@ -327,7 +375,7 @@ ccc (CccEnv {..}) (Ops {..}) cat = -- dtrace "top App result" (ppr (mkCompose cat uncU' (mkFork cat v' (mkId cat dom)))) $ return (mkCompose cat uncU' (mkFork cat v' (mkId cat dom))) where - Just (dom,_) = splitFunTy_maybe (exprType e) + Just (dom,_) = splitFunTy_maybe' (exprType e) Tick t e -> Doing("top tick") return $ Tick t (mkCcc e) _e -> Doing("top Unhandled") @@ -590,7 +638,7 @@ ccc (CccEnv {..}) (Ops {..}) cat = co'' = downgradeRole r r' co' -- same as co? in -- pprTrace "lam nominal Cast" (ppr co $$ text "-->" $$ ppr co'') $ - return (mkCcc (Cast (Lam x body') (FunCo r (mkReflCo r xty) co''))) + return (mkCcc (Cast (Lam x body') (mkFunCo' r (mkReflCo r xty) co''))) Trying("lam representational cast") e@(Cast e' _) -> Doing("lam representational cast") @@ -839,7 +887,7 @@ mkOps (CccEnv {..}) guts annotations famEnvs dflags inScope evTy ev cat = Ops {. catTy (tyArgs2 -> (a,b)) = mkAppTys cat [a,b] reCatCo :: Rewrite Coercion -- reCatCo co | dtrace "reCatCo" (ppr co) False = undefined - reCatCo (FunCo r a b) = Just (mkAppCos (mkReflCo r cat) [a,b]) + reCatCo (FunCo' r a b) = Just (mkAppCos (mkReflCo r cat) [a,b]) reCatCo (splitAppCo_maybe -> Just (splitAppCo_maybe -> Just #if MIN_VERSION_GLASGOW_HASKELL(8,8,0,0) @@ -890,7 +938,7 @@ mkOps (CccEnv {..}) guts annotations famEnvs dflags inScope evTy ev cat = Ops {. noDictErr doc = either (\ msg -> pprPanic "ccc - couldn't build dictionary for" (doc GHC.<> colon $$ msg)) id onDictTry :: CoreExpr -> Either SDoc CoreExpr - onDictTry e | Just (ty,_) <- splitFunTy_maybe (exprType e) + onDictTry e | Just (ty,_) <- splitFunTy_maybe' (exprType e) , isPredTy' ty = App e <$> buildDictMaybe ty | otherwise = return e -- pprPanic "ccc / onDictTy: not a function from pred" (pprWithType e) @@ -907,7 +955,7 @@ mkOps (CccEnv {..}) guts annotations famEnvs dflags inScope evTy ev cat = Ops {. -- Yet another variant: keep applying to dictionaries as long as we have -- a predicate type. TODO: reassess and refactor these variants. onDicts :: Unop CoreExpr - onDicts e | Just (ty,_) <- splitFunTy_maybe (exprType e) + onDicts e | Just (ty,_) <- splitFunTy_maybe' (exprType e) , isPredTy' ty = onDicts (onDict e) | otherwise = e buildDictMaybe :: Type -> Either SDoc CoreExpr @@ -926,7 +974,7 @@ mkOps (CccEnv {..}) guts annotations famEnvs dflags inScope evTy ev cat = Ops {. mkCcc' e = varApps cccPV [cat,a,b,evTy] [ev,e] where (a,b) = fromMaybe (pprPanic "mkCcc non-function:" (pprWithType e)) $ - splitFunTy_maybe (exprType e) + splitFunTy_maybe' (exprType e) mkCcc :: Unop CoreExpr -- Any reason to parametrize over Cat? mkCcc e = -- dtrace "mkCcc" (ppr (cat, e)) $ mkCcc' e @@ -1330,12 +1378,12 @@ composeRuleName = fsLit "compose/coerce" evidenceRuleName :: FastString evidenceRuleName = fsLit "evidence annotation" -cccRules :: Maybe (IORef Int) -> FamInstEnvs -> CccEnv -> ModGuts -> AnnEnv -> [CoreRule] -cccRules steps famEnvs env@(CccEnv {..}) guts annotations = +cccRules :: Maybe (IORef Int) -> FamInstEnvs -> CccEnv -> ModGuts -> AnnEnv -> DynFlags -> [CoreRule] +cccRules steps famEnvs env@(CccEnv {..}) guts annotations dflags = [ BuiltinRule { ru_name = cccRuleName , ru_fn = varName cccPV , ru_nargs = 6 -- including type args - , ru_try = \ dflags inScope _fn -> + , ru_try = \ _rOpts inScope _fn -> \ case -- _args | pprTrace "ccc ru_try args" (ppr _args) False -> undefined _es@(Type k : Type _a : Type _b : Type evType : ev : arg : _) -> @@ -1405,7 +1453,7 @@ install opts todos = let famEnvs = (pkgFamEnv, mg_fam_inst_env guts) maxSteps = (unsafePerformIO . newIORef) <$> parseOpt "maxSteps" opts - return (on_mg_rules (++ cccRules maxSteps famEnvs env guts allAnns) guts) + return (on_mg_rules (++ cccRules maxSteps famEnvs env guts allAnns dflags) guts) delCccRule guts = return (on_mg_rules (filter (not . isCccRule)) guts) isCccRule r = isBuiltinRule r && ru_name r `elem` [cccRuleName,composeRuleName] -- isCCC r | is = pprTrace "delRule" (ppr cccRuleName) is @@ -1561,8 +1609,13 @@ mkCccEnv opts = do let boxers = OrdMap.fromList [(intTyCon,boxIV),(doubleTyCon,boxDV),(floatTyCon,boxFV)] #endif -- _ <- findId "GHC.Num" "subtract" -- help the plugin find instances for Float and Double +#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) + when (isDeadEndId cccV) $ + pprPanic "isDeadEndId cccV" empty +#else when (isBottomingId cccV) $ pprPanic "isBottomingId cccV" empty +#endif return (CccEnv { .. }) -- Variables that have associated ccc rewrite rules in AltCat. If we have @@ -1698,7 +1751,11 @@ qualifiedName nm = -- binders, which is handy as dead binders can appear with live binders of the -- same variable. subst :: [(Id,CoreExpr)] -> Unop CoreExpr +#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) +subst ps = substExpr (foldr add emptySubst ps') +#else subst ps = substExpr "subst" (foldr add emptySubst ps') +#endif where add (v,new) sub = extendIdSubst sub v new ps' = filter (not . isDeadBinder . fst) ps @@ -1756,22 +1813,6 @@ stringExpr = Lit . mkMachString varNameExpr :: Id -> CoreExpr varNameExpr = stringExpr . uniqVarName -#if ! MIN_VERSION_GLASGOW_HASKELL(8,2,0,0) - -pattern FunTy :: Type -> Type -> Type -pattern FunTy dom ran <- (splitFunTy_maybe -> Just (dom,ran)) - where FunTy = mkFunTy - --- TODO: Replace explicit uses of splitFunTy_maybe - --- TODO: Look for other useful pattern synonyms - -pattern FunCo :: Role -> Coercion -> Coercion -> Coercion -pattern FunCo r dom ran <- TyConAppCo r (isFunTyCon -> True) [dom,ran] - where FunCo = mkFunCo - -#endif - onCaseRhs :: Type -> Unop (Unop CoreExpr) onCaseRhs altsTy' f (Case scrut v _ alts) = Case scrut v altsTy' (onAltRhs f <$> alts) @@ -1858,7 +1899,11 @@ onExprHead _dflags h = (fmap.fmap) simpleOptExpr' $ freshId :: VarSet -> String -> Type -> Id freshId used nm ty = uniqAway (mkInScopeSet used) $ +#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) + mkSysLocal (fsLit nm) (mkBuiltinUnique 17) One ty +#else mkSysLocal (fsLit nm) (mkBuiltinUnique 17) ty +#endif freshDeadId :: VarSet -> String -> Type -> Id freshDeadId used nm ty = setIdOccInfo (freshId used nm ty) IAmDead diff --git a/examples/test/BasicTests.hs b/plugin/test/BasicTests.hs similarity index 100% rename from examples/test/BasicTests.hs rename to plugin/test/BasicTests.hs diff --git a/examples/test/Examples.hs b/plugin/test/Examples.hs similarity index 100% rename from examples/test/Examples.hs rename to plugin/test/Examples.hs diff --git a/examples/test/GoldTests.hs b/plugin/test/GoldTests.hs similarity index 100% rename from examples/test/GoldTests.hs rename to plugin/test/GoldTests.hs diff --git a/examples/test/Miscellany.hs b/plugin/test/Miscellany.hs similarity index 100% rename from examples/test/Miscellany.hs rename to plugin/test/Miscellany.hs diff --git a/examples/test/Utils.hs b/plugin/test/Utils.hs similarity index 100% rename from examples/test/Utils.hs rename to plugin/test/Utils.hs diff --git a/examples/test/gold/Makefile b/plugin/test/gold/Makefile similarity index 100% rename from examples/test/gold/Makefile rename to plugin/test/gold/Makefile diff --git a/examples/test/gold/add-adf-dot.golden b/plugin/test/gold/add-adf-dot.golden similarity index 100% rename from examples/test/gold/add-adf-dot.golden rename to plugin/test/gold/add-adf-dot.golden diff --git a/examples/test/gold/add-adf-syn.golden b/plugin/test/gold/add-adf-syn.golden similarity index 100% rename from examples/test/gold/add-adf-syn.golden rename to plugin/test/gold/add-adf-syn.golden diff --git a/examples/test/gold/add-adr-dot.golden b/plugin/test/gold/add-adr-dot.golden similarity index 100% rename from examples/test/gold/add-adr-dot.golden rename to plugin/test/gold/add-adr-dot.golden diff --git a/examples/test/gold/add-adr-syn.golden b/plugin/test/gold/add-adr-syn.golden similarity index 100% rename from examples/test/gold/add-adr-syn.golden rename to plugin/test/gold/add-adr-syn.golden diff --git a/examples/test/gold/add-dot.golden b/plugin/test/gold/add-dot.golden similarity index 100% rename from examples/test/gold/add-dot.golden rename to plugin/test/gold/add-dot.golden diff --git a/examples/test/gold/add-gradr-dot.golden b/plugin/test/gold/add-gradr-dot.golden similarity index 100% rename from examples/test/gold/add-gradr-dot.golden rename to plugin/test/gold/add-gradr-dot.golden diff --git a/examples/test/gold/add-gradr-syn.golden b/plugin/test/gold/add-gradr-syn.golden similarity index 100% rename from examples/test/gold/add-gradr-syn.golden rename to plugin/test/gold/add-gradr-syn.golden diff --git a/examples/test/gold/add-syn.golden b/plugin/test/gold/add-syn.golden similarity index 100% rename from examples/test/gold/add-syn.golden rename to plugin/test/gold/add-syn.golden diff --git a/examples/test/gold/add-uncurry-dot.golden b/plugin/test/gold/add-uncurry-dot.golden similarity index 100% rename from examples/test/gold/add-uncurry-dot.golden rename to plugin/test/gold/add-uncurry-dot.golden diff --git a/examples/test/gold/add-uncurry-syn.golden b/plugin/test/gold/add-uncurry-syn.golden similarity index 100% rename from examples/test/gold/add-uncurry-syn.golden rename to plugin/test/gold/add-uncurry-syn.golden diff --git a/examples/test/gold/complex-mul-a-dot.golden b/plugin/test/gold/complex-mul-a-dot.golden similarity index 100% rename from examples/test/gold/complex-mul-a-dot.golden rename to plugin/test/gold/complex-mul-a-dot.golden diff --git a/examples/test/gold/complex-mul-a-syn.golden b/plugin/test/gold/complex-mul-a-syn.golden similarity index 100% rename from examples/test/gold/complex-mul-a-syn.golden rename to plugin/test/gold/complex-mul-a-syn.golden diff --git a/examples/test/gold/complex-mul-dot.golden b/plugin/test/gold/complex-mul-dot.golden similarity index 100% rename from examples/test/gold/complex-mul-dot.golden rename to plugin/test/gold/complex-mul-dot.golden diff --git a/examples/test/gold/complex-mul-syn.golden b/plugin/test/gold/complex-mul-syn.golden similarity index 100% rename from examples/test/gold/complex-mul-syn.golden rename to plugin/test/gold/complex-mul-syn.golden diff --git a/examples/test/gold/cos-2x-adf-dot.golden b/plugin/test/gold/cos-2x-adf-dot.golden similarity index 100% rename from examples/test/gold/cos-2x-adf-dot.golden rename to plugin/test/gold/cos-2x-adf-dot.golden diff --git a/examples/test/gold/cos-2x-adf-syn.golden b/plugin/test/gold/cos-2x-adf-syn.golden similarity index 100% rename from examples/test/gold/cos-2x-adf-syn.golden rename to plugin/test/gold/cos-2x-adf-syn.golden diff --git a/examples/test/gold/cos-2x-adr-dot.golden b/plugin/test/gold/cos-2x-adr-dot.golden similarity index 100% rename from examples/test/gold/cos-2x-adr-dot.golden rename to plugin/test/gold/cos-2x-adr-dot.golden diff --git a/examples/test/gold/cos-2x-adr-syn.golden b/plugin/test/gold/cos-2x-adr-syn.golden similarity index 100% rename from examples/test/gold/cos-2x-adr-syn.golden rename to plugin/test/gold/cos-2x-adr-syn.golden diff --git a/examples/test/gold/cos-2x-gradr-dot.golden b/plugin/test/gold/cos-2x-gradr-dot.golden similarity index 100% rename from examples/test/gold/cos-2x-gradr-dot.golden rename to plugin/test/gold/cos-2x-gradr-dot.golden diff --git a/examples/test/gold/cos-2x-gradr-syn.golden b/plugin/test/gold/cos-2x-gradr-syn.golden similarity index 100% rename from examples/test/gold/cos-2x-gradr-syn.golden rename to plugin/test/gold/cos-2x-gradr-syn.golden diff --git a/examples/test/gold/cos-2xx-adf-dot.golden b/plugin/test/gold/cos-2xx-adf-dot.golden similarity index 100% rename from examples/test/gold/cos-2xx-adf-dot.golden rename to plugin/test/gold/cos-2xx-adf-dot.golden diff --git a/examples/test/gold/cos-2xx-adf-syn.golden b/plugin/test/gold/cos-2xx-adf-syn.golden similarity index 100% rename from examples/test/gold/cos-2xx-adf-syn.golden rename to plugin/test/gold/cos-2xx-adf-syn.golden diff --git a/examples/test/gold/cos-2xx-adr-dot.golden b/plugin/test/gold/cos-2xx-adr-dot.golden similarity index 100% rename from examples/test/gold/cos-2xx-adr-dot.golden rename to plugin/test/gold/cos-2xx-adr-dot.golden diff --git a/examples/test/gold/cos-2xx-adr-syn.golden b/plugin/test/gold/cos-2xx-adr-syn.golden similarity index 100% rename from examples/test/gold/cos-2xx-adr-syn.golden rename to plugin/test/gold/cos-2xx-adr-syn.golden diff --git a/examples/test/gold/cos-2xx-dot.golden b/plugin/test/gold/cos-2xx-dot.golden similarity index 100% rename from examples/test/gold/cos-2xx-dot.golden rename to plugin/test/gold/cos-2xx-dot.golden diff --git a/examples/test/gold/cos-2xx-gradr-dot.golden b/plugin/test/gold/cos-2xx-gradr-dot.golden similarity index 100% rename from examples/test/gold/cos-2xx-gradr-dot.golden rename to plugin/test/gold/cos-2xx-gradr-dot.golden diff --git a/examples/test/gold/cos-2xx-gradr-syn.golden b/plugin/test/gold/cos-2xx-gradr-syn.golden similarity index 100% rename from examples/test/gold/cos-2xx-gradr-syn.golden rename to plugin/test/gold/cos-2xx-gradr-syn.golden diff --git a/examples/test/gold/cos-2xx-syn.golden b/plugin/test/gold/cos-2xx-syn.golden similarity index 100% rename from examples/test/gold/cos-2xx-syn.golden rename to plugin/test/gold/cos-2xx-syn.golden diff --git a/examples/test/gold/cos-adf-dot.golden b/plugin/test/gold/cos-adf-dot.golden similarity index 100% rename from examples/test/gold/cos-adf-dot.golden rename to plugin/test/gold/cos-adf-dot.golden diff --git a/examples/test/gold/cos-adf-syn.golden b/plugin/test/gold/cos-adf-syn.golden similarity index 100% rename from examples/test/gold/cos-adf-syn.golden rename to plugin/test/gold/cos-adf-syn.golden diff --git a/examples/test/gold/cos-adr-dot.golden b/plugin/test/gold/cos-adr-dot.golden similarity index 100% rename from examples/test/gold/cos-adr-dot.golden rename to plugin/test/gold/cos-adr-dot.golden diff --git a/examples/test/gold/cos-adr-syn.golden b/plugin/test/gold/cos-adr-syn.golden similarity index 100% rename from examples/test/gold/cos-adr-syn.golden rename to plugin/test/gold/cos-adr-syn.golden diff --git a/examples/test/gold/cos-gradr-dot.golden b/plugin/test/gold/cos-gradr-dot.golden similarity index 100% rename from examples/test/gold/cos-gradr-dot.golden rename to plugin/test/gold/cos-gradr-dot.golden diff --git a/examples/test/gold/cos-gradr-syn.golden b/plugin/test/gold/cos-gradr-syn.golden similarity index 100% rename from examples/test/gold/cos-gradr-syn.golden rename to plugin/test/gold/cos-gradr-syn.golden diff --git a/examples/test/gold/cos-xpy-adf-dot.golden b/plugin/test/gold/cos-xpy-adf-dot.golden similarity index 100% rename from examples/test/gold/cos-xpy-adf-dot.golden rename to plugin/test/gold/cos-xpy-adf-dot.golden diff --git a/examples/test/gold/cos-xpy-adf-syn.golden b/plugin/test/gold/cos-xpy-adf-syn.golden similarity index 100% rename from examples/test/gold/cos-xpy-adf-syn.golden rename to plugin/test/gold/cos-xpy-adf-syn.golden diff --git a/examples/test/gold/cos-xpy-adr-dot.golden b/plugin/test/gold/cos-xpy-adr-dot.golden similarity index 100% rename from examples/test/gold/cos-xpy-adr-dot.golden rename to plugin/test/gold/cos-xpy-adr-dot.golden diff --git a/examples/test/gold/cos-xpy-adr-syn.golden b/plugin/test/gold/cos-xpy-adr-syn.golden similarity index 100% rename from examples/test/gold/cos-xpy-adr-syn.golden rename to plugin/test/gold/cos-xpy-adr-syn.golden diff --git a/examples/test/gold/cos-xpy-gradr-dot.golden b/plugin/test/gold/cos-xpy-gradr-dot.golden similarity index 100% rename from examples/test/gold/cos-xpy-gradr-dot.golden rename to plugin/test/gold/cos-xpy-gradr-dot.golden diff --git a/examples/test/gold/cos-xpy-gradr-syn.golden b/plugin/test/gold/cos-xpy-gradr-syn.golden similarity index 100% rename from examples/test/gold/cos-xpy-gradr-syn.golden rename to plugin/test/gold/cos-xpy-gradr-syn.golden diff --git a/examples/test/gold/cosSinProd-adr-dot.golden b/plugin/test/gold/cosSinProd-adr-dot.golden similarity index 100% rename from examples/test/gold/cosSinProd-adr-dot.golden rename to plugin/test/gold/cosSinProd-adr-dot.golden diff --git a/examples/test/gold/cosSinProd-adr-syn.golden b/plugin/test/gold/cosSinProd-adr-syn.golden similarity index 100% rename from examples/test/gold/cosSinProd-adr-syn.golden rename to plugin/test/gold/cosSinProd-adr-syn.golden diff --git a/examples/test/gold/cosSinProd-dot.golden b/plugin/test/gold/cosSinProd-dot.golden similarity index 100% rename from examples/test/gold/cosSinProd-dot.golden rename to plugin/test/gold/cosSinProd-dot.golden diff --git a/examples/test/gold/cosSinProd-syn.golden b/plugin/test/gold/cosSinProd-syn.golden similarity index 100% rename from examples/test/gold/cosSinProd-syn.golden rename to plugin/test/gold/cosSinProd-syn.golden diff --git a/examples/test/gold/dup-dot.golden b/plugin/test/gold/dup-dot.golden similarity index 100% rename from examples/test/gold/dup-dot.golden rename to plugin/test/gold/dup-dot.golden diff --git a/examples/test/gold/dup-syn.golden b/plugin/test/gold/dup-syn.golden similarity index 100% rename from examples/test/gold/dup-syn.golden rename to plugin/test/gold/dup-syn.golden diff --git a/examples/test/gold/fst-dot.golden b/plugin/test/gold/fst-dot.golden similarity index 100% rename from examples/test/gold/fst-dot.golden rename to plugin/test/gold/fst-dot.golden diff --git a/examples/test/gold/fst-syn.golden b/plugin/test/gold/fst-syn.golden similarity index 100% rename from examples/test/gold/fst-syn.golden rename to plugin/test/gold/fst-syn.golden diff --git a/examples/test/gold/horner-dot.golden b/plugin/test/gold/horner-dot.golden similarity index 100% rename from examples/test/gold/horner-dot.golden rename to plugin/test/gold/horner-dot.golden diff --git a/examples/test/gold/horner-syn.golden b/plugin/test/gold/horner-syn.golden similarity index 100% rename from examples/test/gold/horner-syn.golden rename to plugin/test/gold/horner-syn.golden diff --git a/examples/test/gold/log-2xx-dot.golden b/plugin/test/gold/log-2xx-dot.golden similarity index 100% rename from examples/test/gold/log-2xx-dot.golden rename to plugin/test/gold/log-2xx-dot.golden diff --git a/examples/test/gold/log-2xx-syn.golden b/plugin/test/gold/log-2xx-syn.golden similarity index 100% rename from examples/test/gold/log-2xx-syn.golden rename to plugin/test/gold/log-2xx-syn.golden diff --git a/examples/test/gold/magSqr-adf-dot.golden b/plugin/test/gold/magSqr-adf-dot.golden similarity index 100% rename from examples/test/gold/magSqr-adf-dot.golden rename to plugin/test/gold/magSqr-adf-dot.golden diff --git a/examples/test/gold/magSqr-adf-syn.golden b/plugin/test/gold/magSqr-adf-syn.golden similarity index 100% rename from examples/test/gold/magSqr-adf-syn.golden rename to plugin/test/gold/magSqr-adf-syn.golden diff --git a/examples/test/gold/magSqr-adr-dot.golden b/plugin/test/gold/magSqr-adr-dot.golden similarity index 100% rename from examples/test/gold/magSqr-adr-dot.golden rename to plugin/test/gold/magSqr-adr-dot.golden diff --git a/examples/test/gold/magSqr-adr-syn.golden b/plugin/test/gold/magSqr-adr-syn.golden similarity index 100% rename from examples/test/gold/magSqr-adr-syn.golden rename to plugin/test/gold/magSqr-adr-syn.golden diff --git a/examples/test/gold/magSqr-dot.golden b/plugin/test/gold/magSqr-dot.golden similarity index 100% rename from examples/test/gold/magSqr-dot.golden rename to plugin/test/gold/magSqr-dot.golden diff --git a/examples/test/gold/magSqr-gradr-dot.golden b/plugin/test/gold/magSqr-gradr-dot.golden similarity index 100% rename from examples/test/gold/magSqr-gradr-dot.golden rename to plugin/test/gold/magSqr-gradr-dot.golden diff --git a/examples/test/gold/magSqr-gradr-syn.golden b/plugin/test/gold/magSqr-gradr-syn.golden similarity index 100% rename from examples/test/gold/magSqr-gradr-syn.golden rename to plugin/test/gold/magSqr-gradr-syn.golden diff --git a/examples/test/gold/magSqr-syn.golden b/plugin/test/gold/magSqr-syn.golden similarity index 100% rename from examples/test/gold/magSqr-syn.golden rename to plugin/test/gold/magSqr-syn.golden diff --git a/examples/test/gold/sin-adf-dot.golden b/plugin/test/gold/sin-adf-dot.golden similarity index 100% rename from examples/test/gold/sin-adf-dot.golden rename to plugin/test/gold/sin-adf-dot.golden diff --git a/examples/test/gold/sin-adf-syn.golden b/plugin/test/gold/sin-adf-syn.golden similarity index 100% rename from examples/test/gold/sin-adf-syn.golden rename to plugin/test/gold/sin-adf-syn.golden diff --git a/examples/test/gold/sin-adr-dot.golden b/plugin/test/gold/sin-adr-dot.golden similarity index 100% rename from examples/test/gold/sin-adr-dot.golden rename to plugin/test/gold/sin-adr-dot.golden diff --git a/examples/test/gold/sin-adr-syn.golden b/plugin/test/gold/sin-adr-syn.golden similarity index 100% rename from examples/test/gold/sin-adr-syn.golden rename to plugin/test/gold/sin-adr-syn.golden diff --git a/examples/test/gold/sin-gradr-dot.golden b/plugin/test/gold/sin-gradr-dot.golden similarity index 100% rename from examples/test/gold/sin-gradr-dot.golden rename to plugin/test/gold/sin-gradr-dot.golden diff --git a/examples/test/gold/sin-gradr-syn.golden b/plugin/test/gold/sin-gradr-syn.golden similarity index 100% rename from examples/test/gold/sin-gradr-syn.golden rename to plugin/test/gold/sin-gradr-syn.golden diff --git a/examples/test/gold/sqr-adf-dot.golden b/plugin/test/gold/sqr-adf-dot.golden similarity index 100% rename from examples/test/gold/sqr-adf-dot.golden rename to plugin/test/gold/sqr-adf-dot.golden diff --git a/examples/test/gold/sqr-adf-syn.golden b/plugin/test/gold/sqr-adf-syn.golden similarity index 100% rename from examples/test/gold/sqr-adf-syn.golden rename to plugin/test/gold/sqr-adf-syn.golden diff --git a/examples/test/gold/sqr-adr-dot.golden b/plugin/test/gold/sqr-adr-dot.golden similarity index 100% rename from examples/test/gold/sqr-adr-dot.golden rename to plugin/test/gold/sqr-adr-dot.golden diff --git a/examples/test/gold/sqr-adr-syn.golden b/plugin/test/gold/sqr-adr-syn.golden similarity index 100% rename from examples/test/gold/sqr-adr-syn.golden rename to plugin/test/gold/sqr-adr-syn.golden diff --git a/examples/test/gold/sqr-dot.golden b/plugin/test/gold/sqr-dot.golden similarity index 100% rename from examples/test/gold/sqr-dot.golden rename to plugin/test/gold/sqr-dot.golden diff --git a/examples/test/gold/sqr-gradr-dot.golden b/plugin/test/gold/sqr-gradr-dot.golden similarity index 100% rename from examples/test/gold/sqr-gradr-dot.golden rename to plugin/test/gold/sqr-gradr-dot.golden diff --git a/examples/test/gold/sqr-gradr-syn.golden b/plugin/test/gold/sqr-gradr-syn.golden similarity index 100% rename from examples/test/gold/sqr-gradr-syn.golden rename to plugin/test/gold/sqr-gradr-syn.golden diff --git a/examples/test/gold/sqr-syn.golden b/plugin/test/gold/sqr-syn.golden similarity index 100% rename from examples/test/gold/sqr-syn.golden rename to plugin/test/gold/sqr-syn.golden diff --git a/examples/test/gold/twice-adf-dot.golden b/plugin/test/gold/twice-adf-dot.golden similarity index 100% rename from examples/test/gold/twice-adf-dot.golden rename to plugin/test/gold/twice-adf-dot.golden diff --git a/examples/test/gold/twice-adf-syn.golden b/plugin/test/gold/twice-adf-syn.golden similarity index 100% rename from examples/test/gold/twice-adf-syn.golden rename to plugin/test/gold/twice-adf-syn.golden diff --git a/examples/test/gold/twice-adr-dot.golden b/plugin/test/gold/twice-adr-dot.golden similarity index 100% rename from examples/test/gold/twice-adr-dot.golden rename to plugin/test/gold/twice-adr-dot.golden diff --git a/examples/test/gold/twice-adr-syn.golden b/plugin/test/gold/twice-adr-syn.golden similarity index 100% rename from examples/test/gold/twice-adr-syn.golden rename to plugin/test/gold/twice-adr-syn.golden diff --git a/examples/test/gold/twice-dot.golden b/plugin/test/gold/twice-dot.golden similarity index 100% rename from examples/test/gold/twice-dot.golden rename to plugin/test/gold/twice-dot.golden diff --git a/examples/test/gold/twice-gradr-dot.golden b/plugin/test/gold/twice-gradr-dot.golden similarity index 100% rename from examples/test/gold/twice-gradr-dot.golden rename to plugin/test/gold/twice-gradr-dot.golden diff --git a/examples/test/gold/twice-gradr-syn.golden b/plugin/test/gold/twice-gradr-syn.golden similarity index 100% rename from examples/test/gold/twice-gradr-syn.golden rename to plugin/test/gold/twice-gradr-syn.golden diff --git a/examples/test/gold/twice-syn.golden b/plugin/test/gold/twice-syn.golden similarity index 100% rename from examples/test/gold/twice-syn.golden rename to plugin/test/gold/twice-syn.golden diff --git a/examples/test/gold/xp3y-dot.golden b/plugin/test/gold/xp3y-dot.golden similarity index 100% rename from examples/test/gold/xp3y-dot.golden rename to plugin/test/gold/xp3y-dot.golden diff --git a/examples/test/gold/xp3y-syn.golden b/plugin/test/gold/xp3y-syn.golden similarity index 100% rename from examples/test/gold/xp3y-syn.golden rename to plugin/test/gold/xp3y-syn.golden diff --git a/satisfy/src/ConCat/BuildDictionary.hs b/satisfy/src/ConCat/BuildDictionary.hs index c35579b18..81d57bcef 100644 --- a/satisfy/src/ConCat/BuildDictionary.hs +++ b/satisfy/src/ConCat/BuildDictionary.hs @@ -32,11 +32,41 @@ module ConCat.BuildDictionary import Data.Monoid (Any(..)) import Data.Char (isSpace) import Control.Monad (filterM,when) - -import GhcPlugins - import Control.Arrow (second) +#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) +import GHC.Core.Predicate +import GHC.Core.TyCo.Rep (CoercionHole(..), Type(..)) +import GHC.Core.TyCon (isTupleTyCon) +import GHC.HsToCore.Binds +import GHC.HsToCore.Monad +import GHC.Plugins +import GHC.Tc.Errors(warnAllUnsolved) +import GHC.Tc.Module +import GHC.Tc.Solver +import GHC.Tc.Solver.Interact (solveSimpleGivens) +import GHC.Tc.Solver.Monad -- (TcS,runTcS) +import GHC.Tc.Types +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Evidence (evBindMapBinds) +import GHC.Tc.Types.Origin +import qualified GHC.Tc.Utils.Instantiate as TcMType +import GHC.Tc.Utils.Monad (getCtLocM,traceTc) +import GHC.Tc.Utils.Zonk (emptyZonkEnv,zonkEvBinds) +import GHC.Types.Unique (mkUniqueGrimily) +import qualified GHC.Types.Unique.Set as NonDetSet +#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) +import GHC.Runtime.Context (InteractiveContext (..), InteractiveImport (..)) +import GHC.Types.Error (getErrorMessages, getWarningMessages) +import GHC.Unit.Finder (FindResult (..), findExposedPackageModule) +import GHC.Unit.Module.Deps (Dependencies (..)) +import GHC.Utils.Error (pprMsgEnvelopeBagWithLoc) +#else +import GHC.Driver.Finder (findExposedPackageModule) +import GHC.Utils.Error (pprErrMsgBagWithLoc) +#endif +#else +import GhcPlugins import TyCoRep (CoercionHole(..), Type(..)) import TyCon (isTupleTyCon) import TcHsSyn (emptyZonkEnv,zonkEvBinds) @@ -59,7 +89,6 @@ import DsBinds import TcSimplify import TcRnTypes import ErrUtils (pprErrMsgBagWithLoc) -import Encoding (zEncodeString) import Unique (mkUniqueGrimily) import Finder (findExposedPackageModule) @@ -67,12 +96,20 @@ import TcRnDriver #if MIN_VERSION_GLASGOW_HASKELL(8,2,0,0) import qualified UniqSet as NonDetSet #endif +#endif -- Temp -- import HERMIT.GHC.Typechecker (initTcFromModGuts) -- import ConCat.GHC import ConCat.Simplify +isEvVarType' :: Type -> Bool +#if MIN_VERSION_GLASGOW_HASKELL(8, 8, 0, 0) +isEvVarType' = isEvVarType +#else +isEvVarType' = isPredTy +#endif + isFound :: FindResult -> Bool isFound (Found _ _) = True isFound _ = False @@ -80,6 +117,20 @@ isFound _ = False moduleIsOkay :: HscEnv -> ModuleName -> IO Bool moduleIsOkay env mname = isFound <$> findExposedPackageModule env mname Nothing +mkLocalId' :: HasDebugCallStack => Name -> Type -> Id +#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) +mkLocalId' n = mkLocalId n One +#else +mkLocalId' = mkLocalId +#endif + +mkWildCase' :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr +#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) +mkWildCase' ce t = mkWildCase ce (linear t) +#else +mkWildCase' = mkWildCase +#endif + #if MIN_VERSION_GLASGOW_HASKELL(8,2,0,0) uniqSetToList :: UniqSet a -> [a] uniqSetToList = NonDetSet.nonDetEltsUniqSet @@ -105,9 +156,15 @@ runTcM env0 dflags guts m = do orphans <- filterM (moduleIsOkay env0) (moduleName <$> dep_orphs (mg_deps guts)) -- pprTrace' "runTcM orphans" (ppr orphans) (return ()) (msgs, mr) <- runTcInteractive (env orphans) m +#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) + let showMsgs msg = showSDoc dflags $ vcat $ + text "Errors:" : pprMsgEnvelopeBagWithLoc (getErrorMessages msg) + ++ text "Warnings:" : pprMsgEnvelopeBagWithLoc (getWarningMessages msg) +#else let showMsgs (warns, errs) = showSDoc dflags $ vcat $ text "Errors:" : pprErrMsgBagWithLoc errs ++ text "Warnings:" : pprErrMsgBagWithLoc warns +#endif maybe (fail $ showMsgs msgs) return mr where imports0 = ic_imports (hsc_IC env0) @@ -184,7 +241,7 @@ buildDictionary :: HscEnv -> DynFlags -> ModGuts -> UniqSupply -> InScopeEnv -> buildDictionary env dflags guts uniqSupply inScope evType@(TyConApp tyCon evTypes) ev goalTy | isTupleTyCon tyCon = reallyBuildDictionary env dflags guts uniqSupply inScope evType evTypes ev goalTy -- only 1-tuples in Haskell -buildDictionary env dflags guts uniqSupply inScope evType ev goalTy | isEvVarType evType = +buildDictionary env dflags guts uniqSupply inScope evType ev goalTy | isEvVarType' evType = reallyBuildDictionary env dflags guts uniqSupply inScope evType [evType] ev goalTy buildDictionary _env _dflags _guts _uniqSupply _inScope evT _ev _goalTy = pprPanic "evidence type mismatch" (ppr evT) @@ -196,7 +253,7 @@ reallyBuildDictionary env dflags guts uniqSupply _inScope evType evTypes ev goal where evIds = [ local | (evTy, unq) <- evTypes `zip` (uniqsFromSupply uniqSupply) - , let local = mkLocalId (mkSystemVarName unq evVarName) evTy ] + , let local = mkLocalId' (mkSystemVarName unq evVarName) evTy ] evIdSet = mkVarSet evIds reassemble Nothing = Left (text "unsolved constraints") @@ -220,7 +277,11 @@ reallyBuildDictionary env dflags guts uniqSupply _inScope evType evTypes ev goal then dict else case evIds of [evId] -> mkCoreLet (NonRec evId ev) dict - _ -> mkWildCase ev evType goalTy [(DataAlt (tupleDataCon Boxed (length evIds)), evIds, dict)] +#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) + _ -> mkWildCase' ev evType goalTy [Alt (DataAlt (tupleDataCon Boxed (length evIds))) evIds dict] +#else + _ -> mkWildCase' ev evType goalTy [(DataAlt (tupleDataCon Boxed (length evIds)), evIds, dict)] +#endif evVarName :: FastString evVarName = mkFastString "evidence" @@ -301,8 +362,13 @@ annotateExpr fnId fnId' typeArgsCount expr0 = go _evVars expr@(Type _) = expr go _evVars expr@(Coercion _) = expr +#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) + annotateAlt evVars (Alt con binders rhs) = + Alt con binders $ go (extendEvVarsList evVars binders) rhs +#else annotateAlt evVars (con, binders, rhs) = (con, binders, go (extendEvVarsList evVars binders) rhs) +#endif -- Maybe place in a GHC utils module. diff --git a/satisfy/src/ConCat/Satisfy/Plugin.hs b/satisfy/src/ConCat/Satisfy/Plugin.hs index 62d32148f..89a6217f1 100644 --- a/satisfy/src/ConCat/Satisfy/Plugin.hs +++ b/satisfy/src/ConCat/Satisfy/Plugin.hs @@ -10,11 +10,24 @@ module ConCat.Satisfy.Plugin where import System.IO.Unsafe (unsafePerformIO) -- GHC API +#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) +import GHC.Core.Unfold (defaultUnfoldingOpts) +import qualified GHC.Driver.Backend as Backend +import GHC.Utils.Logger (getLogger) +#endif +#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) +import GHC.Core.Class (classAllSelIds) +import GHC.Core.Make (mkCoreTup) +import GHC.Plugins as GHC +import GHC.Runtime.Loader +import GHC.Types.Id.Make (mkDictSelRhs) +#else import GhcPlugins as GHC import Class (classAllSelIds) import MkId (mkDictSelRhs) import MkCore (mkCoreTup) import DynamicLoading +#endif import ConCat.BuildDictionary (buildDictionary, annotateEvidence) import ConCat.Inline.Plugin (findId) @@ -35,8 +48,14 @@ install _opts todos = do dflags <- getDynFlags -- Unfortunately, the plugin doesn't work in GHCi. Until fixed, -- disable under GHCi, so we can at least type-check conveniently. +#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) + logger <- getLogger + if backend dflags == Backend.Interpreter then + return todos +#else if hscTarget dflags == HscInterpreted then return todos +#endif else do #if !MIN_VERSION_GLASGOW_HASKELL(8,2,0,0) reinitializeGlobals @@ -48,7 +67,7 @@ install _opts todos = addRule guts = do satisfyPV <- findId "ConCat.Satisfy" "satisfy'" pprTrace "adding satisfyRule" empty (return ()) - return (on_mg_rules (++ [satisfyRule hscEnv guts uniqSupply satisfyPV]) guts) + return (on_mg_rules (++ [satisfyRule hscEnv guts uniqSupply satisfyPV dflags]) guts) isOurRule r = (isBuiltinRule r) && (ru_name r == satisfyRuleName) delRule guts = do pprTrace "removing satisfyRule" empty (return ()) @@ -66,6 +85,14 @@ install _opts todos = , sm_inline = False -- important , sm_eta_expand = False -- ?? , sm_case_case = True +#if MIN_VERSION_GLASGOW_HASKELL(9,2,2,0) + , sm_cast_swizzle = True +#endif +#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) + , sm_uf_opts = defaultUnfoldingOpts + , sm_pre_inline = False + , sm_logger = logger +#endif #if MIN_VERSION_GLASGOW_HASKELL(8,4,0,0) , sm_dflags = dflags #endif @@ -89,12 +116,12 @@ satisfyRuleName :: FastString satisfyRuleName = fsLit "satisfy'Rule" -- satisfy :: forall c z. (c => z) -> z -satisfyRule :: HscEnv -> ModGuts -> UniqSupply -> Id -> CoreRule -satisfyRule env guts uniqSupply satisfyPV = BuiltinRule +satisfyRule :: HscEnv -> ModGuts -> UniqSupply -> Id -> DynFlags -> CoreRule +satisfyRule env guts uniqSupply satisfyPV dflags = BuiltinRule { ru_name = satisfyRuleName , ru_fn = varName satisfyPV , ru_nargs = 5 -- including type args - , ru_try = satisfy env guts uniqSupply + , ru_try = const $ satisfy env guts uniqSupply dflags } satisfy :: HscEnv -> ModGuts -> UniqSupply -> DynFlags -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr diff --git a/satisfy/src/ConCat/Simplify.hs b/satisfy/src/ConCat/Simplify.hs index c0e64d619..e86c2b44d 100644 --- a/satisfy/src/ConCat/Simplify.hs +++ b/satisfy/src/ConCat/Simplify.hs @@ -22,6 +22,24 @@ module ConCat.Simplify (simplifyE) where import System.IO.Unsafe (unsafePerformIO) +#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) +#if !MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) +import GHC.Core (emptyRuleEnv) +#endif +import GHC.Core.FamInstEnv (emptyFamInstEnvs) +import GHC.Core.Opt.OccurAnal (occurAnalyseExpr) +import GHC.Core.Opt.Simplify (simplExpr) +import GHC.Core.Opt.Simplify.Env +import GHC.Core.Opt.Simplify.Monad (SimplM,initSmpl) +import GHC.Core.Stats (exprSize) +import GHC.Plugins +#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) +import GHC.Core.Unfold (defaultUnfoldingOpts) +import qualified GHC.Utils.Logger as Err +#else +import qualified GHC.Utils.Error as Err +#endif +#else import GhcPlugins import Simplify (simplExpr) import SimplMonad (SimplM,initSmpl) @@ -31,7 +49,19 @@ import SimplEnv import CoreStats (exprSize) import OccurAnal (occurAnalyseExpr) import FamInstEnv (emptyFamInstEnvs) +#endif +#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) +dumpIfSet_dyn' :: Err.Logger -> DynFlags -> DumpFlag -> String -> SDoc -> IO () +dumpIfSet_dyn' logger dflags dumpFlag str = + Err.dumpIfSet_dyn logger dflags dumpFlag str Err.FormatCore +#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) +dumpIfSet_dyn' :: DynFlags -> DumpFlag -> String -> SDoc -> IO () +dumpIfSet_dyn' dflags dumpFlag str = Err.dumpIfSet_dyn dflags dumpFlag str Err.FormatCore +#else +dumpIfSet_dyn' :: DynFlags -> DumpFlag -> String -> SDoc -> IO () +dumpIfSet_dyn' = Err.dumpIfSet_dyn +#endif {-------------------------------------------------------------------- Simplification @@ -53,15 +83,26 @@ simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do -- -- Also used by Template Haskell simplifyExpr dflags inline expr - = do us <- mkSplitUniqSupply 'r' - let sz = exprSize expr + = do let sz = exprSize expr +#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) + logger <- Err.initLogger + (expr', counts) <- initSmpl logger dflags emptyRuleEnv + emptyFamInstEnvs sz + (simplExprGently (simplEnvForCcc dflags inline logger) expr) + Err.dumpIfSet logger dflags (dopt Opt_D_dump_simpl_stats dflags) + "Simplifier statistics" (pprSimplCount counts) + dumpIfSet_dyn' logger dflags Opt_D_dump_simpl "Simplified expression" + (ppr expr') +#else + us <- mkSplitUniqSupply 'r' (expr', counts) <- initSmpl dflags emptyRuleEnv emptyFamInstEnvs us sz (simplExprGently (simplEnvForCcc dflags inline) expr) Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags) "Simplifier statistics" (pprSimplCount counts) - Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression" - (ppr expr') + dumpIfSet_dyn' dflags Opt_D_dump_simpl "Simplified expression" + (ppr expr') +#endif return expr' -- Copied from SimplCore (not exported) @@ -71,6 +112,27 @@ simplExprGently env expr = do simplExpr env (occurAnalyseExpr expr1) -- Like simplEnvForGHCi but with inlining. +#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) +simplEnvForCcc :: DynFlags -> Bool -> Err.Logger -> SimplEnv +simplEnvForCcc dflags inline logger + = mkSimplEnv $ SimplMode { sm_names = ["Simplify for ccc"] + , sm_phase = Phase 0 -- Was InitialPhase + , sm_rules = rules_on + , sm_inline = inline -- was False + , sm_eta_expand = eta_expand_on + , sm_case_case = True + , sm_uf_opts = defaultUnfoldingOpts + , sm_pre_inline = inline + , sm_logger = logger + , sm_dflags = dflags +#if MIN_VERSION_GLASGOW_HASKELL(9,2,2,0) + , sm_cast_swizzle = True +#endif + } + where + rules_on = gopt Opt_EnableRewriteRules dflags + eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags +#else simplEnvForCcc :: DynFlags -> Bool -> SimplEnv simplEnvForCcc dflags inline = mkSimplEnv $ SimplMode { sm_names = ["Simplify for ccc"] @@ -86,3 +148,4 @@ simplEnvForCcc dflags inline where rules_on = gopt Opt_EnableRewriteRules dflags eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags +#endif