Add support for GHC 9.

Mostly trivial changes, but we now get the `DynFlags` from `installCoreToDos`
rather than each application of `BuiltinRule.ru_try`.

This continues to work just fine for GHC 8.10, but doesn't quite work on GHC 9.0
for some reason. I don't think it's the `DynFlags` changes (as that's applied to
all GHC versions). But running on GHC 9.0 always fails with "isDeadEndId
cccV" (this is slightly stricter than `isBottomingId` in earlier GHCs, but
removing that `pprPanic` still fails, just with "Oops: toCcc'' called" instead).

Fixes compiling-to-categories#98.

Author: sellout

.github/workflows/ci.yml

@@ -19,6 +19,7 @@ jobs:
           # - "8.6.1"
           - "8.8.1"
           - "8.10.1"
+          - "9.0.1"
     steps:
       - uses: actions/checkout@v2
       - uses: haskell/actions/setup@v1

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

examples/src/ConCat/Dual.hs

@@ -224,7 +224,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 #-}
 

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

inline/src/ConCat/Inline/Plugin.hs

@@ -12,10 +12,17 @@ import qualified ConCat.Inline.ClassOp as CO
 import Data.List (elemIndex)
 
 -- GHC API
+#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

plugin/src/ConCat/Plugin.hs

@@ -36,13 +36,32 @@ 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)
+import GHC.Types.Unique (mkBuiltinUnique)
+import qualified GHC.Types.Unique.DFM as DFMap
+#else
 import GhcPlugins as GHC hiding (substTy,cat)
 import Class (classAllSelIds)
 import CoreArity (etaExpand)
@@ -57,32 +76,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 +163,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 +235,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 +313,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 +371,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 +634,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 +883,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 +934,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 +951,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 +970,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 +1374,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 +1449,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 +1605,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 +1747,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 +1809,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 +1895,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