diff --git a/dex.cabal b/dex.cabal index 1b6b7b771..b44c6a2ae 100644 --- a/dex.cabal +++ b/dex.cabal @@ -49,7 +49,7 @@ library , Builder , CUDA , Cat - , CheapReduction + , Visitor , CheckType , ConcreteSyntax , Core @@ -96,7 +96,6 @@ library , Types.OpNames , Types.Source , QueryType - , QueryTypePure , Util , Vectorize if flag(live) diff --git a/src/lib/Builder.hs b/src/lib/Builder.hs index c539d01b4..cf3940b10 100644 --- a/src/lib/Builder.hs +++ b/src/lib/Builder.hs @@ -10,19 +10,26 @@ module Builder where import Control.Applicative +import Control.Category ((>>>)) import Control.Monad import Control.Monad.Reader import Control.Monad.Writer.Strict hiding (Alt) import Control.Monad.State.Strict (MonadState (..), StateT (..), runStateT) import qualified Data.Map.Strict as M import Data.Foldable (fold) +import Data.Functor ((<&>)) +import Data.Graph (graphFromEdges, topSort) +import Data.List (elemIndex) +import Data.Text.Prettyprint.Doc (Pretty (..)) +import Foreign.Ptr + +import qualified Unsafe.Coerce as TrulyUnsafe import Data.Graph (graphFromEdges, topSort) import Data.Text.Prettyprint.Doc (Pretty (..)) import Foreign.Ptr import qualified Unsafe.Coerce as TrulyUnsafe -import CheapReduction import Core import Err import IRVariants @@ -34,7 +41,8 @@ import Types.Core import Types.Imp import Types.Primitives import Types.Source -import Util (enumerate, transitiveClosureM, bindM2, toSnocList, (...)) +import Util (enumerate, transitiveClosureM, bindM2, toSnocList, (...), Tree (..)) +import Visitor -- === Ordinary (local) builder class === @@ -49,6 +57,12 @@ class Builder r m => ScopableBuilder (r::IR) (m::MonadKind1) | m -> r where -> (forall l. DExt n l => Nest (Decl r) n l -> e l -> m l a) -> m n a +buildScoped2 + :: (ScopableBuilder r m, SinkableE e) + => (forall l. (Emits l, DExt n l) => m l (Nest (Decl r) n l -> a)) + -> m n a +buildScoped2 cont = undefined -- buildScopedAndThen cont \decls body -> return $ Abs decls body + buildScoped :: (ScopableBuilder r m, SinkableE e) => (forall l. (Emits l, DExt n l) => m l (e l)) @@ -61,6 +75,10 @@ type CBuilder = Builder CoreIR type Builder2 (r::IR) (m :: MonadKind2) = forall i. Builder r (m i) type ScopableBuilder2 (r::IR) (m :: MonadKind2) = forall i. ScopableBuilder r (m i) +type BuilderEmits r m n = (Builder r m, Emits n, IRRep r) +type CBuilderEmits m n = BuilderEmits CoreIR m n +type SBuilderEmits m n = BuilderEmits SimpIR m n + emitDecl :: (Builder r m, Emits n) => NameHint -> LetAnn -> Expr r n -> m n (AtomVar r n) emitDecl _ _ (Atom (Var n)) = return n emitDecl hint ann expr = rawEmitDecl hint ann expr @@ -78,23 +96,23 @@ emitOp :: (Builder r m, IsPrimOp e, Emits n) => e r n -> m n (Atom r n) emitOp op = Var <$> emit (PrimOp $ toPrimOp op) {-# INLINE emitOp #-} -emitExpr :: (Builder r m, Emits n) => Expr r n -> m n (Atom r n) +emitExpr :: BuilderEmits r m n => Expr r n -> m n (Atom r n) emitExpr expr = Var <$> emit expr {-# INLINE emitExpr #-} -emitHof :: (Builder r m, Emits n) => Hof r n -> m n (Atom r n) +emitHof :: BuilderEmits r m n => Hof r n -> m n (Atom r n) emitHof hof = mkTypedHof hof >>= emitOp -mkTypedHof :: (EnvReader m, IRRep r) => Hof r n -> m n (TypedHof r n) +mkTypedHof :: BuilderEmits r m n => Hof r n -> m n (TypedHof r n) mkTypedHof hof = do effTy <- effTyOfHof hof return $ TypedHof effTy hof -emitUnOp :: (Builder r m, Emits n) => UnOp -> Atom r n -> m n (Atom r n) +emitUnOp :: BuilderEmits r m n => UnOp -> Atom r n -> m n (Atom r n) emitUnOp op x = emitOp $ UnOp op x {-# INLINE emitUnOp #-} -emitBlock :: (Builder r m, Emits n) => Block r n -> m n (Atom r n) +emitBlock :: BuilderEmits r m n => Block r n -> m n (Atom r n) emitBlock = emitDecls emitDecls :: (Builder r m, Emits n, RenameE e, SinkableE e) @@ -109,7 +127,7 @@ emitDecls' (Nest (Let b (DeclBinding ann expr)) rest) e = do AtomVar v _ <- emitDecl (getNameHint b) ann expr' extendSubst (b @> v) $ emitDecls' rest e -emitExprToAtom :: (Builder r m, Emits n) => Expr r n -> m n (Atom r n) +emitExprToAtom :: BuilderEmits r m n => Expr r n -> m n (Atom r n) emitExprToAtom (Atom atom) = return atom emitExprToAtom expr = Var <$> emit expr {-# INLINE emitExprToAtom #-} @@ -649,7 +667,7 @@ buildAbs hint binding cont = do typesFromNonDepBinderNest :: (EnvReader m, Fallible1 m, IRRep r) - => Nest (Binder r) n l -> m n [Type r n] + => Binders r n l -> m n [Type r n] typesFromNonDepBinderNest Empty = return [] typesFromNonDepBinderNest (Nest b rest) = do Abs rest' UnitE <- return $ assumeConst $ Abs (UnaryNest b) $ Abs rest UnitE @@ -662,7 +680,7 @@ buildUnaryLamExpr -> (forall l. (Emits l, Distinct l, DExt n l) => AtomVar r l -> m l (Atom r l)) -> m n (LamExpr r n) buildUnaryLamExpr hint ty cont = do - bs <- withFreshBinder hint ty \b -> return $ EmptyAbs (UnaryNest b) + bs <- withFreshBinder hint ty \b -> return $ EmptyAbs (UnaryNest (PlainBD b)) buildLamExpr bs \[v] -> cont v buildBinaryLamExpr @@ -672,21 +690,22 @@ buildBinaryLamExpr -> m n (LamExpr r n) buildBinaryLamExpr (h1,t1) (h2,t2) cont = do bs <- withFreshBinder h1 t1 \b1 -> withFreshBinder h2 (sink t2) \b2 -> - return $ EmptyAbs $ BinaryNest b1 b2 + return $ EmptyAbs $ BinaryNest (PlainBD b1) (PlainBD b2) buildLamExpr bs \[v1, v2] -> cont v1 v2 buildLamExpr :: ScopableBuilder r m - => (EmptyAbs (Nest (Binder r)) n) + => (Abs (Binders r) any n) -> (forall l. (Emits l, Distinct l, DExt n l) => [AtomVar r l] -> m l (Atom r l)) -> m n (LamExpr r n) -buildLamExpr (Abs bs UnitE) cont = case bs of - Empty -> LamExpr Empty <$> buildBlock (cont []) - Nest b rest -> do - Abs b' (LamExpr bs' body') <- buildAbs (getNameHint b) (binderType b) \v -> do - rest' <- applySubst (b@>SubstVal (Var v)) $ EmptyAbs rest - buildLamExpr rest' \vs -> cont $ sink v : vs - return $ LamExpr (Nest b' bs') body' +buildLamExpr (Abs bs _) cont = undefined +-- buildLamExpr (Abs bs _) cont = case bs of + -- Empty -> LamExpr Empty <$> buildBlock (cont []) + -- Nest b rest -> do + -- Abs b' (LamExpr bs' body') <- buildAbs (getNameHint b) (binderType b) \v -> do + -- rest' <- instantiate (Abs (UnaryNest b) (EmptyAbs rest)) [Var v] + -- buildLamExpr rest' \vs -> cont $ sink v : vs + -- return $ LamExpr (Nest (PlainBD b') bs') body' buildTopLamFromPi :: ScopableBuilder r m @@ -765,7 +784,7 @@ buildEffLam hint ty body = do let ref = binderVar b hVar <- sinkM $ binderVar h body' <- buildBlock $ body (sink hVar) $ sink ref - return $ LamExpr (BinaryNest h b) body' + return $ LamExpr (BinaryNest (PlainBD h) (PlainBD b)) body' buildForAnn :: (Emits n, ScopableBuilder r m) @@ -776,7 +795,7 @@ buildForAnn hint ann (IxType iTy ixDict) body = do lam <- withFreshBinder hint iTy \b -> do let v = binderVar b body' <- buildBlock $ body $ sink v - return $ LamExpr (UnaryNest b) body' + return $ UnaryLamExpr b body' emitHof $ For ann (IxType iTy ixDict) lam buildFor :: (Emits n, ScopableBuilder r m) @@ -862,7 +881,7 @@ zeroAt ty = liftEmitBuilder $ go ty where BaseTy bt -> return $ Con $ Lit $ zeroLit bt ProdTy tys -> ProdVal <$> mapM go tys TabPi tabPi -> buildFor (getNameHint tabPi) Fwd (tabIxType tabPi) \i -> - go =<< instantiate (sink tabPi) [Var i] + go =<< instantiate tabPi [Var i] _ -> unreachable zeroLit bt = case bt of Scalar Float64Type -> Float64Lit 0.0 @@ -1030,44 +1049,39 @@ getProjRef i r = emitOp =<< mkProjRef r i -- ProjectElt atoms are always fully reduced (to avoid type errors between two -- equivalent types spelled differently). getUnpacked :: (Fallible1 m, EnvReader m, IRRep r) => Atom r n -> m n [Atom r n] -getUnpacked atom = do - atom' <- cheapNormalize atom - ty <- return $ getType atom' - positions <- case ty of - ProdTy tys -> return $ void tys - DepPairTy _ -> return [(), ()] - _ -> error $ "not a product type: " ++ pprint ty - forM (enumerate positions) \(i, _) -> - normalizeProj (ProjectProduct i) atom' -{-# SCC getUnpacked #-} +getUnpacked atom = undefined +-- getUnpacked atom = do +-- atom' <- cheapNormalize atom +-- ty <- return $ getType atom' +-- positions <- case ty of +-- ProdTy tys -> return $ void tys +-- DepPairTy _ -> return [(), ()] +-- _ -> error $ "not a product type: " ++ pprint ty +-- forM (enumerate positions) \(i, _) -> +-- normalizeProj (ProjectProduct i) atom' +-- {-# SCC getUnpacked #-} getProj :: (Builder r m, Emits n) => Int -> Atom r n -> m n (Atom r n) -getProj i atom = do - atom' <- cheapNormalize atom - normalizeProj (ProjectProduct i) atom' +getProj i atom = undefined +-- getProj i atom = do +-- atom' <- cheapNormalize atom +-- normalizeProj (ProjectProduct i) atom' emitUnpacked :: (Builder r m, Emits n) => Atom r n -> m n [AtomVar r n] emitUnpacked tup = do xs <- getUnpacked tup forM xs \x -> emit $ Atom x -unwrapNewtype :: EnvReader m => CAtom n -> m n (CAtom n) -unwrapNewtype (NewtypeCon _ x) = return x -unwrapNewtype x = case getType x of - NewtypeTyCon con -> do - (_, ty) <- unwrapNewtypeType con - return $ ProjectElt ty UnwrapNewtype x - _ -> error "not a newtype" -{-# INLINE unwrapNewtype #-} - projectTuple :: (IRRep r, EnvReader m) => Int -> Atom r n -> m n (Atom r n) -projectTuple i x = normalizeProj (ProjectProduct i) x +projectTuple i x = undefined +-- projectTuple i x = normalizeProj (ProjectProduct i) x projectStruct :: EnvReader m => Int -> CAtom n -> m n (CAtom n) -projectStruct i x = do - projs <- getStructProjections i (getType x) - normalizeNaryProj projs x -{-# INLINE projectStruct #-} +projectStruct i x = undefined +-- projectStruct i x = do +-- projs <- getStructProjections i (getType x) +-- normalizeNaryProj projs x +-- {-# INLINE projectStruct #-} projectStructRef :: (Builder CoreIR m, Emits n) => Int -> CAtom n -> m n (CAtom n) projectStructRef i x = do @@ -1085,27 +1099,27 @@ getStructProjections i (NewtypeTyCon (UserADTType _ tyConName _)) = do _ -> [ProjectProduct i, UnwrapNewtype] getStructProjections _ _ = error "not a struct" -mkApp :: EnvReader m => CAtom n -> [CAtom n] -> m n (CExpr n) +mkApp :: BuilderEmits CoreIR m n => CAtom n -> [CAtom n] -> m n (CExpr n) mkApp f xs = do et <- appEffTy (getType f) xs return $ App et f xs -mkTabApp :: (EnvReader m, IRRep r) => Atom r n -> [Atom r n] -> m n (Expr r n) +mkTabApp :: BuilderEmits r m n => Atom r n -> [Atom r n] -> m n (Expr r n) mkTabApp xs ixs = do ty <- typeOfTabApp (getType xs) ixs return $ TabApp ty xs ixs -mkTopApp :: EnvReader m => TopFunName n -> [SAtom n] -> m n (SExpr n) +mkTopApp :: BuilderEmits SimpIR m n => TopFunName n -> [SAtom n] -> m n (SExpr n) mkTopApp f xs = do resultTy <- typeOfTopApp f xs return $ TopApp resultTy f xs -mkApplyMethod :: EnvReader m => CAtom n -> Int -> [CAtom n] -> m n (CExpr n) +mkApplyMethod :: BuilderEmits CoreIR m n => CAtom n -> Int -> [CAtom n] -> m n (CExpr n) mkApplyMethod d i xs = do resultTy <- typeOfApplyMethod d i xs return $ ApplyMethod resultTy d i xs -mkDictAtom :: EnvReader m => DictExpr n -> m n (CAtom n) +mkDictAtom :: BuilderEmits CoreIR m n => DictExpr n -> m n (CAtom n) mkDictAtom d = do ty <- typeOfDictExpr d return $ DictCon ty d @@ -1146,41 +1160,41 @@ naryAppHinted :: (CBuilder m, Emits n) => NameHint -> CAtom n -> [CAtom n] -> m n (CAtom n) naryAppHinted hint f xs = Var <$> (mkApp f xs >>= emitHinted hint) -tabApp :: (Builder r m, Emits n) => Atom r n -> Atom r n -> m n (Atom r n) +tabApp :: BuilderEmits r m n => Atom r n -> Atom r n -> m n (Atom r n) tabApp x i = mkTabApp x [i] >>= emitExpr -naryTabApp :: (Builder r m, Emits n) => Atom r n -> [Atom r n] -> m n (Atom r n) +naryTabApp :: BuilderEmits r m n => Atom r n -> [Atom r n] -> m n (Atom r n) naryTabApp = naryTabAppHinted noHint {-# INLINE naryTabApp #-} -naryTabAppHinted :: (Builder r m, Emits n) +naryTabAppHinted :: BuilderEmits r m n => NameHint -> Atom r n -> [Atom r n] -> m n (Atom r n) naryTabAppHinted hint f xs = do expr <- mkTabApp f xs Var <$> emitHinted hint expr -indexRef :: (Builder r m, Emits n) => Atom r n -> Atom r n -> m n (Atom r n) +indexRef :: BuilderEmits r m n => Atom r n -> Atom r n -> m n (Atom r n) indexRef ref i = emitOp =<< mkIndexRef ref i -naryIndexRef :: (Builder r m, Emits n) => Atom r n -> [Atom r n] -> m n (Atom r n) +naryIndexRef :: BuilderEmits r m n => Atom r n -> [Atom r n] -> m n (Atom r n) naryIndexRef ref is = foldM indexRef ref is -ptrOffset :: (Builder r m, Emits n) => Atom r n -> Atom r n -> m n (Atom r n) +ptrOffset :: BuilderEmits r m n => Atom r n -> Atom r n -> m n (Atom r n) ptrOffset x (IdxRepVal 0) = return x ptrOffset x i = emitOp $ MemOp $ PtrOffset x i {-# INLINE ptrOffset #-} -unsafePtrLoad :: (Builder r m, Emits n) => Atom r n -> m n (Atom r n) +unsafePtrLoad :: BuilderEmits r m n => Atom r n -> m n (Atom r n) unsafePtrLoad x = do body <- liftEmitBuilder $ buildBlock $ emitOp . MemOp . PtrLoad =<< sinkM x emitHof $ RunIO body -mkIndexRef :: (EnvReader m, Fallible1 m, IRRep r) => Atom r n -> Atom r n -> m n (PrimOp r n) +mkIndexRef :: BuilderEmits r m n => Atom r n -> Atom r n -> m n (PrimOp r n) mkIndexRef ref i = do resultTy <- typeOfIndexRef (getType ref) i return $ RefOp ref $ IndexRef resultTy i -mkProjRef :: (EnvReader m, IRRep r) => Atom r n -> Projection -> m n (PrimOp r n) +mkProjRef :: BuilderEmits r m n => Atom r n -> Projection -> m n (PrimOp r n) mkProjRef ref i = do resultTy <- typeOfProjRef (getType ref) i return $ RefOp ref $ ProjRef resultTy i @@ -1336,17 +1350,15 @@ runMaybeWhile body = do type ReconAbs r e = Abs (ReconBinders r) e -data ReconBinders r n l = ReconBinders - (TelescopeType (AtomNameC r) (Type r) n) - (Nest (NameBinder (AtomNameC r)) n l) +data ReconBinders r n l = ReconBinders (TelescopeType r n) (Nest (NameBinder (AtomNameC r)) n l) -data TelescopeType c e n = - DepTelescope (TelescopeType c e n) (Abs (BinderP c e) (TelescopeType c e) n) - | ProdTelescope [e n] +data TelescopeType r n = + DepTelescope (TelescopeType r n) (Abs (BinderAndDecls r) (TelescopeType r) n) + | ProdTelescope [Type r n] instance IRRep r => GenericB (ReconBinders r) where type RepB (ReconBinders r) = - PairB (LiftB (TelescopeType (AtomNameC r) (Type r))) + PairB (LiftB (TelescopeType r)) (Nest (NameBinder (AtomNameC r))) fromB (ReconBinders x y) = PairB (LiftB x) y {-# INLINE fromB #-} @@ -1365,10 +1377,10 @@ instance IRRep r => ProvesExt (ReconBinders r) instance IRRep r => BindsNames (ReconBinders r) instance IRRep r => HoistableB (ReconBinders r) -instance GenericE (TelescopeType c e) where - type RepE (TelescopeType c e) = EitherE - (PairE (TelescopeType c e) (Abs (BinderP c e) (TelescopeType c e))) - (ListE e) +instance GenericE (TelescopeType r) where + type RepE (TelescopeType r) = EitherE + (PairE (TelescopeType r) (Abs (BinderAndDecls r) (TelescopeType r))) + (ListE (Type r)) fromE (DepTelescope lhs ab) = LeftE (PairE lhs ab) fromE (ProdTelescope tys) = RightE (ListE tys) {-# INLINE fromE #-} @@ -1376,14 +1388,14 @@ instance GenericE (TelescopeType c e) where toE (RightE (ListE tys)) = ProdTelescope tys {-# INLINE toE #-} -instance (Color c, SinkableE e) => SinkableE (TelescopeType c e) -instance (Color c, SinkableE e, RenameE e) => RenameE (TelescopeType c e) -instance (Color c, ToBinding e c, SubstE AtomSubstVal e) => SubstE AtomSubstVal (TelescopeType c e) -instance (Color c, HoistableE e) => HoistableE (TelescopeType c e) +instance IRRep r => SinkableE (TelescopeType r) +instance IRRep r => RenameE (TelescopeType r) +instance IRRep r => SubstE AtomSubstVal (TelescopeType r) +instance IRRep r => HoistableE (TelescopeType r) telescopicCapture - :: (EnvReader m, HoistableE e, HoistableB b, IRRep r) - => b n l -> e l -> m l (Atom r l, ReconAbs r e n) + :: (ScopableBuilder r m, HoistableE e, HoistableB b) + => b n l -> e l -> m l (Block r l, ReconAbs r e n) telescopicCapture bs e = do vs <- localVarsAndTypeVars bs e vTys <- forM vs \v -> getType <$> toAtomVar v @@ -1391,7 +1403,7 @@ telescopicCapture bs e = do let vsSorted = map fst vsTysSorted ty <- liftEnvReaderM $ buildTelescopeTy vsTysSorted valsSorted <- forM vsSorted \v -> Var <$> toAtomVar v - result <- buildTelescopeVal valsSorted ty + result <- buildScoped $ buildTelescopeVal (sink <$> valsSorted) (sink ty) reconAbs <- return $ ignoreHoistFailure $ hoist bs do case abstractFreeVarsNoAnn vsSorted e of Abs bs' e' -> Abs (ReconBinders ty bs') e' @@ -1405,40 +1417,36 @@ applyReconAbs (Abs bs result) x = do applySubst (bs @@> map SubstVal xs) result buildTelescopeTy - :: (EnvReader m, EnvExtender m, Color c, HoistableE e) - => [AnnVar c e n] -> m n (TelescopeType c e n) + :: (EnvReader m, EnvExtender m, IRRep r) + => [AnnVar (AtomNameC r) (Type r) n] -> m n (TelescopeType r n) buildTelescopeTy [] = return (ProdTelescope []) buildTelescopeTy ((v,ty):xs) = do rhs <- buildTelescopeTy xs Abs b rhs' <- return $ abstractFreeVar v rhs case hoist b rhs' of HoistSuccess rhs'' -> return $ prependTelescopeTy ty rhs'' - HoistFailure _ -> return $ DepTelescope (ProdTelescope []) (Abs (b:>ty) rhs') + HoistFailure _ -> return $ DepTelescope (ProdTelescope []) (Abs (PlainBD (b:>ty)) rhs') -prependTelescopeTy :: e n -> TelescopeType c e n -> TelescopeType c e n +prependTelescopeTy :: Type r n -> TelescopeType r n -> TelescopeType r n prependTelescopeTy x = \case DepTelescope lhs rhs -> DepTelescope (prependTelescopeTy x lhs) rhs ProdTelescope xs -> ProdTelescope (x:xs) -buildTelescopeVal - :: (EnvReader m, IRRep r) => [Atom r n] - -> TelescopeType (AtomNameC r) (Type r) n -> m n (Atom r n) +buildTelescopeVal :: BuilderEmits r m n => [Atom r n] -> TelescopeType r n -> m n (Atom r n) buildTelescopeVal xsTop tyTop = fst <$> go tyTop xsTop where - go :: (EnvReader m, IRRep r) - => TelescopeType (AtomNameC r) (Type r) n -> [Atom r n] - -> m n (Atom r n, [Atom r n]) + go :: BuilderEmits r m n => TelescopeType r n -> [Atom r n] -> m n (Atom r n, [Atom r n]) go ty rest = case ty of ProdTelescope tys -> do (xs, rest') <- return $ splitAt (length tys) rest return (ProdVal xs, rest') DepTelescope ty1 (Abs b ty2) -> do (x1, ~(xDep : rest')) <- go ty1 rest - ty2' <- applySubst (b@>SubstVal xDep) ty2 + ty2' <- instantiate (Abs b ty2) [xDep] (x2, rest'') <- go ty2' rest' let depPairTy = DepPairType ExplicitDepPair b (telescopeTypeType ty2) return (PairVal x1 (DepPair xDep x2 depPairTy), rest'') -telescopeTypeType :: TelescopeType (AtomNameC r) (Type r) n -> Type r n +telescopeTypeType :: TelescopeType r n -> Type r n telescopeTypeType (ProdTelescope tys) = ProdTy tys telescopeTypeType (DepTelescope lhs (Abs b rhs)) = do let lhs' = telescopeTypeType lhs @@ -1450,7 +1458,7 @@ unpackTelescope => ReconBinders r l1 l2 -> Atom r n -> m n [Atom r n] unpackTelescope (ReconBinders tyTop _) xTop = go tyTop xTop where go :: (Fallible1 m, EnvReader m, IRRep r) - => TelescopeType c e l-> Atom r n -> m n [Atom r n] + => TelescopeType r l-> Atom r n -> m n [Atom r n] go ty x = case ty of ProdTelescope _ -> getUnpacked x DepTelescope ty1 (Abs _ ty2) -> do @@ -1594,3 +1602,589 @@ applyFloatBinOp f x y = case (x, y) of _applyFloatUnOp :: (forall a. (Num a, Fractional a) => a -> a) -> Atom r n -> Atom r n _applyFloatUnOp f x = applyFloatBinOp (\_ -> f) (error "shouldn't be needed") x + + +-- === Stuff that used to be in Normalize/CheapReduce === + +-- We should figure out how to organize these things into modules but for now +-- I'm putting them in one file to avoid circular dependency issues. + +repValAtom :: EnvReader m => SRepVal n -> m n (SAtom n) +repValAtom (RepVal ty tree) = case ty of + ProdTy ts -> case tree of + Branch trees -> ProdVal <$> mapM repValAtom (zipWith RepVal ts trees) + _ -> malformed + BaseTy _ -> case tree of + Leaf x -> case x of + ILit l -> return $ Con $ Lit l + _ -> fallback + _ -> malformed + _ -> fallback + where fallback = return $ RepValAtom $ RepVal ty tree + malformed = error "malformed repval" +{-# INLINE repValAtom #-} + +liftSimpType :: EnvReader m => SType n -> m n (CType n) +liftSimpType = \case + BaseTy t -> return $ BaseTy t + ProdTy ts -> ProdTy <$> mapM rec ts + SumTy ts -> SumTy <$> mapM rec ts + t -> error $ "not implemented: " ++ pprint t + where rec = liftSimpType +{-# INLINE liftSimpType #-} + +liftSimpFun :: EnvReader m => Type CoreIR n -> LamExpr SimpIR n -> m n (CAtom n) +liftSimpFun (Pi piTy) f = return $ SimpInCore $ LiftSimpFun piTy f +liftSimpFun _ _ = error "not a pi type" + +unwrapNewtypeType :: BuilderEmits CoreIR m n => NewtypeTyCon n -> m n (NewtypeCon n, Type CoreIR n) +unwrapNewtypeType = \case + Nat -> return (NatCon, IdxRepTy) + Fin n -> return (FinCon n, NatTy) + UserADTType sn defName params -> do + def <- lookupTyCon defName + ty' <- dataDefRep <$> instantiateTyConDef def params + return (UserADTData sn defName params, ty') + ty -> error $ "Shouldn't be projecting: " ++ pprint ty +{-# INLINE unwrapNewtypeType #-} + +unwrapLeadingNewtypesType :: BuilderEmits CoreIR m n => CType n -> m n ([NewtypeCon n], CType n) +unwrapLeadingNewtypesType = \case + NewtypeTyCon tyCon -> do + (dataCon, ty) <- unwrapNewtypeType tyCon + (dataCons, ty') <- unwrapLeadingNewtypesType ty + return (dataCon:dataCons, ty') + ty -> return ([], ty) + +wrapNewtypesData :: [NewtypeCon n] -> CAtom n-> CAtom n +wrapNewtypesData [] x = x +wrapNewtypesData (c:cs) x = NewtypeCon c $ wrapNewtypesData cs x + +instantiateTyConDef :: BuilderEmits CoreIR m n => TyConDef n -> TyConParams n -> m n (DataConDefs n) +instantiateTyConDef tyConDef (TyConParams _ xs) = instantiate tyConDef xs +{-# INLINE instantiateTyConDef #-} + +assumeConst + :: (IRRep r, HoistableE body, SinkableE body, ToBindersAbs e body r) => e n -> body n +assumeConst e = case toAbs e of Abs bs body -> ignoreHoistFailure $ hoist bs body + +arity :: (IRRep r, ToBindersAbs e body r) => e n -> Int +arity e = case toAbs e of Abs bs _ -> nestLength bs + +tryAsConst + :: (IRRep r, HoistableE body, SinkableE body, ToBindersAbs e body r) => e n -> Maybe (body n) +tryAsConst e = + case toAbs e of + Abs bs body -> case hoist bs body of + HoistFailure _ -> Nothing + HoistSuccess e' -> Just e' + +instantiate + :: (Builder r m, Emits n, IRRep r, SubstE (SubstVal Atom) body, SinkableE body, SinkableE e, + ToBindersAbs e body r, Ext h n) + => e h -> [Atom r n] -> m n (body n) +instantiate e xs = undefined +-- instantiate e xs = do +-- Abs bs body <- sinkM $ toAbs e +-- let bs' = fmapNest (\(BD b) -> b) bs +-- applySubst (bs' @@> (SubstVal <$> xs)) body +-- {-# INLINE instantiate #-} + +-- "lazy" subst-extending version of `instantiate` +withInstantiated + :: (SubstReader AtomSubstVal m, IRRep r, SubstE (SubstVal Atom) body, SinkableE body, ToBindersAbs e body r) + => e i -> [Atom r o] + -> (forall i'. body i' -> m i' o a) + -> m i o a +withInstantiated e xs cont = undefined +-- withInstantiated e xs cont = do +-- Abs bs body <- return $ toAbs e +-- let bs' = fmapNest (\(BD b) -> b) bs +-- extendSubst (bs' @@> (SubstVal <$> xs)) $ cont body + +instantiateNames + :: (EnvReader m, IRRep r, RenameE body, SinkableE body, ToBindersAbs e body r, Ext h n) + => e h -> [AtomName r n] -> m n (body n) +instantiateNames e vs = undefined +-- instantiateNames e vs = do +-- Abs bs body <- sinkM $ toAbs e +-- let bs' = fmapNest (\(BD b) -> b) bs +-- applyRename (bs' @@> vs) body + +-- "lazy" subst-extending version of `instantiateNames` +withInstantiatedNames + :: (SubstReader Name m, IRRep r, RenameE body, SinkableE body, ToBindersAbs e body r) + => e i -> [AtomName r o] + -> (forall i'. body i' -> m i' o a) + -> m i o a +withInstantiatedNames e vs cont = undefined +-- withInstantiatedNames e vs cont = do +-- Abs bs body <- return $ toAbs e +-- let bs' = fmapNest (\(BD b) -> b) bs +-- extendRenamer (bs' @@> vs) $ cont body + +extendSubstBD + :: forall v m b r i i' o a + . (SubstReader v m, ToBinders b r, IRRep r) + => b i i' -> [v (AtomNameC r) o] -> m i' o a -> m i o a +extendSubstBD bsTop xsTop contTop = undefined -- go (toBinders bsTop) xsTop contTop +-- extendSubstBD bsTop xsTop contTop = go (toBinders bsTop) xsTop contTop +-- where +-- go :: Binders r ii ii' -> [v (AtomNameC r) o] -> m ii' o a -> m ii o a +-- go Empty [] cont = cont +-- go (Nest (BD b) bs) (x:xs) cont = extendSubst (b@>x) $ go bs xs cont +-- go _ _ _ = error "zip error" +-- {-# INLINE extendSubstBD #-} + +-- Returns a representation type (type of an TypeCon-typed Newtype payload) +-- given a list of instantiated DataConDefs. +dataDefRep :: DataConDefs n -> CType n +dataDefRep (ADTCons cons) = case cons of + [] -> error "unreachable" -- There's no representation for a void type + [DataConDef _ _ ty _] -> ty + tys -> SumTy $ tys <&> \(DataConDef _ _ ty _) -> ty +dataDefRep (StructFields fields) = case map snd fields of + [ty] -> ty + tys -> ProdTy tys + +makeStructRepVal :: (Fallible1 m, EnvReader m) => TyConName n -> [CAtom n] -> m n (CAtom n) +makeStructRepVal tyConName args = do + TyConDef _ _ _ (StructFields fields) <- lookupTyCon tyConName + case fields of + [_] -> case args of + [arg] -> return arg + _ -> error "wrong number of args" + _ -> return $ ProdVal args + +-- === Exposed helpers for querying types and effects === + +caseAltsBinderTys :: BuilderEmits r m n => Type r n -> m n [Type r n] +caseAltsBinderTys ty = case ty of + SumTy types -> return types + NewtypeTyCon t -> case t of + UserADTType _ defName params -> do + def <- lookupTyCon defName + ~(ADTCons cons) <- instantiateTyConDef def params + return [repTy | DataConDef _ _ repTy _ <- cons] + _ -> error msg + _ -> error msg + where msg = "Case analysis only supported on ADTs, not on " ++ pprint ty + +extendEffect :: IRRep r => Effect r n -> EffectRow r n -> EffectRow r n +extendEffect eff (EffectRow effs t) = EffectRow (effs <> eSetSingleton eff) t + +blockEffTy :: (EnvReader m, IRRep r) => Block r n -> m n (EffTy r n) +blockEffTy block = liftEnvReaderM $ refreshAbs block \decls result -> do + effs <- declsEffects decls mempty + return $ ignoreHoistFailure $ hoist decls $ EffTy effs $ getType result + where + declsEffects :: IRRep r => Nest (Decl r) n l -> EffectRow r l -> EnvReaderM l (EffectRow r l) + declsEffects Empty !acc = return acc + declsEffects n@(Nest (Let _ (DeclBinding _ expr)) rest) !acc = withExtEvidence n do + expr' <- sinkM expr + declsEffects rest $ acc <> getEffects expr' + +blockTy :: (EnvReader m, IRRep r) => Block r n -> m n (Type r n) +blockTy b = blockEffTy b <&> \(EffTy _ t) -> t + +piTypeWithoutDest :: PiType SimpIR n -> PiType SimpIR n +piTypeWithoutDest (PiType bsRefB _) = + case popNest bsRefB of + Just (PairB bs refB) -> do + case binderType refB of + RawRefTy ansTy -> PiType bs $ EffTy Pure ansTy -- XXX: we ignore the effects here + _ -> error "expected ref type" + _ -> error "expected trailing binder" + +blockEff :: (EnvReader m, IRRep r) => Block r n -> m n (EffectRow r n) +blockEff b = blockEffTy b <&> \(EffTy eff _) -> eff + +typeOfApp :: (IRRep r, EnvReader m) => Type r n -> [Atom r n] -> m n (Type r n) +typeOfApp (Pi piTy) xs = withSubstReaderT $ + withInstantiated piTy xs \(EffTy _ ty) -> substM ty +typeOfApp _ _ = error "expected a pi type" + +typeOfTabApp :: BuilderEmits r m n => Type r n -> [Atom r n] -> m n (Type r n) +typeOfTabApp t [] = return t +typeOfTabApp (TabPi tabTy) (i:rest) = do + resultTy <- instantiate tabTy [i] + typeOfTabApp resultTy rest +typeOfTabApp ty _ = error $ "expected a table type. Got: " ++ pprint ty + +typeOfApplyMethod :: BuilderEmits CoreIR m n => CAtom n -> Int -> [CAtom n] -> m n (EffTy CoreIR n) +typeOfApplyMethod d i args = do + ty <- Pi <$> getMethodType d i + appEffTy ty args + +typeOfDictExpr :: BuilderEmits CoreIR m n => DictExpr n -> m n (CType n) +typeOfDictExpr e = liftEmitBuilder case e of + InstanceDict instanceName args -> do + instanceDef@(InstanceDef className _ _ _ _) <- lookupInstanceDef instanceName + sourceName <- getSourceName <$> lookupClassDef className + PairE (ListE params) _ <- instantiate instanceDef args + return $ DictTy $ DictType sourceName className params + InstantiatedGiven given args -> typeOfApp (getType given) args + SuperclassProj d i -> do + DictTy (DictType _ className params) <- return $ getType d + classDef <- lookupClassDef className + withSubstReaderT $ withInstantiated classDef params \(Abs superclasses _) -> do + substM $ getSuperclassType REmpty superclasses i + IxFin n -> liftM DictTy $ ixDictType $ NewtypeTyCon $ Fin n + DataData ty -> DictTy <$> dataDictType ty + +typeOfTopApp :: BuilderEmits SimpIR m n => TopFunName n -> [SAtom n] -> m n (EffTy SimpIR n) +typeOfTopApp f xs = do + piTy <- getTypeTopFun f + instantiate piTy xs + +typeOfIndexRef :: BuilderEmits r m n => Type r n -> Atom r n -> m n (Type r n) +typeOfIndexRef (TC (RefType h s)) i = do + TabPi tabPi <- return s + eltTy <- instantiate tabPi [i] + return $ TC $ RefType h eltTy +typeOfIndexRef _ _ = error "expected a ref type" + +typeOfProjRef :: BuilderEmits r m n => Type r n -> Projection -> m n (Type r n) +typeOfProjRef (TC (RefType h s)) p = do + TC . RefType h <$> case p of + ProjectProduct i -> do + ~(ProdTy tys) <- return s + return $ tys !! i + UnwrapNewtype -> do + case s of + NewtypeTyCon tc -> snd <$> unwrapNewtypeType tc + _ -> error "expected a newtype" +typeOfProjRef _ _ = error "expected a reference" + +appEffTy :: BuilderEmits r m n => Type r n -> [Atom r n] -> m n (EffTy r n) +appEffTy (Pi piTy) xs = instantiate piTy xs +appEffTy t _ = error $ "expected a pi type, got: " ++ pprint t + +partialAppType :: BuilderEmits r m n => Type r n -> [Atom r n] -> m n (Type r n) +partialAppType (Pi (CorePiType appExpl expls bs effTy)) xs = do + (_, expls2) <- return $ splitAt (length xs) expls + PairB bs1 bs2 <- return $ splitNestAt (length xs) bs + instantiate (Abs bs1 (Pi $ CorePiType appExpl expls2 bs2 effTy)) xs +partialAppType _ _ = error "expected a pi type" + +effTyOfHof :: BuilderEmits r m n => Hof r n -> m n (EffTy r n) +effTyOfHof hof = EffTy <$> hofEffects hof <*> typeOfHof hof + +typeOfHof :: BuilderEmits r m n => Hof r n -> m n (Type r n) +typeOfHof = \case + For _ ixTy f -> getLamExprType f >>= \case + PiType (UnaryNest b) (EffTy _ eltTy) -> return $ TabTy (ixTypeDict ixTy) b eltTy + _ -> error "expected a unary pi type" + While _ -> return UnitTy + Linearize f _ -> getLamExprType f >>= \case + PiType (UnaryNest binder) (EffTy Pure b) -> do + let b' = ignoreHoistFailure $ hoist binder b + let fLinTy = Pi $ nonDepPiType [binderType binder] Pure b' + return $ PairTy b' fLinTy + _ -> error "expected a unary pi type" + Transpose f _ -> getLamExprType f >>= \case + PiType (UnaryNest b) _ -> return $ binderType b + _ -> error "expected a unary pi type" + RunReader _ f -> do + (resultTy, _) <- getTypeRWSAction f + return resultTy + RunWriter _ _ f -> uncurry PairTy <$> getTypeRWSAction f + RunState _ _ f -> do + (resultTy, stateTy) <- getTypeRWSAction f + return $ PairTy resultTy stateTy + RunIO f -> blockTy f + RunInit f -> blockTy f + CatchException ty _ -> return ty + +hofEffects :: (EnvReader m, IRRep r) => Hof r n -> m n (EffectRow r n) +hofEffects = \case + For _ _ f -> functionEffs f + While body -> blockEff body + Linearize _ _ -> return Pure -- Body has to be a pure function + Transpose _ _ -> return Pure -- Body has to be a pure function + RunReader _ f -> rwsFunEffects Reader f + RunWriter d _ f -> maybeInit d <$> rwsFunEffects Writer f + RunState d _ f -> maybeInit d <$> rwsFunEffects State f + RunIO f -> deleteEff IOEffect <$> blockEff f + RunInit f -> deleteEff InitEffect <$> blockEff f + CatchException _ f -> deleteEff ExceptionEffect <$> blockEff f + where maybeInit :: IRRep r => Maybe (Atom r i) -> (EffectRow r o -> EffectRow r o) + maybeInit d = case d of Just _ -> (<>OneEffect InitEffect); Nothing -> id + +deleteEff :: IRRep r => Effect r n -> EffectRow r n -> EffectRow r n +deleteEff eff (EffectRow effs t) = EffectRow (effs `eSetDifference` eSetSingleton eff) t + +getMethodIndex :: EnvReader m => ClassName n -> SourceName -> m n Int +getMethodIndex className methodSourceName = do + ClassDef _ methodNames _ _ _ _ _ <- lookupClassDef className + case elemIndex methodSourceName methodNames of + Nothing -> error $ methodSourceName ++ " is not a method of " ++ pprint className + Just i -> return i +{-# INLINE getMethodIndex #-} + +getUVarType :: BuilderEmits CoreIR m n => UVar n -> m n (CType n) +getUVarType = \case + UAtomVar v -> getType <$> toAtomVar v + UTyConVar v -> getTyConNameType v + UDataConVar v -> getDataConNameType v + UPunVar v -> getStructDataConType v + UClassVar v -> do + ClassDef _ _ _ roleExpls bs _ _ <- lookupClassDef v + return $ Pi $ CorePiType ExplicitApp (map snd roleExpls) bs $ EffTy Pure TyKind + UMethodVar v -> getMethodNameType v + UEffectVar _ -> error "not implemented" + UEffectOpVar _ -> error "not implemented" + +getMethodNameType :: BuilderEmits CoreIR m n => MethodName n -> m n (CType n) +getMethodNameType v = liftEmitBuilder $ lookupEnv v >>= \case + MethodBinding className i -> do + ClassDef _ _ paramNames _ paramBs scBinders methodTys <- lookupClassDef className + refreshAbs (Abs paramBs $ Abs scBinders (methodTys !! i)) \paramBs' absPiTy -> do + let params = Var <$> bindersVars paramBs' + dictTy <- DictTy <$> dictType (sink className) params + withFreshBinderAndDecls noHint dictTy \dict -> do + piTy <- instantiate absPiTy =<< getSuperclassDicts (Var dict) + CorePiType appExpl methodExpls methodBs effTy <- return piTy + let paramExpls = paramNames <&> \name -> Inferred name Unify + let expls = paramExpls <> [Inferred Nothing (Synth $ Partial $ succ i)] <> methodExpls + return \dictB -> + Pi $ CorePiType appExpl expls (paramBs' >>> UnaryNest dictB >>> methodBs) effTy + +withFreshBinderAndDecls + :: (IRRep r, EnvExtender m, ScopableBuilder r m) + => NameHint -> Type r n + -> (forall l. (DExt n l, Emits l) => AtomVar r l -> m l (BinderAndDecls r n l -> a)) + -> m n a +withFreshBinderAndDecls _ _ _ = undefined + +-- dictTy <- DictTy <$> dictType (sink className) params + -- withFreshBinder noHint dictTy \dictB -> do + -- scDicts <- getSuperclassDicts (Var $ binderVar dictB) + -- CorePiType appExpl methodExpls methodBs effTy <- instantiate absPiTy scDicts + -- let paramExpls = paramNames <&> \name -> Inferred name Unify + -- let expls = paramExpls <> [Inferred Nothing (Synth $ Partial $ succ i)] <> methodExpls + -- return $ Pi $ CorePiType appExpl expls (paramBs' >>> UnaryNest (PlainBD dictB) >>> methodBs) effTy + + +getMethodType :: BuilderEmits CoreIR m n => Dict n -> Int -> m n (CorePiType n) +getMethodType dict i = liftEmitBuilder $ withSubstReaderT do + ~(DictTy (DictType _ className params)) <- return $ getType dict + superclassDicts <- getSuperclassDicts dict + classDef <- lookupClassDef className + withInstantiated classDef params \ab -> do + withInstantiated ab superclassDicts \(ListE methodTys) -> + substM $ methodTys !! i + +getTyConNameType :: EnvReader m => TyConName n -> m n (Type CoreIR n) +getTyConNameType v = do + TyConDef _ expls bs _ <- lookupTyCon v + case bs of + Empty -> return TyKind + _ -> return $ Pi $ CorePiType ExplicitApp (snd <$> expls) bs $ EffTy Pure TyKind + +getDataConNameType :: EnvReader m => DataConName n -> m n (Type CoreIR n) +getDataConNameType dataCon = liftEnvReaderM $ withSubstReaderT do + (tyCon, i) <- lookupDataCon dataCon + tyConDef <- lookupTyCon tyCon + buildDataConType tyConDef \expls paramBs' paramVs params -> do + withInstantiatedNames tyConDef paramVs \(ADTCons dataCons) -> do + DataConDef _ ab _ _ <- renameM (dataCons !! i) + refreshAbs ab \dataBs UnitE -> do + let appExpl = case dataBs of Empty -> ImplicitApp + _ -> ExplicitApp + let resultTy = NewtypeTyCon $ UserADTType (getSourceName tyConDef) (sink tyCon) (sink params) + let dataExpls = nestToList (const $ Explicit) dataBs + return $ Pi $ CorePiType appExpl (expls <> dataExpls) (paramBs' >>> dataBs) (EffTy Pure resultTy) + +getStructDataConType :: EnvReader m => TyConName n -> m n (CType n) +getStructDataConType tyCon = liftEnvReaderM $ withSubstReaderT do + tyConDef <- lookupTyCon tyCon + buildDataConType tyConDef \expls paramBs' paramVs params -> do + withInstantiatedNames tyConDef paramVs \(StructFields fields) -> do + fieldTys <- forM fields \(_, t) -> renameM t + let resultTy = NewtypeTyCon $ UserADTType (getSourceName tyConDef) (sink tyCon) params + Abs dataBs resultTy' <- return $ typesAsBinderNest fieldTys resultTy + let dataExpls = nestToList (const Explicit) dataBs + return $ Pi $ CorePiType ExplicitApp (expls <> dataExpls) (paramBs' >>> dataBs) (EffTy Pure resultTy') + +buildDataConType + :: (EnvReader m, EnvExtender m) + => TyConDef n + -> (forall l. DExt n l => [Explicitness] -> CBinders n l -> [CAtomName l] -> TyConParams l -> m l a) + -> m n a +buildDataConType (TyConDef _ roleExpls bs _) cont = do + let expls = snd <$> roleExpls + expls' <- forM expls \case + Explicit -> return $ Inferred Nothing Unify + expl -> return $ expl + refreshAbs (Abs bs UnitE) \bs' UnitE -> do + let vs = bindersVars bs' + cont expls' bs' (atomVarName <$> vs) $ TyConParams expls (Var <$> vs) + +makeTyConParams :: EnvReader m => TyConName n -> [CAtom n] -> m n (TyConParams n) +makeTyConParams tc params = do + TyConDef _ expls _ _ <- lookupTyCon tc + return $ TyConParams (map snd expls) params + +getDataClassName :: (Fallible1 m, EnvReader m) => m n (ClassName n) +getDataClassName = lookupSourceMap "Data" >>= \case + Nothing -> throw CompilerErr $ "Data interface needed but not defined!" + Just (UClassVar v) -> return v + Just _ -> error "not a class var" + +dataDictType :: (Fallible1 m, EnvReader m) => CType n -> m n (DictType n) +dataDictType ty = do + dataClassName <- getDataClassName + dictType dataClassName [Type ty] + +getIxClassName :: (Fallible1 m, EnvReader m) => m n (ClassName n) +getIxClassName = lookupSourceMap "Ix" >>= \case + Nothing -> throw CompilerErr $ "Ix interface needed but not defined!" + Just (UClassVar v) -> return v + Just _ -> error "not a class var" + +dictType :: EnvReader m => ClassName n -> [CAtom n] -> m n (DictType n) +dictType className params = do + ClassDef sourceName _ _ _ _ _ _ <- lookupClassDef className + return $ DictType sourceName className params + +ixDictType :: (Fallible1 m, EnvReader m) => CType n -> m n (DictType n) +ixDictType ty = do + ixClassName <- getIxClassName + dictType ixClassName [Type ty] + +makePreludeMaybeTy :: EnvReader m => CType n -> m n (CType n) +makePreludeMaybeTy ty = do + ~(Just (UTyConVar tyConName)) <- lookupSourceMap "Maybe" + return $ TypeCon "Maybe" tyConName $ TyConParams [Explicit] [Type ty] + +-- === computing effects === + +functionEffs :: (IRRep r, EnvReader m) => LamExpr r n -> m n (EffectRow r n) +functionEffs f = getLamExprType f >>= \case + PiType b (EffTy effs _) -> return $ ignoreHoistFailure $ hoist b effs + +rwsFunEffects :: (IRRep r, EnvReader m) => RWS -> LamExpr r n -> m n (EffectRow r n) +rwsFunEffects rws f = liftEnvReaderM $ getLamExprType f >>= \case + PiType (BinaryNest h ref) et -> do + let effs' = ignoreHoistFailure $ hoist ref (etEff et) + refreshAbs (Abs h effs') \h' effs'' -> do + let hVal = Var $ binderVar h' + let effs''' = deleteEff (RWSEffect rws hVal) effs'' + return $ ignoreHoistFailure $ hoist h' effs''' + _ -> error "Expected a binary function type" + +getLamExprType :: (IRRep r, EnvReader m) => LamExpr r n -> m n (PiType r n) +getLamExprType (LamExpr bs body) = liftEnvReaderM $ + refreshAbs (Abs bs body) \bs' body' -> do + effTy <- blockEffTy body' + return $ PiType bs' effTy + +getTypeRWSAction :: (IRRep r, EnvReader m) => LamExpr r n -> m n (Type r n, Type r n) +getTypeRWSAction f = getLamExprType f >>= \case + PiType (BinaryNest regionBinder refBinder) (EffTy _ resultTy) -> do + case binderType refBinder of + RefTy _ referentTy -> do + let referentTy' = ignoreHoistFailure $ hoist regionBinder referentTy + let resultTy' = ignoreHoistFailure $ hoist (PairB regionBinder refBinder) resultTy + return (resultTy', referentTy') + _ -> error "expected a ref" + _ -> error "expected a pi type" + +getSuperclassDicts :: BuilderEmits CoreIR m n => CAtom n -> m n ([CAtom n]) +getSuperclassDicts dict = do + case getType dict of + DictTy dTy -> do + ts <- getSuperclassTys dTy + forM (enumerate ts) \(i, t) -> return $ DictCon t $ SuperclassProj dict i + _ -> error "expected a dict type" + +getSuperclassTys :: BuilderEmits CoreIR m n => DictType n -> m n [CType n] +getSuperclassTys (DictType _ className params) = do + ClassDef _ _ _ _ bs superclasses _ <- lookupClassDef className + forM [0 .. nestLength superclasses - 1] \i -> do + instantiate (Abs bs $ getSuperclassType REmpty superclasses i) params + +getSuperclassType :: RNest (BinderAndDecls CoreIR) n l -> CBinders l l' -> Int -> CType n +getSuperclassType _ Empty = error "bad index" +getSuperclassType bsAbove (Nest b bs) = \case + 0 -> ignoreHoistFailure $ hoist bsAbove (binderType b) + i -> getSuperclassType (RNest bsAbove b) bs (i-1) + + +getTypeTopFun :: EnvReader m => TopFunName n -> m n (PiType SimpIR n) +getTypeTopFun f = lookupTopFun f >>= \case + DexTopFun _ (TopLam _ piTy _) _ -> return piTy + FFITopFun _ iTy -> liftIFunType iTy + +asTopLam :: (EnvReader m, IRRep r) => LamExpr r n -> m n (TopLam r n) +asTopLam lam = do + piTy <- getLamExprType lam + return $ TopLam False piTy lam + +liftIFunType :: (IRRep r, EnvReader m) => IFunType -> m n (PiType r n) +liftIFunType (IFunType _ argTys resultTys) = liftEnvReaderM $ go argTys where + go :: IRRep r => [BaseType] -> EnvReaderM n (PiType r n) + go = \case + [] -> return $ PiType Empty (EffTy (OneEffect IOEffect) resultTy) + where resultTy = case resultTys of + [] -> UnitTy + [t] -> BaseTy t + [t1, t2] -> PairTy (BaseTy t1) (BaseTy t2) + _ -> error $ "Not a valid FFI return type: " ++ pprint resultTys + t:ts -> withFreshBinder noHint (BaseTy t) \b -> do + PiType bs effTy <- go ts + return $ PiType (Nest (PlainBD b) bs) effTy + +unwrapNewtype :: EnvReader m => CAtom n -> m n (CAtom n) +unwrapNewtype (NewtypeCon _ x) = return x +-- unwrapNewtype x = case getType x of +-- NewtypeTyCon con -> do +-- (_, ty) <- unwrapNewtypeType con +-- return $ ProjectElt ty UnwrapNewtype x +-- _ -> error "not a newtype" +-- {-# INLINE unwrapNewtype #-} + +-- === Data constraints === + +isData :: EnvReader m => Type CoreIR n -> m n Bool +isData ty = do + result <- liftEnvReaderT $ withSubstReaderT $ checkDataLike ty + case runFallibleM result of + Success () -> return True + Failure _ -> return False + +checkDataLike :: Type CoreIR i -> SubstReaderT Name FallibleEnvReaderM i o () +checkDataLike ty = undefined +-- checkDataLike ty = case ty of +-- TyVar _ -> notData +-- TabPi (TabPiType _ b eltTy) -> do +-- renameBinders b \_ -> +-- checkDataLike eltTy +-- DepPairTy (DepPairType _ b r) -> do +-- recur $ binderType b +-- renameBinders b \_ -> checkDataLike r +-- NewtypeTyCon nt -> do +-- (_, ty') <- unwrapNewtypeType =<< renameM nt +-- dropSubst $ recur ty' +-- TC con -> case con of +-- BaseType _ -> return () +-- ProdType as -> mapM_ recur as +-- SumType cs -> mapM_ recur cs +-- RefType _ _ -> return () +-- HeapType -> return () +-- _ -> notData +-- _ -> notData +-- where +-- recur = checkDataLike +-- notData = throw TypeErr $ pprint ty + +checkExtends :: (Fallible m, IRRep r) => EffectRow r n -> EffectRow r n -> m () +checkExtends allowed (EffectRow effs effTail) = do + let (EffectRow allowedEffs allowedEffTail) = allowed + case effTail of + EffectRowTail _ -> assertEq allowedEffTail effTail "" + NoTail -> return () + forM_ (eSetToList effs) \eff -> unless (eff `eSetMember` allowedEffs) $ + throw CompilerErr $ "Unexpected effect: " ++ pprint eff ++ + "\nAllowed: " ++ pprint allowed diff --git a/src/lib/CheapReduction.hs b/src/lib/CheapReduction.hs deleted file mode 100644 index c4cc41bb1..000000000 --- a/src/lib/CheapReduction.hs +++ /dev/null @@ -1,926 +0,0 @@ --- Copyright 2021 Google LLC --- --- Use of this source code is governed by a BSD-style --- license that can be found in the LICENSE file or at --- https://developers.google.com/open-source/licenses/bsd - -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module CheapReduction - ( CheaplyReducibleE (..), cheapReduce, cheapReduceWithDecls, cheapNormalize - , normalizeProj, asNaryProj, normalizeNaryProj - , depPairLeftTy, instantiateTyConDef - , dataDefRep, unwrapNewtypeType, repValAtom - , unwrapLeadingNewtypesType, wrapNewtypesData, liftSimpAtom, liftSimpType - , liftSimpFun, makeStructRepVal, NonAtomRenamer (..), Visitor (..), VisitGeneric (..) - , visitAtomPartial, visitTypePartial, visitAtomDefault, visitTypeDefault, Visitor2 - , visitBinders, visitPiDefault, visitAlt, toAtomVar, instantiate, withInstantiated - , bindersToVars, bindersToAtoms, instantiateNames, withInstantiatedNames, assumeConst) - where - -import Control.Applicative -import Control.Monad.Trans -import Control.Monad.Writer.Strict hiding (Alt) -import Control.Monad.State.Strict -import Control.Monad.Reader -import Data.Foldable (toList) -import Data.Functor.Identity -import Data.Functor ((<&>)) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M - -import Subst -import Core -import Err -import IRVariants -import MTL1 -import Name -import PPrint () -import QueryTypePure -import Types.Core -import Types.Imp -import Types.Primitives -import Util -import {-# SOURCE #-} Inference (trySynthTerm) - --- Carry out the reductions we are willing to carry out during type --- inference. The goal is to support type aliases like `Int = Int32` --- and type-level functions like `def Fin (n:Int) : Type = Range 0 n`. --- The reductions in question are mostly inlining and beta-reducing --- functions. There's also a bunch of stuff to do with synthesizing --- class dictionaries, because types often contain polymorphic --- literals (e.g., `Fin 10`). - --- === api === - -type NiceE r e = (HoistableE e, SinkableE e, SubstE AtomSubstVal e, RenameE e, IRRep r) - -cheapReduce :: forall r e' e m n - . (EnvReader m, CheaplyReducibleE r e e', NiceE r e, NiceE r e') - => e n -> m n (Maybe (e' n)) -cheapReduce e = liftCheapReducerM idSubst $ cheapReduceE e -{-# INLINE cheapReduce #-} -{-# SCC cheapReduce #-} - -cheapReduceWithDecls - :: forall r e' e m n l - . ( CheaplyReducibleE r e e', NiceE r e', NiceE r e, EnvReader m ) - => Nest (Decl r) n l -> e l -> m n (Maybe (e' n)) -cheapReduceWithDecls decls result = do - Abs decls' result' <- sinkM $ Abs decls result - liftCheapReducerM idSubst $ - cheapReduceWithDeclsB decls' $ - cheapReduceE result' -{-# INLINE cheapReduceWithDecls #-} -{-# SCC cheapReduceWithDecls #-} - -cheapNormalize :: (EnvReader m, CheaplyReducibleE r e e, NiceE r e) => e n -> m n (e n) -cheapNormalize a = cheapReduce a >>= \case - Just ans -> return ans - _ -> error "couldn't normalize expression" -{-# INLINE cheapNormalize #-} - --- === internal === - -newtype CheapReducerM (r::IR) (i :: S) (o :: S) (a :: *) = - CheapReducerM - (SubstReaderT AtomSubstVal - (MaybeT1 - (ScopedT1 (MapE (AtomName r) (MaybeE (Atom r))) - (EnvReaderT Identity))) i o a) - deriving (Functor, Applicative, Monad, Alternative) - -deriving instance IRRep r => ScopeReader (CheapReducerM r i) -deriving instance IRRep r => EnvReader (CheapReducerM r i) -deriving instance IRRep r => EnvExtender (CheapReducerM r i) -deriving instance IRRep r => SubstReader AtomSubstVal (CheapReducerM r) - -class ( Alternative2 m, SubstReader AtomSubstVal m - , EnvReader2 m, EnvExtender2 m) => CheapReducer m r | m -> r where - updateCache :: AtomName r o -> Maybe (Atom r o) -> m i o () - lookupCache :: AtomName r o -> m i o (Maybe (Maybe (Atom r o))) - -instance IRRep r => CheapReducer (CheapReducerM r) r where - updateCache v u = CheapReducerM $ SubstReaderT $ lift $ lift11 $ - modify (MapE . M.insert v (toMaybeE u) . fromMapE) - lookupCache v = CheapReducerM $ SubstReaderT $ lift $ lift11 $ - fmap fromMaybeE <$> gets (M.lookup v . fromMapE) - -liftCheapReducerM - :: (EnvReader m, IRRep r) - => Subst AtomSubstVal i o -> CheapReducerM r i o a - -> m o (Maybe a) -liftCheapReducerM subst (CheapReducerM m) = do - liftM runIdentity $ liftEnvReaderT $ runScopedT1 - (runMaybeT1 $ runSubstReaderT subst m) mempty -{-# INLINE liftCheapReducerM #-} - -cheapReduceWithDeclsB - :: NiceE r e - => Nest (Decl r) i i' - -> (forall o'. Ext o o' => CheapReducerM r i' o' (e o')) - -> CheapReducerM r i o (e o) -cheapReduceWithDeclsB decls cont = do - Abs irreducibleDecls result <- cheapReduceWithDeclsRec decls cont - case hoist irreducibleDecls result of - HoistSuccess result' -> return result' - HoistFailure _ -> empty - -cheapReduceWithDeclsRec - :: NiceE r e - => Nest (Decl r) i i' - -> (forall o'. Ext o o' => CheapReducerM r i' o' (e o')) - -> CheapReducerM r i o (Abs (Nest (Decl r)) e o) -cheapReduceWithDeclsRec decls cont = case decls of - Empty -> Abs Empty <$> cont - Nest (Let b binding@(DeclBinding _ expr)) rest -> do - optional (cheapReduceE expr) >>= \case - Nothing -> do - binding' <- substM binding - withFreshBinder (getNameHint b) binding' \(b':>_) -> do - updateCache (binderName b') Nothing - extendSubst (b@>Rename (binderName b')) do - Abs decls' result <- cheapReduceWithDeclsRec rest cont - return $ Abs (Nest (Let b' binding') decls') result - Just x -> - extendSubst (b@>SubstVal x) $ - cheapReduceWithDeclsRec rest cont - -cheapReduceName :: forall c r i o . (IRRep r, Color c) => Name c o -> CheapReducerM r i o (AtomSubstVal c o) -cheapReduceName v = - case eqColorRep @c @(AtomNameC r) of - Just ColorsEqual -> - lookupEnv v >>= \case - AtomNameBinding binding -> cheapReduceAtomBinding v binding - Nothing -> stuck - where stuck = return $ Rename v - -cheapReduceAtomBinding - :: forall r i o. IRRep r - => AtomName r o -> AtomBinding r o -> CheapReducerM r i o (AtomSubstVal (AtomNameC r) o) -cheapReduceAtomBinding v = \case - LetBound (DeclBinding _ e) -> do - cachedVal <- lookupCache v >>= \case - Nothing -> do - result <- optional (dropSubst $ cheapReduceE e) - updateCache v result - return result - Just result -> return result - case cachedVal of - Nothing -> stuck - Just ans -> return $ SubstVal ans - _ -> stuck - where stuck = return $ Rename v - -class CheaplyReducibleE (r::IR) (e::E) (e'::E) | e -> e', e -> r where - cheapReduceE :: e i -> CheapReducerM r i o (e' o) - -instance IRRep r => CheaplyReducibleE r (Atom r) (Atom r) where - cheapReduceE :: forall i o. Atom r i -> CheapReducerM r i o (Atom r o) - cheapReduceE a = confuseGHC >>= \_ -> case a of - -- Don't try to eagerly reduce lambda bodies. We might get stuck long before - -- we have a chance to apply tham. Also, recursive traversal of those bodies - -- means that we will follow the full call chain, so it's really expensive! - -- TODO: we don't collect the dict holes here, so there's a danger of - -- dropping them if they turn out to be phantom. - Lam _ -> substM a - DictHole ctx ty' access -> do - ty <- cheapReduceE ty' - runFallibleT1 (trySynthTerm ty access) >>= \case - Success d -> return d - Failure _ -> return $ DictHole ctx ty access - -- We traverse the Atom constructors that might contain lambda expressions - -- explicitly, to make sure that we can skip normalizing free vars inside those. - Con con -> Con <$> traverseOp con cheapReduceE cheapReduceE (error "unexpected lambda") - DictCon t d -> do - t' <- cheapReduceE t - cheapReduceDictExpr t' d - SimpInCore (LiftSimp t x) -> do - t' <- cheapReduceE t - x' <- substM x - liftSimpAtom t' x' - -- These two are a special-case hack. TODO(dougalm): write a traversal over - -- the NewtypeTyCon (or types generally) - NewtypeCon NatCon n -> NewtypeCon NatCon <$> cheapReduceE n - -- Do recursive reduction via substitution - -- TODO: we don't collect the dict holes here, so there's a danger of - -- dropping them if they turn out to be phantom. - _ -> do - a' <- substM a - dropSubst $ traverseNames cheapReduceName a' - -instance IRRep r => CheaplyReducibleE r (Type r) (Type r) where - cheapReduceE :: forall i o. Type r i -> CheapReducerM r i o (Type r o) - cheapReduceE a = case a of - -- Don't try to eagerly reduce lambda bodies. We might get stuck long before - -- we have a chance to apply tham. Also, recursive traversal of those bodies - -- means that we will follow the full call chain, so it's really expensive! - -- TODO: we don't collect the dict holes here, so there's a danger of - -- dropping them if they turn out to be phantom. - TabPi (TabPiType d (b:>t) resultTy) -> do - t' <- cheapReduceE t - d' <- cheapReduceE d - withFreshBinder (getNameHint b) t' \b' -> do - resultTy' <- extendSubst (b@>Rename (binderName b')) $ cheapReduceE resultTy - return $ TabPi $ TabPiType d' b' resultTy' - -- We traverse the Atom constructors that might contain lambda expressions - -- explicitly, to make sure that we can skip normalizing free vars inside those. - NewtypeTyCon (Fin n) -> NewtypeTyCon . Fin <$> cheapReduceE n - -- Do recursive reduction via substitution - -- TODO: we don't collect the dict holes here, so there's a danger of - -- dropping them if they turn out to be phantom. - _ -> do - a' <- substM a - dropSubst $ traverseNames cheapReduceName a' - -cheapReduceDictExpr :: CType o -> DictExpr i -> CheapReducerM CoreIR i o (CAtom o) -cheapReduceDictExpr resultTy d = case d of - SuperclassProj child superclassIx -> do - cheapReduceE child >>= \case - DictCon _ (InstanceDict instanceName args) -> dropSubst do - args' <- mapM cheapReduceE args - InstanceDef _ _ bs _ body <- lookupInstanceDef instanceName - let InstanceBody superclasses _ = body - instantiate (Abs bs (superclasses !! superclassIx)) args' - child' -> return $ DictCon resultTy $ SuperclassProj child' superclassIx - InstantiatedGiven f xs -> - reduceApp <|> justSubst - where reduceApp = do - f' <- cheapReduceE f - xs' <- mapM cheapReduceE (toList xs) - cheapReduceApp f' xs' - InstanceDict _ _ -> justSubst - IxFin _ -> justSubst - DataData ty -> DictCon resultTy . DataData <$> cheapReduceE ty - where justSubst = DictCon resultTy <$> substM d - -instance CheaplyReducibleE CoreIR TyConParams TyConParams where - cheapReduceE (TyConParams infs ps) = - TyConParams infs <$> mapM cheapReduceE ps - -instance (CheaplyReducibleE r e e', NiceE r e') => CheaplyReducibleE r (Abs (Nest (Decl r)) e) e' where - cheapReduceE (Abs decls result) = cheapReduceWithDeclsB decls $ cheapReduceE result - -instance IRRep r => CheaplyReducibleE r (Expr r) (Atom r) where - cheapReduceE expr = confuseGHC >>= \_ -> case expr of - Atom atom -> cheapReduceE atom - App _ f' xs' -> do - xs <- mapM cheapReduceE xs' - f <- cheapReduceE f' - cheapReduceApp f xs - -- TODO: Make sure that this wraps correctly - -- TODO: Other casts? - PrimOp (MiscOp (CastOp ty' val')) -> do - ty <- cheapReduceE ty' - case ty of - BaseTy (Scalar Word32Type) -> do - val <- cheapReduceE val' - case val of - Con (Lit (Word64Lit v)) -> return $ Con $ Lit $ Word32Lit $ fromIntegral v - _ -> empty - _ -> empty - ApplyMethod _ dict i explicitArgs -> do - explicitArgs' <- mapM cheapReduceE explicitArgs - cheapReduceE dict >>= \case - DictCon _ (InstanceDict instanceName args) -> dropSubst do - args' <- mapM cheapReduceE args - def <- lookupInstanceDef instanceName - withInstantiated def args' \(PairE _ (InstanceBody _ methods)) -> do - method' <- cheapReduceE $ methods !! i - cheapReduceApp method' explicitArgs' - _ -> empty - _ -> empty - -cheapReduceApp :: CAtom o -> [CAtom o] -> CheapReducerM CoreIR i o (CAtom o) -cheapReduceApp f xs = case f of - Lam lam -> dropSubst $ withInstantiated lam xs \body -> cheapReduceE body - _ -> empty - -instance IRRep r => CheaplyReducibleE r (IxType r) (IxType r) where - cheapReduceE (IxType t d) = IxType <$> cheapReduceE t <*> cheapReduceE d - -instance IRRep r => CheaplyReducibleE r (IxDict r) (IxDict r) where - cheapReduceE = \case - IxDictAtom x -> IxDictAtom <$> cheapReduceE x - IxDictRawFin n -> IxDictRawFin <$> cheapReduceE n - IxDictSpecialized t d xs -> - IxDictSpecialized <$> cheapReduceE t <*> substM d <*> mapM cheapReduceE xs - -instance (CheaplyReducibleE r e1 e1', CheaplyReducibleE r e2 e2') - => CheaplyReducibleE r (PairE e1 e2) (PairE e1' e2') where - cheapReduceE (PairE e1 e2) = PairE <$> cheapReduceE e1 <*> cheapReduceE e2 - -instance (CheaplyReducibleE r e1 e1', CheaplyReducibleE r e2 e2') - => CheaplyReducibleE r (EitherE e1 e2) (EitherE e1' e2') where - cheapReduceE (LeftE e) = LeftE <$> cheapReduceE e - cheapReduceE (RightE e) = RightE <$> cheapReduceE e - --- XXX: TODO: figure out exactly what our normalization invariants are. We --- shouldn't have to choose `normalizeProj` or `asNaryProj` on a --- case-by-case basis. This is here for now because it makes it easier to switch --- to the new version of `ProjectElt`. -asNaryProj :: IRRep r => Projection -> Atom r n -> (NE.NonEmpty Projection, AtomVar r n) -asNaryProj p (Var v) = (p NE.:| [], v) -asNaryProj p1 (ProjectElt _ p2 x) = do - let (p2' NE.:| ps, v) = asNaryProj p2 x - (p1 NE.:| (p2':ps), v) -asNaryProj p x = error $ "Can't normalize projection: " ++ pprint p ++ " " ++ pprint x - --- assumes the atom is already normalized -normalizeNaryProj :: IRRep r => EnvReader m => [Projection] -> Atom r n -> m n (Atom r n) -normalizeNaryProj [] x = return x -normalizeNaryProj (i:is) x = normalizeProj i =<< normalizeNaryProj is x - --- assumes the atom itself is already normalized -normalizeProj :: IRRep r => EnvReader m => Projection -> Atom r n -> m n (Atom r n) -normalizeProj UnwrapNewtype atom = case atom of - NewtypeCon _ x -> return x - SimpInCore (LiftSimp (NewtypeTyCon t) x) -> do - t' <- snd <$> unwrapNewtypeType t - return $ SimpInCore $ LiftSimp t' x - x -> case getType x of - NewtypeTyCon t -> do - t' <- snd <$> unwrapNewtypeType t - return $ ProjectElt t' UnwrapNewtype x - _ -> error "expected a newtype" -normalizeProj (ProjectProduct i) atom = case atom of - Con (ProdCon xs) -> return $ xs !! i - DepPair l _ _ | i == 0 -> return l - DepPair _ r _ | i == 1 -> return r - SimpInCore (LiftSimp _ x) -> do - x' <- normalizeProj (ProjectProduct i) x - resultTy <- getResultTy - return $ SimpInCore $ LiftSimp resultTy x' - RepValAtom (RepVal _ tree) -> case tree of - Branch trees -> do - resultTy <- getResultTy - repValAtom $ RepVal resultTy (trees!!i) - Leaf _ -> error "unexpected leaf" - _ -> do - resultTy <- getResultTy - return $ ProjectElt resultTy (ProjectProduct i) atom - where - getResultTy = projType i (getType atom) atom -{-# INLINE normalizeProj #-} - --- === lifting imp to simp and simp to core === - -repValAtom :: EnvReader m => SRepVal n -> m n (SAtom n) -repValAtom (RepVal ty tree) = case ty of - ProdTy ts -> case tree of - Branch trees -> ProdVal <$> mapM repValAtom (zipWith RepVal ts trees) - _ -> malformed - BaseTy _ -> case tree of - Leaf x -> case x of - ILit l -> return $ Con $ Lit l - _ -> fallback - _ -> malformed - _ -> fallback - where fallback = return $ RepValAtom $ RepVal ty tree - malformed = error "malformed repval" -{-# INLINE repValAtom #-} - -liftSimpType :: EnvReader m => SType n -> m n (CType n) -liftSimpType = \case - BaseTy t -> return $ BaseTy t - ProdTy ts -> ProdTy <$> mapM rec ts - SumTy ts -> SumTy <$> mapM rec ts - t -> error $ "not implemented: " ++ pprint t - where rec = liftSimpType -{-# INLINE liftSimpType #-} - -liftSimpAtom :: EnvReader m => Type CoreIR n -> SAtom n -> m n (CAtom n) -liftSimpAtom ty simpAtom = case simpAtom of - Var _ -> justLift - ProjectElt _ _ _ -> justLift - RepValAtom _ -> justLift -- TODO(dougalm): should we make more effort to pull out products etc? - _ -> do - (cons , ty') <- unwrapLeadingNewtypesType ty - atom <- case (ty', simpAtom) of - (BaseTy _ , Con (Lit v)) -> return $ Con $ Lit v - (ProdTy tys, Con (ProdCon xs)) -> Con . ProdCon <$> zipWithM rec tys xs - (SumTy tys, Con (SumCon _ i x)) -> Con . SumCon tys i <$> rec (tys!!i) x - (DepPairTy dpt@(DepPairType _ (b:>t1) t2), DepPair x1 x2 _) -> do - x1' <- rec t1 x1 - t2' <- applySubst (b@>SubstVal x1') t2 - x2' <- rec t2' x2 - return $ DepPair x1' x2' dpt - _ -> error $ "can't lift " <> pprint simpAtom <> " to " <> pprint ty' - return $ wrapNewtypesData cons atom - where - rec = liftSimpAtom - justLift = return $ SimpInCore $ LiftSimp ty simpAtom -{-# INLINE liftSimpAtom #-} - -liftSimpFun :: EnvReader m => Type CoreIR n -> LamExpr SimpIR n -> m n (CAtom n) -liftSimpFun (Pi piTy) f = return $ SimpInCore $ LiftSimpFun piTy f -liftSimpFun _ _ = error "not a pi type" - --- See Note [Confuse GHC] from Simplify.hs -confuseGHC :: IRRep r => CheapReducerM r i n (DistinctEvidence n) -confuseGHC = getDistinct -{-# INLINE confuseGHC #-} - --- TODO: These used to live in QueryType. Think about a better way to organize --- them. Maybe a common set of low-level type-querying utils that both --- CheapReduction and QueryType import? - -depPairLeftTy :: DepPairType r n -> Type r n -depPairLeftTy (DepPairType _ (_:>ty) _) = ty -{-# INLINE depPairLeftTy #-} - -unwrapNewtypeType :: EnvReader m => NewtypeTyCon n -> m n (NewtypeCon n, Type CoreIR n) -unwrapNewtypeType = \case - Nat -> return (NatCon, IdxRepTy) - Fin n -> return (FinCon n, NatTy) - UserADTType sn defName params -> do - def <- lookupTyCon defName - ty' <- dataDefRep <$> instantiateTyConDef def params - return (UserADTData sn defName params, ty') - ty -> error $ "Shouldn't be projecting: " ++ pprint ty -{-# INLINE unwrapNewtypeType #-} - -projType :: (IRRep r, EnvReader m) => Int -> Type r n -> Atom r n -> m n (Type r n) -projType i ty x = case ty of - ProdTy xs -> return $ xs !! i - DepPairTy t | i == 0 -> return $ depPairLeftTy t - DepPairTy t | i == 1 -> do - xFst <- normalizeProj (ProjectProduct 0) x - instantiate t [xFst] - _ -> error $ "Can't project type: " ++ pprint ty - -unwrapLeadingNewtypesType :: EnvReader m => CType n -> m n ([NewtypeCon n], CType n) -unwrapLeadingNewtypesType = \case - NewtypeTyCon tyCon -> do - (dataCon, ty) <- unwrapNewtypeType tyCon - (dataCons, ty') <- unwrapLeadingNewtypesType ty - return (dataCon:dataCons, ty') - ty -> return ([], ty) - -wrapNewtypesData :: [NewtypeCon n] -> CAtom n-> CAtom n -wrapNewtypesData [] x = x -wrapNewtypesData (c:cs) x = NewtypeCon c $ wrapNewtypesData cs x - -instantiateTyConDef :: EnvReader m => TyConDef n -> TyConParams n -> m n (DataConDefs n) -instantiateTyConDef (TyConDef _ _ bs conDefs) (TyConParams _ xs) = do - applySubst (bs @@> (SubstVal <$> xs)) conDefs -{-# INLINE instantiateTyConDef #-} - -assumeConst - :: (IRRep r, HoistableE body, SinkableE body, ToBindersAbs e body r) => e n -> body n -assumeConst e = case toAbs e of Abs bs body -> ignoreHoistFailure $ hoist bs body - -instantiate - :: (EnvReader m, IRRep r, SubstE (SubstVal Atom) body, SinkableE body, ToBindersAbs e body r) - => e n -> [Atom r n] -> m n (body n) -instantiate e xs = case toAbs e of - Abs bs body -> applySubst (bs @@> (SubstVal <$> xs)) body - --- "lazy" subst-extending version of `instantiate` -withInstantiated - :: (SubstReader AtomSubstVal m, IRRep r, SubstE (SubstVal Atom) body, SinkableE body, ToBindersAbs e body r) - => e i -> [Atom r o] - -> (forall i'. body i' -> m i' o a) - -> m i o a -withInstantiated e xs cont = case toAbs e of - Abs bs body -> extendSubst (bs @@> (SubstVal <$> xs)) $ cont body - -instantiateNames - :: (EnvReader m, IRRep r, RenameE body, SinkableE body, ToBindersAbs e body r) - => e n -> [AtomName r n] -> m n (body n) -instantiateNames e vs = case toAbs e of - Abs bs body -> applyRename (bs @@> vs) body - --- "lazy" subst-extending version of `instantiateNames` -withInstantiatedNames - :: (SubstReader Name m, IRRep r, RenameE body, SinkableE body, ToBindersAbs e body r) - => e i -> [AtomName r o] - -> (forall i'. body i' -> m i' o a) - -> m i o a -withInstantiatedNames e vs cont = case toAbs e of - Abs bs body -> extendRenamer (bs @@> vs) $ cont body - --- Returns a representation type (type of an TypeCon-typed Newtype payload) --- given a list of instantiated DataConDefs. -dataDefRep :: DataConDefs n -> CType n -dataDefRep (ADTCons cons) = case cons of - [] -> error "unreachable" -- There's no representation for a void type - [DataConDef _ _ ty _] -> ty - tys -> SumTy $ tys <&> \(DataConDef _ _ ty _) -> ty -dataDefRep (StructFields fields) = case map snd fields of - [ty] -> ty - tys -> ProdTy tys - -makeStructRepVal :: (Fallible1 m, EnvReader m) => TyConName n -> [CAtom n] -> m n (CAtom n) -makeStructRepVal tyConName args = do - TyConDef _ _ _ (StructFields fields) <- lookupTyCon tyConName - case fields of - [_] -> case args of - [arg] -> return arg - _ -> error "wrong number of args" - _ -> return $ ProdVal args - --- === traversable terms === - -class Monad m => NonAtomRenamer m i o | m -> i, m -> o where - renameN :: (IsAtomName c ~ False, Color c) => Name c i -> m (Name c o) - -class NonAtomRenamer m i o => Visitor m r i o | m -> i, m -> o where - visitType :: Type r i -> m (Type r o) - visitAtom :: Atom r i -> m (Atom r o) - visitLam :: LamExpr r i -> m (LamExpr r o) - visitPi :: PiType r i -> m (PiType r o) - -class VisitGeneric (e:: E) (r::IR) | e -> r where - visitGeneric :: Visitor m r i o => e i -> m (e o) - -type Visitor2 (m::MonadKind2) r = forall i o . Visitor (m i o) r i o - -instance VisitGeneric (Atom r) r where visitGeneric = visitAtom -instance VisitGeneric (Type r) r where visitGeneric = visitType -instance VisitGeneric (LamExpr r) r where visitGeneric = visitLam -instance VisitGeneric (PiType r) r where visitGeneric = visitPi - -visitBlock :: Visitor m r i o => Block r i -> m (Block r o) -visitBlock b = visitGeneric (LamExpr Empty b) >>= \case - LamExpr Empty b' -> return b' - _ -> error "not a block" - -visitAlt :: Visitor m r i o => Alt r i -> m (Alt r o) -visitAlt (Abs b body) = do - visitGeneric (LamExpr (UnaryNest b) body) >>= \case - LamExpr (UnaryNest b') body' -> return $ Abs b' body' - _ -> error "not an alt" - -traverseOpTerm - :: (GenericOp e, Visitor m r i o, OpConst e r ~ OpConst e r) - => e r i -> m (e r o) -traverseOpTerm e = traverseOp e visitGeneric visitGeneric visitGeneric - -visitAtomDefault - :: (IRRep r, Visitor (m i o) r i o, AtomSubstReader v m, EnvReader2 m) - => Atom r i -> m i o (Atom r o) -visitAtomDefault atom = case atom of - Var _ -> atomSubstM atom - SimpInCore _ -> atomSubstM atom - ProjectElt t i x -> ProjectElt <$> visitType t <*> pure i <*> visitGeneric x - _ -> visitAtomPartial atom - -visitTypeDefault - :: (IRRep r, Visitor (m i o) r i o, AtomSubstReader v m, EnvReader2 m) - => Type r i -> m i o (Type r o) -visitTypeDefault = \case - TyVar v -> atomSubstM $ TyVar v - ProjectEltTy t i x -> ProjectEltTy <$> visitType t <*> pure i <*> visitGeneric x - x -> visitTypePartial x - -visitPiDefault - :: (Visitor2 m r, IRRep r, FromName v, AtomSubstReader v m, EnvExtender2 m) - => PiType r i -> m i o (PiType r o) -visitPiDefault (PiType bs effty) = do - visitBinders bs \bs' -> do - effty' <- visitGeneric effty - return $ PiType bs' effty' - -visitBinders - :: (Visitor2 m r, IRRep r, FromName v, AtomSubstReader v m, EnvExtender2 m) - => Nest (Binder r) i i' - -> (forall o'. DExt o o' => Nest (Binder r) o o' -> m i' o' a) - -> m i o a -visitBinders Empty cont = getDistinct >>= \Distinct -> cont Empty -visitBinders (Nest (b:>ty) bs) cont = do - ty' <- visitType ty - withFreshBinder (getNameHint b) ty' \b' -> do - extendRenamer (b@>binderName b') do - visitBinders bs \bs' -> - cont $ Nest b' bs' - --- XXX: This doesn't handle the `Var`, `ProjectElt`, `SimpInCore` cases. These --- should be handled explicitly beforehand. TODO: split out these cases under a --- separate constructor, perhaps even a `hole` paremeter to `Atom` or part of --- `IR`. -visitAtomPartial :: (IRRep r, Visitor m r i o) => Atom r i -> m (Atom r o) -visitAtomPartial = \case - Var _ -> error "Not handled generically" - SimpInCore _ -> error "Not handled generically" - ProjectElt _ _ _ -> error "Not handled generically" - Con con -> Con <$> visitGeneric con - PtrVar t v -> PtrVar t <$> renameN v - DepPair x y t -> do - x' <- visitGeneric x - y' <- visitGeneric y - ~(DepPairTy t') <- visitGeneric $ DepPairTy t - return $ DepPair x' y' t' - Lam lam -> Lam <$> visitGeneric lam - Eff eff -> Eff <$> visitGeneric eff - DictCon t d -> DictCon <$> visitType t <*> visitGeneric d - NewtypeCon con x -> NewtypeCon <$> visitGeneric con <*> visitGeneric x - DictHole ctx ty access -> DictHole ctx <$> visitGeneric ty <*> pure access - TypeAsAtom t -> TypeAsAtom <$> visitGeneric t - RepValAtom repVal -> RepValAtom <$> visitGeneric repVal - --- XXX: This doesn't handle the `TyVar` or `ProjectEltTy` cases. These should be --- handled explicitly beforehand. -visitTypePartial :: (IRRep r, Visitor m r i o) => Type r i -> m (Type r o) -visitTypePartial = \case - TyVar _ -> error "Not handled generically" - ProjectEltTy _ _ _ -> error "Not handled generically" - NewtypeTyCon t -> NewtypeTyCon <$> visitGeneric t - Pi t -> Pi <$> visitGeneric t - TabPi t -> TabPi <$> visitGeneric t - TC t -> TC <$> visitGeneric t - DepPairTy t -> DepPairTy <$> visitGeneric t - DictTy t -> DictTy <$> visitGeneric t - -instance IRRep r => VisitGeneric (Expr r) r where - visitGeneric = \case - TopApp et v xs -> TopApp <$> visitGeneric et <*> renameN v <*> mapM visitGeneric xs - TabApp t tab xs -> TabApp <$> visitType t <*> visitGeneric tab <*> mapM visitGeneric xs - -- TODO: should we reuse the original effects? Whether it's valid depends on - -- the type-preservation requirements for a visitor. We should clarify what - -- those are. - Case x alts effTy -> do - x' <- visitGeneric x - alts' <- mapM visitAlt alts - effTy' <- visitGeneric effTy - return $ Case x' alts' effTy' - Atom x -> Atom <$> visitGeneric x - TabCon Nothing t xs -> TabCon Nothing <$> visitGeneric t <*> mapM visitGeneric xs - TabCon (Just (WhenIRE d)) t xs -> TabCon <$> (Just . WhenIRE <$> visitGeneric d) <*> visitGeneric t <*> mapM visitGeneric xs - PrimOp op -> PrimOp <$> visitGeneric op - App et fAtom xs -> App <$> visitGeneric et <*> visitGeneric fAtom <*> mapM visitGeneric xs - ApplyMethod et m i xs -> ApplyMethod <$> visitGeneric et <*> visitGeneric m <*> pure i <*> mapM visitGeneric xs - -instance IRRep r => VisitGeneric (PrimOp r) r where - visitGeneric = \case - UnOp op x -> UnOp op <$> visitGeneric x - BinOp op x y -> BinOp op <$> visitGeneric x <*> visitGeneric y - MemOp op -> MemOp <$> visitGeneric op - VectorOp op -> VectorOp <$> visitGeneric op - MiscOp op -> MiscOp <$> visitGeneric op - Hof op -> Hof <$> visitGeneric op - DAMOp op -> DAMOp <$> visitGeneric op - RefOp r op -> RefOp <$> visitGeneric r <*> traverseOp op visitGeneric visitGeneric visitGeneric - -instance IRRep r => VisitGeneric (TypedHof r) r where - visitGeneric (TypedHof eff hof) = TypedHof <$> visitGeneric eff <*> visitGeneric hof - -instance IRRep r => VisitGeneric (Hof r) r where - visitGeneric = \case - For ann d lam -> For ann <$> visitGeneric d <*> visitGeneric lam - RunReader x body -> RunReader <$> visitGeneric x <*> visitGeneric body - RunWriter dest bm body -> RunWriter <$> mapM visitGeneric dest <*> visitGeneric bm <*> visitGeneric body - RunState dest s body -> RunState <$> mapM visitGeneric dest <*> visitGeneric s <*> visitGeneric body - While b -> While <$> visitBlock b - RunIO b -> RunIO <$> visitBlock b - RunInit b -> RunInit <$> visitBlock b - CatchException t b -> CatchException <$> visitType t <*> visitBlock b - Linearize lam x -> Linearize <$> visitGeneric lam <*> visitGeneric x - Transpose lam x -> Transpose <$> visitGeneric lam <*> visitGeneric x - -instance IRRep r => VisitGeneric (BaseMonoid r) r where - visitGeneric (BaseMonoid x lam) = BaseMonoid <$> visitGeneric x <*> visitGeneric lam - -instance IRRep r => VisitGeneric (DAMOp r) r where - visitGeneric = \case - Seq eff dir d x lam -> Seq <$> visitGeneric eff <*> pure dir <*> visitGeneric d <*> visitGeneric x <*> visitGeneric lam - RememberDest eff x lam -> RememberDest <$> visitGeneric eff <*> visitGeneric x <*> visitGeneric lam - AllocDest t -> AllocDest <$> visitGeneric t - Place x y -> Place <$> visitGeneric x <*> visitGeneric y - Freeze x -> Freeze <$> visitGeneric x - -instance IRRep r => VisitGeneric (Effect r) r where - visitGeneric = \case - RWSEffect rws h -> RWSEffect rws <$> visitGeneric h - ExceptionEffect -> pure ExceptionEffect - IOEffect -> pure IOEffect - InitEffect -> pure InitEffect - -instance IRRep r => VisitGeneric (EffectRow r) r where - visitGeneric (EffectRow effs tailVar) = do - effs' <- eSetFromList <$> mapM visitGeneric (eSetToList effs) - tailEffRow <- case tailVar of - NoTail -> return $ EffectRow mempty NoTail - EffectRowTail v -> visitGeneric (Var v) <&> \case - Var v' -> EffectRow mempty (EffectRowTail v') - Eff r -> r - _ -> error "Not a valid effect substitution" - return $ extendEffRow effs' tailEffRow - -instance VisitGeneric DictExpr CoreIR where - visitGeneric = \case - InstantiatedGiven x xs -> InstantiatedGiven <$> visitGeneric x <*> mapM visitGeneric xs - SuperclassProj x i -> SuperclassProj <$> visitGeneric x <*> pure i - InstanceDict v xs -> InstanceDict <$> renameN v <*> mapM visitGeneric xs - IxFin x -> IxFin <$> visitGeneric x - DataData t -> DataData <$> visitGeneric t - -instance VisitGeneric NewtypeCon CoreIR where - visitGeneric = \case - UserADTData sn t params -> UserADTData sn <$> renameN t <*> visitGeneric params - NatCon -> return NatCon - FinCon x -> FinCon <$> visitGeneric x - -instance VisitGeneric NewtypeTyCon CoreIR where - visitGeneric = \case - Nat -> return Nat - Fin x -> Fin <$> visitGeneric x - EffectRowKind -> return EffectRowKind - UserADTType n v params -> UserADTType n <$> renameN v <*> visitGeneric params - -instance VisitGeneric TyConParams CoreIR where - visitGeneric (TyConParams expls xs) = TyConParams expls <$> mapM visitGeneric xs - -instance IRRep r => VisitGeneric (IxDict r) r where - visitGeneric = \case - IxDictAtom x -> IxDictAtom <$> visitGeneric x - IxDictRawFin x -> IxDictRawFin <$> visitGeneric x - IxDictSpecialized t v xs -> IxDictSpecialized <$> visitGeneric t <*> renameN v <*> mapM visitGeneric xs - -instance IRRep r => VisitGeneric (IxType r) r where - visitGeneric (IxType t d) = IxType <$> visitType t <*> visitGeneric d - -instance VisitGeneric DictType CoreIR where - visitGeneric (DictType n v xs) = DictType n <$> renameN v <*> mapM visitGeneric xs - -instance VisitGeneric CoreLamExpr CoreIR where - visitGeneric (CoreLamExpr t lam) = CoreLamExpr <$> visitGeneric t <*> visitGeneric lam - -instance VisitGeneric CorePiType CoreIR where - visitGeneric (CorePiType app expl bs effty) = do - PiType bs' effty' <- visitGeneric $ PiType bs effty - return $ CorePiType app expl bs' effty' - -instance IRRep r => VisitGeneric (TabPiType r) r where - visitGeneric (TabPiType d b eltTy) = do - d' <- visitGeneric d - visitGeneric (PiType (UnaryNest b) (EffTy Pure eltTy)) <&> \case - PiType (UnaryNest b') (EffTy Pure eltTy') -> TabPiType d' b' eltTy' - _ -> error "not a table pi type" - -instance IRRep r => VisitGeneric (DepPairType r) r where - visitGeneric (DepPairType expl b ty) = do - visitGeneric (PiType (UnaryNest b) (EffTy Pure ty)) <&> \case - PiType (UnaryNest b') (EffTy Pure ty') -> DepPairType expl b' ty' - _ -> error "not a dependent pair type" - -instance VisitGeneric (RepVal SimpIR) SimpIR where - visitGeneric (RepVal ty tree) = RepVal <$> visitGeneric ty <*> mapM renameIExpr tree - where renameIExpr = \case - ILit l -> return $ ILit l - IVar v t -> IVar <$> renameN v <*> pure t - IPtrVar v t -> IPtrVar <$> renameN v <*> pure t - -instance IRRep r => VisitGeneric (DeclBinding r) r where - visitGeneric (DeclBinding ann expr) = DeclBinding ann <$> visitGeneric expr - -instance IRRep r => VisitGeneric (EffTy r) r where - visitGeneric (EffTy eff ty) = - EffTy <$> visitGeneric eff <*> visitGeneric ty - -instance VisitGeneric DataConDefs CoreIR where - visitGeneric = \case - ADTCons cons -> ADTCons <$> mapM visitGeneric cons - StructFields defs -> do - let (names, tys) = unzip defs - tys' <- mapM visitGeneric tys - return $ StructFields $ zip names tys' - -instance VisitGeneric DataConDef CoreIR where - visitGeneric (DataConDef sn (Abs bs UnitE) repTy ps) = do - PiType bs' _ <- visitGeneric $ PiType bs $ EffTy Pure UnitTy - repTy' <- visitGeneric repTy - return $ DataConDef sn (Abs bs' UnitE) repTy' ps - -instance VisitGeneric (Con r) r where visitGeneric = traverseOpTerm -instance VisitGeneric (TC r) r where visitGeneric = traverseOpTerm -instance VisitGeneric (MiscOp r) r where visitGeneric = traverseOpTerm -instance VisitGeneric (VectorOp r) r where visitGeneric = traverseOpTerm -instance VisitGeneric (MemOp r) r where visitGeneric = traverseOpTerm - --- === SubstE/SubstB instances === --- These live here, as orphan instances, because we normalize as we substitute. - -toAtomVar :: (EnvReader m, IRRep r) => AtomName r n -> m n (AtomVar r n) -toAtomVar v = do - ty <- getType <$> lookupAtomName v - return $ AtomVar v ty - -bindersToVars :: (EnvReader m, IRRep r) => Nest (Binder r) n' n -> m n [AtomVar r n] -bindersToVars bs = do - withExtEvidence bs do - Distinct <- getDistinct - mapM toAtomVar $ nestToNames bs - -bindersToAtoms :: (EnvReader m, IRRep r) => Nest (Binder r) n' n -> m n [Atom r n] -bindersToAtoms bs = liftM (Var <$>) $ bindersToVars bs - -newtype SubstVisitor i o a = SubstVisitor { runSubstVisitor :: Reader (Env o, Subst AtomSubstVal i o) a } - deriving (Functor, Applicative, Monad, MonadReader (Env o, Subst AtomSubstVal i o)) - -substV :: (Distinct o, SubstE AtomSubstVal e) => e i -> SubstVisitor i o (e o) -substV x = ask <&> \env -> substE env x - -instance Distinct o => NonAtomRenamer (SubstVisitor i o) i o where - renameN = substV - -instance (Distinct o, IRRep r) => Visitor (SubstVisitor i o) r i o where - visitType = substV - visitAtom = substV - visitLam = substV - visitPi = substV - -instance Color c => SubstE AtomSubstVal (AtomSubstVal c) where - substE (_, env) (Rename name) = env ! name - substE env (SubstVal val) = SubstVal $ substE env val - -instance SubstV (SubstVal Atom) (SubstVal Atom) where - -instance IRRep r => SubstE AtomSubstVal (Atom r) where - substE es@(env, subst) = \case - Var (AtomVar v ty) -> case subst!v of - Rename v' -> Var $ AtomVar v' (substE es ty) - SubstVal x -> x - SimpInCore x -> SimpInCore (substE es x) - ProjectElt _ i x -> do - let x' = substE es x - runEnvReaderM env $ normalizeProj i x' - atom -> runReader (runSubstVisitor $ visitAtomPartial atom) es - -instance IRRep r => SubstE AtomSubstVal (Type r) where - substE es@(env, subst) = \case - TyVar (AtomVar v ty) -> case subst ! v of - Rename v' -> TyVar $ AtomVar v' (substE es ty) - SubstVal (Type t) -> t - SubstVal atom -> error $ "bad substitution: " ++ pprint v ++ " -> " ++ pprint atom - ProjectEltTy _ i x -> do - let x' = substE es x - case runEnvReaderM env $ normalizeProj i x' of - Type t -> t - _ -> error "bad substitution" - ty -> runReader (runSubstVisitor $ visitTypePartial ty) es - -instance SubstE AtomSubstVal SimpInCore - -instance IRRep r => SubstE AtomSubstVal (EffectRow r) where - substE env (EffectRow effs tailVar) = do - let effs' = eSetFromList $ map (substE env) (eSetToList effs) - let tailEffRow = case tailVar of - NoTail -> EffectRow mempty NoTail - EffectRowTail (AtomVar v _) -> case snd env ! v of - Rename v' -> do - let v'' = runEnvReaderM (fst env) $ toAtomVar v' - EffectRow mempty (EffectRowTail v'') - SubstVal (Var v') -> EffectRow mempty (EffectRowTail v') - SubstVal (Eff r) -> r - _ -> error "Not a valid effect substitution" - extendEffRow effs' tailEffRow - -instance IRRep r => SubstE AtomSubstVal (Effect r) - -instance SubstE AtomSubstVal SpecializationSpec where - substE env (AppSpecialization (AtomVar f _) ab) = do - let f' = case snd env ! f of - Rename v -> runEnvReaderM (fst env) $ toAtomVar v - SubstVal (Var v) -> v - _ -> error "bad substitution" - AppSpecialization f' (substE env ab) - -instance SubstE AtomSubstVal EffectDef -instance SubstE AtomSubstVal EffectOpType -instance SubstE AtomSubstVal IExpr -instance IRRep r => SubstE AtomSubstVal (RepVal r) -instance SubstE AtomSubstVal TyConParams -instance SubstE AtomSubstVal DataConDef -instance IRRep r => SubstE AtomSubstVal (BaseMonoid r) -instance IRRep r => SubstE AtomSubstVal (DAMOp r) -instance IRRep r => SubstE AtomSubstVal (TypedHof r) -instance IRRep r => SubstE AtomSubstVal (Hof r) -instance IRRep r => SubstE AtomSubstVal (TC r) -instance IRRep r => SubstE AtomSubstVal (Con r) -instance IRRep r => SubstE AtomSubstVal (MiscOp r) -instance IRRep r => SubstE AtomSubstVal (VectorOp r) -instance IRRep r => SubstE AtomSubstVal (MemOp r) -instance IRRep r => SubstE AtomSubstVal (PrimOp r) -instance IRRep r => SubstE AtomSubstVal (RefOp r) -instance IRRep r => SubstE AtomSubstVal (EffTy r) -instance IRRep r => SubstE AtomSubstVal (Expr r) -instance IRRep r => SubstE AtomSubstVal (GenericOpRep const r) -instance SubstE AtomSubstVal InstanceBody -instance SubstE AtomSubstVal DictType -instance SubstE AtomSubstVal DictExpr -instance IRRep r => SubstE AtomSubstVal (LamExpr r) -instance SubstE AtomSubstVal CorePiType -instance SubstE AtomSubstVal CoreLamExpr -instance IRRep r => SubstE AtomSubstVal (TabPiType r) -instance IRRep r => SubstE AtomSubstVal (PiType r) -instance IRRep r => SubstE AtomSubstVal (DepPairType r) -instance SubstE AtomSubstVal SolverBinding -instance IRRep r => SubstE AtomSubstVal (DeclBinding r) -instance IRRep r => SubstB AtomSubstVal (Decl r) -instance SubstE AtomSubstVal NewtypeTyCon -instance SubstE AtomSubstVal NewtypeCon -instance IRRep r => SubstE AtomSubstVal (IxDict r) -instance IRRep r => SubstE AtomSubstVal (IxType r) -instance SubstE AtomSubstVal DataConDefs diff --git a/src/lib/CheckType.hs b/src/lib/CheckType.hs index a49e5989f..3390126b2 100644 --- a/src/lib/CheckType.hs +++ b/src/lib/CheckType.hs @@ -15,12 +15,12 @@ import Control.Monad.Reader import Control.Monad.State.Class import Data.Functor -import CheapReduction import Core import Err import IRVariants import MTL1 import Name +import Builder import Subst import PPrint () import QueryType @@ -87,15 +87,16 @@ parallelAffines actions = TyperM $ do -- === typeable things === checkTypesEq :: IRRep r => Type r o -> Type r o -> TyperM r i o () -checkTypesEq reqTy ty = alphaEq reqTy ty >>= \case - True -> return () - False -> {-# SCC typeNormalization #-} do - reqTy' <- cheapNormalize reqTy - ty' <- cheapNormalize ty - alphaEq reqTy' ty' >>= \case - True -> return () - False -> throw TypeErr $ pprint reqTy' ++ " != " ++ pprint ty' -{-# INLINE checkTypesEq #-} +checkTypesEq reqTy ty = undefined +-- checkTypesEq reqTy ty = alphaEq reqTy ty >>= \case +-- True -> return () +-- False -> {-# SCC typeNormalization #-} do +-- reqTy' <- cheapNormalize reqTy +-- ty' <- cheapNormalize ty +-- alphaEq reqTy' ty' >>= \case +-- True -> return () +-- False -> throw TypeErr $ pprint reqTy' ++ " != " ++ pprint ty' +-- {-# INLINE checkTypesEq #-} class SinkableE e => CheckableE (r::IR) (e::E) | e -> r where checkE :: e i -> TyperM r i o (e o) @@ -179,27 +180,6 @@ instance IRRep r => CheckableE r (Atom r) where con' <- typeCheckNewtypeCon con xTy return $ NewtypeCon con' x' SimpInCore x -> SimpInCore <$> checkE x - DictHole ctx ty access -> do - ty' <- ty |: TyKind - return $ DictHole ctx ty' access - ProjectElt resultTy UnwrapNewtype x -> do - resultTy' <- resultTy |: TyKind - (x', NewtypeTyCon con) <- checkAndGetType x - resultTy'' <- snd <$> unwrapNewtypeType con - checkTypesEq resultTy' resultTy'' - return $ ProjectElt resultTy' UnwrapNewtype x' - ProjectElt resultTy (ProjectProduct i) x -> do - resultTy' <- resultTy |: TyKind - (x', xTy) <- checkAndGetType x - resultTy'' <- case xTy of - ProdTy tys -> return $ tys !! i - DepPairTy t | i == 0 -> return $ depPairLeftTy t - DepPairTy t | i == 1 -> do - xFst <- normalizeProj (ProjectProduct 0) x' - checkInstantiation t [xFst] - _ -> throw TypeErr $ "Not a product type:" ++ pprint xTy - checkTypesEq resultTy' resultTy'' - return $ ProjectElt resultTy' (ProjectProduct i) x' TypeAsAtom ty -> TypeAsAtom <$> checkE ty instance IRRep r => CheckableE r (AtomVar r) where @@ -224,25 +204,6 @@ instance IRRep r => CheckableE r (Type r) where void $ checkInstantiation (Abs paramBs UnitE) params' return $ DictTy (DictType sn className' params') TyVar v -> TyVar <$> checkE v - ProjectEltTy resultTy UnwrapNewtype x -> do - resultTy' <- resultTy |: TyKind - x' <- checkE x - NewtypeTyCon con <- return $ getType x' - ty <- snd <$> unwrapNewtypeType con - checkTypesEq resultTy' ty - return $ ProjectEltTy resultTy' UnwrapNewtype x' - ProjectEltTy resultTy (ProjectProduct i) x -> do - resultTy' <- resultTy |: TyKind - (x', ty) <- checkAndGetType x - resultTy'' <- case ty of - ProdTy tys -> return $ tys !! i - DepPairTy t | i == 0 -> return $ depPairLeftTy t - DepPairTy t | i == 1 -> do - xFst <- normalizeProj (ProjectProduct 0) x' - instantiate t [xFst] - _ -> throw TypeErr $ "Not a product type:" ++ pprint ty - checkTypesEq resultTy' resultTy'' - return $ ProjectEltTy resultTy' (ProjectProduct i) x' instance CheckableE CoreIR SimpInCore where checkE x = renameM x -- TODO: check @@ -254,6 +215,12 @@ instance (ToBinding ann c, Color c, CheckableE r ann) => CheckableB r (BinderP c extendRenamer (b@>binderName b') $ cont b' +instance IRRep r => CheckableB r (BinderAndDecls r) where + checkB (BD b ds) cont = checkB b \b' -> checkB ds \ds' -> cont $ BD b' ds' + +instance IRRep r => CheckableB r (Decl r) where + checkB _ _ = undefined + checkBinderType :: (IRRep r) => Type r o -> Binder r i i' -> (forall o'. DExt o o' => Binder r o o' -> TyperM r i' o' a) @@ -263,6 +230,12 @@ checkBinderType ty b cont = do checkTypesEq (sink $ binderType b') (sink ty) cont b' +checkBinderAndDecls + :: (IRRep r) => Type r o -> BinderAndDecls r i i' + -> (forall o'. DExt o o' => BinderAndDecls r o o' -> TyperM r i' o' a) + -> TyperM r i o a +checkBinderAndDecls ty _ _ = undefined + instance IRRep r => CheckableWithEffects r (Expr r) where checkWithEffects allowedEffs expr = addContext ("Checking expr:\n" ++ pprint expr) case expr of App effTy f xs -> do @@ -300,14 +273,14 @@ instance IRRep r => CheckableWithEffects r (Expr r) where checkTypesEq (sink reqBinderTy) (sink $ binderType b') Abs b' <$> checkBlock (sink effTy') body return $ Case scrut' alts' effTy' - ApplyMethod effTy dict i args -> do - effTy' <- checkEffTy allowedEffs effTy - dict' <- checkE dict - args' <- mapM checkE args - methodTy <- getMethodType dict' i - effTy'' <- checkInstantiation methodTy args' - checkAlphaEq effTy' effTy'' - return $ ApplyMethod effTy' dict' i args' + -- ApplyMethod effTy dict i args -> do + -- effTy' <- checkEffTy allowedEffs effTy + -- dict' <- checkE dict + -- args' <- mapM checkE args + -- methodTy <- getMethodType dict' i + -- effTy'' <- checkInstantiation methodTy args' + -- checkAlphaEq effTy' effTy'' + -- return $ ApplyMethod effTy' dict' i args' TabCon maybeD ty xs -> do ty'@(TabPi (TabPiType _ b restTy)) <- ty |: TyKind maybeD' <- mapM renameM maybeD -- TODO: check @@ -318,6 +291,27 @@ instance IRRep r => CheckableWithEffects r (Expr r) where -- each index from the ix dict. HoistFailure _ -> forM xs checkE return $ TabCon maybeD' ty' xs' + DictHole ctx ty access -> do + ty' <- ty |: TyKind + return $ DictHole ctx ty' access + ProjectElt resultTy UnwrapNewtype x -> undefined + -- resultTy' <- resultTy |: TyKind + -- (x', NewtypeTyCon con) <- checkAndGetType x + -- resultTy'' <- snd <$> unwrapNewtypeType con + -- checkTypesEq resultTy' resultTy'' + -- return $ ProjectElt resultTy' UnwrapNewtype x' + -- ProjectElt resultTy (ProjectProduct i) x -> do + -- resultTy' <- resultTy |: TyKind + -- (x', xTy) <- checkAndGetType x + -- resultTy'' <- case xTy of + -- ProdTy tys -> return $ tys !! i + -- DepPairTy t | i == 0 -> return $ depPairLeftTy t + -- DepPairTy t | i == 1 -> do + -- xFst <- normalizeProj (ProjectProduct 0) x' + -- checkInstantiation t [xFst] + -- _ -> throw TypeErr $ "Not a product type:" ++ pprint xTy + -- checkTypesEq resultTy' resultTy'' + -- return $ ProjectElt resultTy' (ProjectProduct i) x' instance CheckableE CoreIR TyConParams where checkE (TyConParams expls params) = TyConParams expls <$> mapM checkE params @@ -480,17 +474,17 @@ instance IRRep r => CheckableWithEffects r (PrimOp r) where eltTy' <- checkInstantiation tabTy [i'] checkTypesEq givenTy' (TC $ RefType h eltTy') return $ IndexRef givenTy' i' - ProjRef givenTy p -> do - givenTy' <- givenTy |: TyKind - resultEltTy <- case p of - ProjectProduct i -> do - ProdTy tys <- return s - return $ tys !! i - UnwrapNewtype -> do - NewtypeTyCon tc <- return s - snd <$> unwrapNewtypeType tc - checkTypesEq givenTy' (TC $ RefType h resultEltTy) - return $ ProjRef givenTy' p + -- ProjRef givenTy p -> do + -- givenTy' <- givenTy |: TyKind + -- resultEltTy <- case p of + -- ProjectProduct i -> do + -- ProdTy tys <- return s + -- return $ tys !! i + -- UnwrapNewtype -> do + -- NewtypeTyCon tc <- return s + -- snd <$> unwrapNewtypeType tc + -- checkTypesEq givenTy' (TC $ RefType h resultEltTy) + -- return $ ProjRef givenTy' p return $ RefOp ref' m' instance IRRep r => CheckableE r (EffTy r) where @@ -573,12 +567,13 @@ instance IRRep r => CheckableWithEffects r (MiscOp r) where ty|:TyKind checkSomeSumType :: IRRep r => Type r o -> TyperM r i o [Type r o] -checkSomeSumType = \case - SumTy cases -> return cases - NewtypeTyCon con -> do - (_, SumTy cases) <- unwrapNewtypeType con - return cases - t -> error $ "not some sum type: " ++ pprint t +checkSomeSumType = undefined -- need to produce TypeBlock instead? Or just use Emits? +-- checkSomeSumType = \case +-- SumTy cases -> return cases +-- NewtypeTyCon con -> do +-- (_, SumTy cases) <- unwrapNewtypeType con +-- return cases +-- t -> error $ "not some sum type: " ++ pprint t instance IRRep r => CheckableE r (VectorOp r) where checkE = \case @@ -616,7 +611,7 @@ checkHof (EffTy effs reqTy) = \case IxType t d <- checkE ixTy LamExpr (UnaryNest b) body <- return f TabPi tabTy <- return reqTy - checkBinderType t b \b' -> do + checkBinderAndDecls t b \b' -> do resultTy <- checkInstantiation (sink tabTy) [Var $ binderVar b'] body' <- checkBlock (EffTy (sink effs) resultTy) body return $ For dir (IxType t d) (LamExpr (UnaryNest b') body') @@ -627,7 +622,7 @@ checkHof (EffTy effs reqTy) = \case Linearize f x -> do (x', xTy) <- checkAndGetType x LamExpr (UnaryNest b) body <- return f - checkBinderType xTy b \b' -> do + checkBinderAndDecls xTy b \b' -> do PairTy resultTy fLinTy <- sinkM reqTy body' <- checkBlock (EffTy Pure resultTy) body checkTypesEq fLinTy (Pi $ nonDepPiType [sink xTy] Pure resultTy) @@ -693,7 +688,7 @@ instance IRRep r => CheckableWithEffects r (DAMOp r) where ProdTy refTys -> forM_ refTys \case RawRefTy _ -> return (); _ -> badCarry _ -> badCarry let binderReqTy = PairTy (ixTypeType ixTy') carryTy' - checkBinderType binderReqTy b \b' -> do + checkBinderAndDecls binderReqTy b \b' -> do body' <- checkBlock (EffTy (sink effAnn') UnitTy) body return $ Seq effAnn' dir ixTy' carry' $ LamExpr (UnaryNest b') body' RememberDest effAnn d lam -> do @@ -701,7 +696,7 @@ instance IRRep r => CheckableWithEffects r (DAMOp r) where effAnn' <- checkE effAnn checkExtends effs effAnn' (d', dTy@(RawRefTy _)) <- checkAndGetType d - checkBinderType dTy b \b' -> do + checkBinderAndDecls dTy b \b' -> do body' <- checkBlock (EffTy (sink effAnn') UnitTy) body return $ RememberDest effAnn' d' $ LamExpr (UnaryNest b') body' AllocDest ty -> AllocDest <$> ty|:TyKind @@ -740,10 +735,10 @@ checkRWSAction -> RWS -> LamExpr r i -> TyperM r i o (LamExpr r o) checkRWSAction resultTy referentTy effs rws f = do BinaryLamExpr bH bR body <- return f - checkBinderType (TC HeapType) bH \bH' -> do + checkBinderAndDecls (TC HeapType) bH \bH' -> do let h = Var $ binderVar bH' let refTy = RefTy h (sink referentTy) - checkBinderType refTy bR \bR' -> do + checkBinderAndDecls refTy bR \bR' -> do let effs' = extendEffect (RWSEffect rws $ sink h) (sink effs) body' <- checkBlock (EffTy effs' (sink resultTy)) body return $ BinaryLamExpr bH' bR' body' @@ -775,13 +770,13 @@ checkInstantiation abTop xsTop = do Abs bs body <- return $ toAbs abTop go (Abs bs body) xsTop where - go :: Abs (Nest (Binder r)) body o' -> [Atom r o'] -> TyperM r i o' (body o') + go :: Abs (Binders r) body o' -> [Atom r o'] -> TyperM r i o' (body o') go (Abs Empty body) [] = return body - go (Abs (Nest b bs) body) (x:xs) = do - checkTypesEq (getType x) (binderType b) - rest <- applySubst (b@>SubstVal x) (Abs bs body) - go rest xs - go _ _ = throw ZipErr "Wrong number of args" + -- go (Abs (Nest (BD b) bs) body) (x:xs) = do + -- checkTypesEq (getType x) (binderType b) + -- rest <- applySubst (b@>SubstVal x) (Abs bs body) + -- go rest xs + -- go _ _ = throw ZipErr "Wrong number of args" checkIntBaseType :: Fallible m => BaseType -> m () checkIntBaseType t = case t of diff --git a/src/lib/Core.hs b/src/lib/Core.hs index a7a107b49..e7c221f27 100644 --- a/src/lib/Core.hs +++ b/src/lib/Core.hs @@ -40,6 +40,14 @@ import Types.Core import Types.Imp import Types.Primitives import Types.Source +import QueryType + +-- === Various helpers === + +toAtomVar :: (EnvReader m, IRRep r) => AtomName r n -> m n (AtomVar r n) +toAtomVar v = do + ty <- getType <$> lookupAtomName v + return $ AtomVar v ty -- === Typeclasses for monads === @@ -215,6 +223,10 @@ instance IRRep r => BindsEnv (Decl r) where toEnvFrag (Let b binding) = toEnvFrag $ b :> binding {-# INLINE toEnvFrag #-} +instance IRRep r => BindsEnv (BinderAndDecls r) where + toEnvFrag (BD b d) = toEnvFrag (PairB b d) + {-# INLINE toEnvFrag #-} + instance BindsEnv EnvFrag where toEnvFrag frag = frag {-# INLINE toEnvFrag #-} @@ -415,7 +427,7 @@ liftLamExpr f (TopLam d ty (LamExpr bs body)) = liftM (TopLam d ty) $ liftEnvRea fromNaryForExpr :: IRRep r => Int -> Expr r n -> Maybe (Int, LamExpr r n) fromNaryForExpr maxDepth | maxDepth <= 0 = error "expected non-negative number of args" fromNaryForExpr maxDepth = \case - PrimOp (Hof (TypedHof _ (For _ _ (UnaryLamExpr b body)))) -> + PrimOp (Hof (TypedHof _ (For _ _ (LamExpr (UnaryNest b) body)))) -> extend <|> (Just $ (1, LamExpr (Nest b Empty) body)) where extend = do diff --git a/src/lib/Export.hs b/src/lib/Export.hs index f7ab3184d..4b47bd141 100644 --- a/src/lib/Export.hs +++ b/src/lib/Export.hs @@ -119,7 +119,7 @@ goArgs :: (IRRep r) => CallingConvention -> Nest ExportArg o o' -> [CAtomName o'] - -> Nest (WithAttrB Explicitness (Binder r)) i i' + -> Nest (WithAttrB Explicitness (BinderAndDecls r)) i i' -> Type r i' -> ExportSigM r i o' (ExportedSignature o) goArgs cc argSig argVs piBs piRes = case piBs of @@ -128,10 +128,10 @@ goArgs cc argSig argVs piBs piRes = case piBs of StandardCC -> (fromListE $ sink $ ListE argVs) ++ nestToList (sink . binderName) resSig XLACC -> [] _ -> error $ "calling convention not supported: " ++ show cc - Nest (WithAttrB expl (b:>ty)) bs -> do - ety <- toExportType ty + Nest (WithAttrB expl b) bs -> do + ety <- toExportType $ binderType b withFreshBinder (getNameHint b) ety \(v:>_) -> - extendSubst (b @> Rename (binderName v)) $ do + extendSubstBD b [Rename (binderName v)] do vis <- case expl of Explicit -> return ExplicitArg Inferred _ _ -> return ImplicitArg @@ -173,8 +173,8 @@ parseTabTy = go [] go shape = \case BaseTy (Scalar sbt) -> return $ Just $ RectContArrayPtr sbt shape NewtypeTyCon Nat -> return $ Just $ RectContArrayPtr IdxRepScalarBaseTy shape - TabTy d (b:>ixty) a -> do - maybeN <- case IxType ixty d of + TabTy d b a -> do + maybeN <- case IxType (binderType b) d of IxType (NewtypeTyCon (Fin n)) _ -> return $ Just n IxType _ (IxDictRawFin n) -> return $ Just n _ -> return Nothing diff --git a/src/lib/Generalize.hs b/src/lib/Generalize.hs index 58c0721d4..5fc9595a1 100644 --- a/src/lib/Generalize.hs +++ b/src/lib/Generalize.hs @@ -12,6 +12,7 @@ import Core import Err import Types.Core import Inference +import Builder import IRVariants import QueryType import Name @@ -19,7 +20,7 @@ import Subst import MTL1 import Types.Primitives -type RolePiBinder = WithAttrB RoleExpl CBinder +type RolePiBinder = WithAttrB RoleExpl CBinderAndDecls type RolePiBinders = Nest RolePiBinder generalizeIxDict :: EnvReader m => Atom CoreIR n -> m n (Generalized CoreIR CAtom n) @@ -36,7 +37,7 @@ generalizeArgs fTy argsTop = liftGeneralizerM $ runSubstReaderT idSubst do PairE (CorePiType _ expls bs _) (ListE argsTop') <- sinkM $ PairE fTy (ListE argsTop) ListE <$> go (zipAttrs expls bs) argsTop' where - go :: Nest (WithAttrB Explicitness CBinder) i i' -> [Atom CoreIR n] + go :: Nest (WithAttrB Explicitness CBinderAndDecls) i i' -> [Atom CoreIR n] -> SubstReaderT AtomSubstVal GeneralizerM i n [Atom CoreIR n] go (Nest (WithAttrB expl b) bs) (arg:args) = do ty' <- substM $ binderType b @@ -52,7 +53,7 @@ generalizeArgs fTy argsTop = liftGeneralizerM $ runSubstReaderT idSubst do -- non-type, non-dict arguments (e.g. a function). We just don't -- generalize in that case. return arg - args'' <- extendSubst (b@>SubstVal arg') $ go bs args + args'' <- extendSubstBD b [SubstVal arg'] $ go bs args return $ arg' : args'' go Empty [] = return [] go _ _ = error "zip error" @@ -80,12 +81,12 @@ liftGeneralizerM cont = do return (Abs bs e, vals) where -- OPTIMIZE: something not O(N^2) - hoistGeneralizationVals :: Nest GeneralizationEmission n l -> (Nest (Binder CoreIR) n l, [Atom CoreIR n]) + hoistGeneralizationVals :: Nest GeneralizationEmission n l -> (Binders CoreIR n l, [Atom CoreIR n]) hoistGeneralizationVals Empty = (Empty, []) hoistGeneralizationVals (Nest (GeneralizationEmission b val) bs) = do let (bs', vals) = hoistGeneralizationVals bs case hoist b (ListE vals) of - HoistSuccess (ListE vals') -> (Nest b bs', val:vals') + HoistSuccess (ListE vals') -> (Nest (PlainBD b) bs', val:vals') HoistFailure _ -> error "should't happen" -- when we do the generalization, -- the "local" values we emit never mention the new generalization binders. -- TODO: consider trying to encode this constraint using scope parameters. @@ -130,13 +131,14 @@ traverseTyParams ty f = getDistinct >>= \Distinct -> case ty of Abs paramRoles UnitE <- getClassRoleBinders name params' <- traverseRoleBinders f paramRoles params return $ DictTy $ DictType sn name params' - TabPi (TabPiType (IxDictAtom d) (b:>iTy) resultTy) -> do - iTy' <- f' TypeParam TyKind iTy - dictTy <- liftM ignoreExcept $ runFallibleT1 $ DictTy <$> ixDictType iTy' - d' <- f DictParam dictTy d - withFreshBinder (getNameHint b) iTy' \(b':>_) -> do - resultTy' <- applyRename (b@>binderName b') resultTy >>= (f' TypeParam TyKind) - return $ TabTy (IxDictAtom d') (b':>iTy') resultTy' + TabPi tabTy@(TabPiType (IxDictAtom d) b _) -> undefined + -- TabPi tabTy@(TabPiType (IxDictAtom d) b _) -> do + -- iTy <- f' TypeParam TyKind $ binderType b + -- dictTy <- liftM ignoreExcept $ runFallibleT1 $ DictTy <$> ixDictType iTy + -- d' <- f DictParam dictTy d + -- withFreshBinder (getNameHint b) iTy \b' -> do + -- resultTy' <- instantiate tabTy [Var $ binderVar b'] >>= (f' TypeParam TyKind) + -- return $ TabTy (IxDictAtom d') (PlainBD b') resultTy' -- shouldn't need this once we can exclude IxDictFin and IxDictSpecialized from CoreI TabPi t -> return $ TabPi t TC tc -> TC <$> case tc of @@ -178,7 +180,7 @@ traverseRoleBinders f allBinders allParams = ty' <- substM $ binderType b Distinct <- getDistinct param' <- liftSubstReaderT $ f role ty' param - params'' <- extendSubst (b@>SubstVal param') $ go bs params + params'' <- extendSubstBD b [SubstVal param'] $ go bs params return $ param' : params'' go _ _ = error "zip error" {-# INLINE traverseRoleBinders #-} diff --git a/src/lib/Imp.hs b/src/lib/Imp.hs index 9a9ab2e71..ba641666e 100644 --- a/src/lib/Imp.hs +++ b/src/lib/Imp.hs @@ -32,7 +32,6 @@ import qualified Control.Monad.State.Strict as MTL import Algebra import Builder -import CheapReduction import CheckType (CheckableE (..)) import Core import Err @@ -59,18 +58,18 @@ toImpFunction cc (TopLam True destTy lam) = do case cc of EntryFunCC _ -> do argAtoms <- interpretImpArgs (sink $ EmptyAbs bs) vs - extendSubst (bs @@> (SubstVal <$> argAtoms)) do + extendSubstBD bs (SubstVal <$> argAtoms) do dest <- case binderType destB of RefTy _ ansTy -> allocDestUnmanaged =<< substM ansTy _ -> error "Expected a reference type for body destination" - extendSubst (destB @> SubstVal (destToAtom dest)) do + extendSubstBD destB [SubstVal $ destToAtom dest] do void $ translateBlock body resultAtom <- loadAtom dest repValToList <$> atomToRepVal resultAtom _ -> do (argAtoms, resultDest) <- interpretImpArgsWithCC cc (sink ty) vs - extendSubst (bs @@> (SubstVal <$> argAtoms)) do - extendSubst (destB @> SubstVal (destToAtom (sink resultDest))) do + extendSubstBD bs (SubstVal <$> argAtoms) do + extendSubstBD destB [SubstVal $ destToAtom (sink resultDest)] do void $ translateBlock body return [] toImpFunction _ (TopLam False _ _) = error "expected a lambda in destination-passing form" @@ -126,12 +125,12 @@ getNaryLamImpArgTypes t = liftEnvReaderM $ go t where return (ts:argTys, resultTys) Empty -> ([],) <$> getDestBaseTypes (etTy effTy) -interpretImpArgsWithDest :: EnvReader m - => PiType SimpIR n -> [IExpr n] -> m n ([SAtom n], Dest n) +interpretImpArgsWithDest :: Emits n + => PiType SimpIR n -> [IExpr n] -> SubstImpM i n ([SAtom n], Dest n) interpretImpArgsWithDest t xs = do - (PiType bs (EffTy _ resultTy)) <- return t + piTy@(PiType bs _) <- return t (args, xsLeft) <- _interpretImpArgs (EmptyAbs bs) xs - resultTy' <- applySubst (bs @@> (SubstVal <$> args)) resultTy + EffTy _ resultTy' <- instantiateImp piTy args (destTree, xsRest) <- listToTree resultTy' xsLeft case xsRest of [] -> return () @@ -139,7 +138,7 @@ interpretImpArgsWithDest t xs = do return (args, Dest resultTy' destTree) interpretImpArgs :: EnvReader m - => EmptyAbs (Nest SBinder) n -> [IExpr n] -> m n [SAtom n] + => EmptyAbs SBinders n -> [IExpr n] -> m n [SAtom n] interpretImpArgs t args = do (args', xsLeft) <- _interpretImpArgs t args case xsLeft of @@ -147,17 +146,17 @@ interpretImpArgs t args = do _ -> error "Shouldn't have any Imp arguments left" _interpretImpArgs :: EnvReader m - => EmptyAbs (Nest SBinder) n -> [IExpr n] -> m n ([SAtom n], [IExpr n]) + => EmptyAbs SBinders n -> [IExpr n] -> m n ([SAtom n], [IExpr n]) _interpretImpArgs t args = liftEnvReaderM $ runSubstReaderT idSubst $ go t args where - go :: EmptyAbs (Nest SBinder) i -> [IExpr o] + go :: EmptyAbs SBinders i -> [IExpr o] -> SubstReaderT AtomSubstVal EnvReaderM i o ([SAtom o], [IExpr o]) go (Abs bs UnitE) xs = case bs of - Nest (b:>argTy) rest -> do - argTy' <- substM argTy - (argTree, xsRest) <- listToTree argTy' xs - arg <- repValAtom $ RepVal argTy' argTree - (args', xsLeft) <- extendSubst (b @> SubstVal arg) $ go (EmptyAbs rest) xsRest + Nest b rest -> do + argTy <- substM $ binderType b + (argTree, xsRest) <- listToTree argTy xs + arg <- repValAtom $ RepVal argTy argTree + (args', xsLeft) <- extendSubstBD b [SubstVal arg] $ go (EmptyAbs rest) xsRest return (arg:args', xsLeft) Empty -> return ([], xs) @@ -316,21 +315,37 @@ translateExpr expr = confuseGHC >>= \_ -> case expr of Just (con, arg) -> do Abs b body <- return $ alts !! con extendSubst (b @> SubstVal arg) $ translateBlock body - Nothing -> do - RepVal sumTy (Branch (tag:xss)) <- atomToRepVal e' - ts <- caseAltsBinderTys sumTy - tag' <- repValAtom $ RepVal TagRepTy tag - xss' <- zipWithM (\t x -> repValAtom $ RepVal t x) ts xss - go tag' xss' - where - go tag xss = do - tag' <- fromScalarAtom tag - emitSwitch tag' (zip xss alts) $ - \(xs, Abs b body) -> - extendSubst (b @> SubstVal (sink xs)) $ - void $ translateBlock body - return UnitVal + -- Nothing -> do + -- RepVal sumTy (Branch (tag:xss)) <- atomToRepVal e' + -- ts <- caseAltsBinderTys sumTy + -- tag' <- repValAtom $ RepVal TagRepTy tag + -- xss' <- zipWithM (\t x -> repValAtom $ RepVal t x) ts xss + -- go tag' xss' + -- where + -- go tag xss = do + -- tag' <- fromScalarAtom tag + -- emitSwitch tag' (zip xss alts) $ + -- \(xs, Abs b body) -> + -- extendSubst (b @> SubstVal (sink xs)) $ + -- void $ translateBlock body + -- return UnitVal TabCon _ _ _ -> error "Unexpected `TabCon` in Imp pass." + ProjectElt _ p val -> undefined + -- ProjectElt _ p val -> do + -- (ps, v) <- return $ asNaryProj p val + -- lookupAtomName (atomVarName v) >>= \case + -- TopDataBound (RepVal _ tree) -> applyProjection (toList ps) tree + -- _ -> error "should only be projecting a data atom" + -- where + -- applyProjection :: [Projection] -> Tree (IExpr n) -> SubstImpM i n (Tree (IExpr n)) + -- applyProjection [] t = return t + -- applyProjection (i:is) t = do + -- t' <- applyProjection is t + -- case i of + -- UnwrapNewtype -> error "impossible" + -- ProjectProduct idx -> case t' of + -- Branch ts -> return $ ts !! idx + -- _ -> error "should only be projecting a branch" toImpRefOp :: Emits o => SAtom i -> RefOp SimpIR i -> SubstImpM i o (SAtom o) @@ -358,13 +373,13 @@ toImpRefOp refDest' m = do => (Dest o) -> SType o -> LamExpr SimpIR o -> SAtom o -> SAtom o -> SubstImpM n o () liftMonoidCombine accDest accTy bc x y = do - LamExpr (Nest (_:>baseTy) _) _ <- return bc + LamExpr (Nest b _) _ <- return bc + let baseTy = binderType b alphaEq accTy baseTy >>= \case -- Immediately beta-reduce, beacuse Imp doesn't reduce non-table applications. True -> do - BinaryLamExpr xb yb body <- return bc - body' <- applySubst (xb @> SubstVal x <.> yb @> SubstVal y) body - ans <- liftBuilderImp $ emitBlock (sink body') + body <- instantiateImp bc [x, y] + ans <- liftBuilderImp $ emitBlock $ sink body storeAtom accDest ans False -> case accTy of TabPi t -> do @@ -374,7 +389,7 @@ toImpRefOp refDest' m = do idx <- unsafeFromOrdinalImp (sink ixTy) i xElt <- liftBuilderImp $ tabApp (sink x) (sink idx) yElt <- liftBuilderImp $ tabApp (sink y) (sink idx) - eltTy <- instantiate (sink t) [idx] + eltTy <- instantiateImp t [idx] ithDest <- indexDest (sink accDest) idx liftMonoidCombine ithDest eltTy (sink bc) xElt yElt _ -> error $ "Base monoid type mismatch: can't lift " ++ @@ -536,14 +551,12 @@ toImpTypedHof (TypedHof (EffTy _ resultTy') hof) = do emitStatement $ IWhile body' return UnitVal RunReader r f -> do - BinaryLamExpr h ref body <- return f r' <- substM r rDest <- allocDest $ getType r' storeAtom rDest r' - extendSubst (h @> SubstVal (Con HeapVal) <.> ref @> SubstVal (destToAtom rDest)) $ + withInstantiated f [Con HeapVal, destToAtom rDest] \body -> translateBlock body RunWriter d (BaseMonoid e _) f -> do - BinaryLamExpr h ref body <- return f let PairTy ansTy accTy = resultTy (aDest, wDest) <- case d of Nothing -> destPairUnpack <$> allocDest resultTy @@ -554,11 +567,10 @@ toImpTypedHof (TypedHof (EffTy _ resultTy') hof) = do e' <- substM e PairE accTy' e'' <- sinkM $ PairE accTy e' liftMonoidEmpty wDest accTy' e'' - extendSubst (h @> SubstVal (Con HeapVal) <.> ref @> SubstVal (destToAtom wDest)) $ + withInstantiated f [Con HeapVal, destToAtom wDest] \body -> translateBlock body >>= storeAtom aDest PairVal <$> loadAtom aDest <*> loadAtom wDest RunState d s f -> do - BinaryLamExpr h ref body <- return f let PairTy ansTy _ = resultTy (aDest, sDest) <- case d of Nothing -> destPairUnpack <$> allocDest resultTy @@ -567,7 +579,7 @@ toImpTypedHof (TypedHof (EffTy _ resultTy') hof) = do sDest <- atomToDest =<< substM d' return (aDest, sDest) storeAtom sDest =<< substM s - extendSubst (h @> SubstVal (Con HeapVal) <.> ref @> SubstVal (destToAtom sDest)) $ + withInstantiated f [Con HeapVal, destToAtom sDest] \body -> do translateBlock body >>= storeAtom aDest PairVal <$> loadAtom aDest <*> loadAtom sDest RunIO body -> translateBlock body @@ -585,7 +597,7 @@ toImpTypedHof (TypedHof (EffTy _ resultTy') hof) = do emitLoop noHint Fwd n \i -> do idx <- unsafeFromOrdinalImp (sink ixTy) i x' <- sinkM x - eltTy <- instantiate (sink t) [idx] + eltTy <- instantiateImp t [idx] ithDest <- indexDest (sink accDest) idx liftMonoidEmpty ithDest eltTy x' _ -> error $ "Base monoid type mismatch: can't lift " ++ @@ -610,13 +622,13 @@ type IndexStructure r = EmptyAbs (IdxNest r) :: E pattern Singleton :: IndexStructure r n pattern Singleton = EmptyAbs Empty -type IxBinder r = PairB (LiftB (IxDict r)) (Binder r) +type IxBinder r = PairB (LiftB (IxDict r)) (BinderAndDecls r) type IdxNest r = Nest (IxBinder r) data TypeCtxLayer (r::IR) (n::S) (l::S) where - TabCtx :: IxBinder r n l -> TypeCtxLayer r n l - DepPairCtx :: MaybeB (Binder r) n l -> TypeCtxLayer r n l - RefCtx :: TypeCtxLayer r n n + TabCtx :: IxBinder r n l -> TypeCtxLayer r n l + DepPairCtx :: MaybeB (BinderAndDecls r) n l -> TypeCtxLayer r n l + RefCtx :: TypeCtxLayer r n n instance SinkableE Dest where sinkingProofE = undefined @@ -663,7 +675,7 @@ allNothingBs Empty = Just UnitB allNothingBs (Nest (LeftB _) _) = Nothing allNothingBs (Nest (RightB UnitB) rest) = allNothingBs rest -splitLeadingDepPairs :: TypeCtx SimpIR n l -> PairB (Nest (MaybeB SBinder)) (TypeCtx SimpIR) n l +splitLeadingDepPairs :: TypeCtx SimpIR n l -> PairB (Nest (MaybeB SBinderAndDecls)) (TypeCtx SimpIR) n l splitLeadingDepPairs = \case Empty -> PairB Empty Empty Nest (DepPairCtx b) rest -> case splitLeadingDepPairs rest of @@ -699,9 +711,10 @@ typeToTree tyTop = return $ go REmpty tyTop BaseTy b -> Leaf $ LeafType (unRNest ctx) b TabTy d b bodyTy -> go (RNest ctx (TabCtx (PairB (LiftB d) b))) bodyTy RefTy _ t -> go (RNest ctx RefCtx) t - DepPairTy (DepPairType _ (b:>t1) (t2)) -> do + DepPairTy (DepPairType _ b (t2)) -> do + let t1 = binderType b let tree1 = rec t1 - let tree2 = go (RNest ctx (DepPairCtx (JustB (b:>t1)))) t2 + let tree2 = go (RNest ctx (DepPairCtx (JustB b))) t2 Branch [tree1, tree2] ProdTy ts -> Branch $ map rec ts SumTy ts -> do @@ -726,41 +739,44 @@ storeRepVal (Dest _ destTree) repVal@(RepVal _ valTree) = do -- Like `typeToTree`, but when we additionally have the value, we can populate -- the existentially-hidden fields. valueToTree :: EnvReader m => SRepVal n -> m n (Tree (LeafType n)) -valueToTree (RepVal tyTop valTop) = do - go REmpty tyTop valTop - where - go :: EnvReader m => RNest (TypeCtxLayer SimpIR) n l -> SType l -> Tree (IExpr n) - -> m n (Tree (LeafType n)) - go ctx ty val = case ty of - BaseTy b -> return $ Leaf $ LeafType (unRNest ctx) b - TabTy d b bodyTy -> go (RNest ctx (TabCtx (PairB (LiftB d) b))) bodyTy val - RefTy _ t -> go (RNest ctx RefCtx) t val - DepPairTy (DepPairType _ (b:>t1) (t2)) -> case val of - Branch [v1, v2] -> do - case allDepPairCtxs (unRNest ctx) of - Just UnitB -> do - tree1 <- rec t1 v1 - x <- repValAtom $ RepVal t1 v1 - t2' <- applySubst (b@>SubstVal x) t2 - tree2 <- go (RNest ctx (DepPairCtx NothingB )) t2' v2 - return $ Branch [tree1, tree2] - Nothing -> do - tree1 <- rec t1 v1 - tree2 <- go (RNest ctx (DepPairCtx (JustB (b:>t1)))) t2 v2 - return $ Branch [tree1, tree2] - _ -> error "expected a branch" - ProdTy ts -> case val of - Branch vals -> Branch <$> zipWithM rec ts vals - _ -> error "expected a branch" - SumTy ts -> case val of - Branch (tagVal:vals) -> do - tag <- rec TagRepTy tagVal - results <- zipWithM rec ts vals - return $ Branch $ tag : results - _ -> error "expected a branch" - _ -> error $ "not implemented " ++ pprint ty - where rec = go ctx -{-# INLINE valueToTree #-} +valueToTree (RepVal tyTop valTop) = undefined +-- valueToTree (RepVal tyTop valTop) = do +-- go REmpty tyTop valTop +-- where +-- go :: EnvReader m => RNest (TypeCtxLayer SimpIR) n l -> SType l -> Tree (IExpr n) +-- -> m n (Tree (LeafType n)) +-- go ctx ty val = case ty of +-- BaseTy b -> return $ Leaf $ LeafType (unRNest ctx) b +-- TabTy d b bodyTy -> go (RNest ctx (TabCtx (PairB (LiftB d) b))) bodyTy val +-- RefTy _ t -> go (RNest ctx RefCtx) t val +-- DepPairTy dpTy@(DepPairType _ b t2) -> case val of +-- Branch [v1, v2] -> do +-- case allDepPairCtxs (unRNest ctx) of +-- Just UnitB -> do +-- let t1 = depPairLeftTy dpTy +-- tree1 <- rec t1 v1 +-- x <- repValAtom $ RepVal t1 v1 +-- t2' <- instantiate dpTy [x] +-- tree2 <- go (RNest ctx (DepPairCtx NothingB )) t2' v2 +-- return $ Branch [tree1, tree2] +-- Nothing -> do +-- let t1 = depPairLeftTy dpTy +-- tree1 <- rec t1 v1 +-- tree2 <- go (RNest ctx (DepPairCtx (JustB b))) t2 v2 +-- return $ Branch [tree1, tree2] +-- _ -> error "expected a branch" +-- ProdTy ts -> case val of +-- Branch vals -> Branch <$> zipWithM rec ts vals +-- _ -> error "expected a branch" +-- SumTy ts -> case val of +-- Branch (tagVal:vals) -> do +-- tag <- rec TagRepTy tagVal +-- results <- zipWithM rec ts vals +-- return $ Branch $ tag : results +-- _ -> error "expected a branch" +-- _ -> error $ "not implemented " ++ pprint ty +-- where rec = go ctx +-- {-# INLINE valueToTree #-} allDepPairCtxs :: TypeCtx SimpIR n l -> Maybe (UnitB n l) allDepPairCtxs ctx = case splitLeadingDepPairs ctx of @@ -877,21 +893,6 @@ atomToRepVal x = RepVal (getType x) <$> go x where TopDataBound (RepVal _ tree) -> return tree _ -> error "should only have pointer and data atom names left" PtrVar ty p -> return $ Leaf $ IPtrVar p ty - ProjectElt _ p val -> do - (ps, v) <- return $ asNaryProj p val - lookupAtomName (atomVarName v) >>= \case - TopDataBound (RepVal _ tree) -> applyProjection (toList ps) tree - _ -> error "should only be projecting a data atom" - where - applyProjection :: [Projection] -> Tree (IExpr n) -> SubstImpM i n (Tree (IExpr n)) - applyProjection [] t = return t - applyProjection (i:is) t = do - t' <- applyProjection is t - case i of - UnwrapNewtype -> error "impossible" - ProjectProduct idx -> case t' of - Branch ts -> return $ ts !! idx - _ -> error "should only be projecting a branch" -- XXX: We used to have a function called `destToAtom` which loaded the value -- from the dest. This version is not that. It just lifts a dest into an atom of @@ -1004,7 +1005,7 @@ buildGarbageVal ty = indexDest :: Emits n => Dest n -> SAtom n -> SubstImpM i n (Dest n) indexDest (Dest (TabPi tabTy) tree) i = do - eltTy <- instantiate tabTy [i] + eltTy <- instantiateImp tabTy [i] ord <- ordinalImp (tabIxType tabTy) i leafTys <- typeToTree $ TabPi tabTy Dest eltTy <$> forM (zipTrees leafTys tree) \(leafTy, ptr) -> do @@ -1028,7 +1029,7 @@ indexRepValParam :: Emits n -> (IExpr n -> SubstImpM i n (IExpr n)) -> SubstImpM i n (SRepVal n) indexRepValParam (RepVal (TabPi tabTy) vals) i tyFunc func = do - eltTy <- instantiate tabTy [i] + eltTy <- instantiateImp tabTy [i] ord <- ordinalImp (tabIxType tabTy) i leafTys <- typeToTree (TabPi tabTy) vals' <- forM (zipTrees leafTys vals) \(leafTy, ptr) -> do @@ -1110,8 +1111,8 @@ computeElemCount idxNest' = do elemCountPoly :: Emits n => IndexStructure SimpIR n -> SBuilderM n (Atom SimpIR n) elemCountPoly (Abs bs UnitE) = case bs of Empty -> return $ IdxRepVal 1 - Nest b@(PairB (LiftB d) (_:>t)) rest -> do - curSize <- indexSetSize $ IxType t d + Nest b@(PairB (LiftB d) b') rest -> do + curSize <- indexSetSize $ IxType (binderType b') d restSizes <- computeSizeGivenOrdinal b $ EmptyAbs rest sumUsingPolysImp curSize restSizes @@ -1119,12 +1120,13 @@ computeSizeGivenOrdinal :: EnvReader m => IxBinder SimpIR n l -> IndexStructure SimpIR l -> m n (Abs (Binder SimpIR) (Block SimpIR) n) -computeSizeGivenOrdinal (PairB (LiftB d) (b:>t)) idxStruct = liftBuilder do - withFreshBinder noHint IdxRepTy \bOrdinal -> - Abs bOrdinal <$> buildBlock do - i <- unsafeFromOrdinal (sink $ IxType t d) $ Var $ sink $ binderVar bOrdinal - idxStruct' <- applySubst (b@>SubstVal i) idxStruct - elemCountPoly $ sink idxStruct' +computeSizeGivenOrdinal _ _ = undefined +-- computeSizeGivenOrdinal (PairB (LiftB d) (BD (b:>t))) idxStruct = liftBuilder do +-- withFreshBinder noHint IdxRepTy \bOrdinal -> +-- Abs bOrdinal <$> buildBlock do +-- i <- unsafeFromOrdinal (sink $ IxType t d) $ Var $ sink $ binderVar bOrdinal +-- idxStruct' <- applySubst (b@>SubstVal i) idxStruct +-- elemCountPoly $ sink idxStruct' -- Split the index structure into a prefix of non-dependent index types -- and a trailing nest of indices that can contain inter-dependencies. @@ -1209,11 +1211,17 @@ withFreshIBinder hint ty cont = do cont $ IBinder b ty {-# INLINE withFreshIBinder #-} +instantiateImp + :: (Emits n, IRRep r, SubstE (SubstVal Atom) body, SinkableE body, SinkableE e, + ToBindersAbs e body r, Ext h n) + => e h -> [Atom r n] -> SubstImpM i n (body n) +instantiateImp = undefined + emitCall :: Emits n => PiType SimpIR n -> ImpFunName n -> [SAtom n] -> SubstImpM i n (SAtom n) -emitCall (PiType bs (EffTy _ resultTy)) f xs = do - resultTy' <- applySubst (bs @@> map SubstVal xs) resultTy +emitCall piTy f xs = do + EffTy _ resultTy' <- instantiateImp piTy xs dest <- allocDest resultTy' argsImp <- forM xs \x -> repValToList <$> atomToRepVal x destImp <- repValToList <$> atomToRepVal (destToAtom dest) @@ -1426,8 +1434,8 @@ indexSetSizeImp (IxType _ dict) = do appSpecializedIxMethod :: Emits n => SpecDictName n -> IxMethod -> [SAtom n] -> SubstImpM i n (SAtom n) appSpecializedIxMethod d method args = do SpecializedDict _ (Just fs) <- lookupSpecDict d - TopLam _ _ (LamExpr bs body) <- return $ fs !! fromEnum method - dropSubst $ extendSubst (bs @@> map SubstVal args) $ translateBlock body + TopLam _ _ lam <- return $ fs !! fromEnum method + dropSubst $ withInstantiated lam args \body -> translateBlock body -- === Abstracting link-time objects === diff --git a/src/lib/Inference.hs b/src/lib/Inference.hs index cd28d7c5e..4999bee13 100644 --- a/src/lib/Inference.hs +++ b/src/lib/Inference.hs @@ -34,7 +34,6 @@ import qualified Unsafe.Coerce as TrulyUnsafe import GHC.Generics (Generic (..)) import Builder -import CheapReduction import CheckType import Core import Err @@ -50,6 +49,7 @@ import Types.Primitives import Types.Source import Util hiding (group) import PPrint (prettyBlock) +import Visitor -- === Top-level interface === @@ -182,22 +182,32 @@ class ( MonadFail1 m, Fallible1 m, Catchable1 m, CtxReader1 m, Builder CoreIR m -> (forall l. (EmitsInf l, DExt n l) => CAtomVar l -> m l (e l)) -> m n (Abs CBinder e n) +buildAbsInfWithDecls + :: (InfBuilder m, SinkableE e, HoistableE e, RenameE e, SubstE AtomSubstVal e) + => EmitsInf n + => NameHint -> Explicitness -> CType n + -> (forall l. (EmitsInf l, DExt n l) => CAtomVar l -> m l (e l)) + -> m n (Abs CBinderAndDecls e n) +buildAbsInfWithDecls hint expl ty cont = do + Abs b e <- buildAbsInf hint expl ty cont + return $ Abs (PlainBD b) e + buildAbsInfWithExpl :: (InfBuilder m, SinkableE e, HoistableE e, RenameE e, SubstE AtomSubstVal e) => EmitsInf n => NameHint -> Explicitness -> CType n -> (forall l. (EmitsInf l, DExt n l) => CAtomVar l -> m l (e l)) - -> m n (Abs (WithExpl CBinder) e n) + -> m n (Abs (WithExpl CBinderAndDecls) e n) buildAbsInfWithExpl hint expl ty cont = do Abs b e <- buildAbsInf hint expl ty cont - return $ Abs (WithAttrB expl b) e + return $ Abs (WithAttrB expl (PlainBD b)) e buildNaryAbsInfWithExpl :: (Inferer m, SinkableE e, HoistableE e, RenameE e, SubstE AtomSubstVal e, Inferer m) => EmitsInf n - => [Explicitness] -> EmptyAbs (Nest CBinder) n + => [Explicitness] -> EmptyAbs CBinders n -> (forall l. (EmitsInf l, DExt n l) => [CAtomVar l] -> m i l (e l)) - -> m i n (Abs (Nest (WithExpl CBinder)) e n) + -> m i n (Abs (Nest (WithExpl CBinderAndDecls)) e n) buildNaryAbsInfWithExpl expls bs cont = do Abs bs' e <- buildNaryAbsInf expls bs cont return $ Abs (zipAttrs expls bs') e @@ -205,13 +215,13 @@ buildNaryAbsInfWithExpl expls bs cont = do buildNaryAbsInf :: (SinkableE e, HoistableE e, RenameE e, SubstE AtomSubstVal e, Inferer m) => EmitsInf n - => [Explicitness] -> EmptyAbs (Nest CBinder) n + => [Explicitness] -> EmptyAbs CBinders n -> (forall l. (EmitsInf l, DExt n l) => [CAtomVar l] -> m i l (e l)) - -> m i n (Abs (Nest CBinder) e n) + -> m i n (Abs CBinders e n) buildNaryAbsInf [] (Abs Empty UnitE) cont = getDistinct >>= \Distinct -> Abs Empty <$> cont [] -buildNaryAbsInf (expl:expls) (Abs (Nest (b:>ty) bs) UnitE) cont = - prependAbs <$> buildAbsInf (getNameHint b) expl ty \v -> do - bs' <- applyRename (b@>atomVarName v) (Abs bs UnitE) +buildNaryAbsInf (expl:expls) (Abs (Nest b bs) UnitE) cont = + prependAbs <$> buildAbsInfWithDecls (getNameHint b) expl (binderType b) \v -> do + bs' <- instantiateNames (Abs b $ Abs bs UnitE) [atomVarName v] buildNaryAbsInf expls bs' \vs -> cont (sink v:vs) buildNaryAbsInf _ _ _ = error "zip error" @@ -857,10 +867,11 @@ extendSynthCandidates (Inferred _ (Synth _)) v (Env topEnv (ModuleEnv a b scs)) extendSynthCandidates _ _ env = env {-# INLINE extendSynthCandidates #-} -extendSynthCandidatess :: Distinct n => [Explicitness] -> Nest CBinder n' n -> Env n -> Env n -extendSynthCandidatess (expl:expls) (Nest b bs) env = - extendSynthCandidatess expls bs env' - where env' = extendSynthCandidates expl (withExtEvidence bs $ sink $ binderName b) env +extendSynthCandidatess :: Distinct n => [Explicitness] -> CBinders n' n -> Env n -> Env n +extendSynthCandidatess (expl:expls) _ _ = undefined +-- extendSynthCandidatess (expl:expls) (Nest (BD b) bs) env = +-- extendSynthCandidatess expls bs env' +-- where env' = extendSynthCandidates expl (withExtEvidence bs $ sink $ binderName b) env extendSynthCandidatess [] Empty env = env extendSynthCandidatess _ _ _ = error "zip error" {-# INLINE extendSynthCandidatess #-} @@ -887,9 +898,9 @@ checkSigma hint expr sTy = confuseGHC >>= \_ -> case sTy of expr' <- inferWithoutInstantiation expr >>= zonk dropSubst $ checkOrInferApp expr' explicits [] (Check resultTy) DepPairTy depPairTy -> case depPairTy of - DepPairType ImplicitDepPair (_ :> lhsTy) _ -> do + DepPairType ImplicitDepPair b _ -> do -- TODO: check for the case that we're given some of the implicit dependent pair args explicitly - lhsVal <- Var <$> freshInferenceName MiscInfVar lhsTy + lhsVal <- Var <$> freshInferenceName MiscInfVar (binderType b) -- TODO: make an InfVarDesc case for dep pair instantiation rhsTy <- instantiate depPairTy [lhsVal] rhsVal <- checkSigma noHint expr rhsTy @@ -914,11 +925,12 @@ inferRho hint expr = checkOrInferRho hint expr Infer {-# INLINE inferRho #-} getImplicitArg :: EmitsInf o => InferenceArgDesc -> InferenceMechanism -> CType o -> InfererM i o (CAtom o) -getImplicitArg desc inf argTy = case inf of - Unify -> Var <$> freshInferenceName (ImplicitArgInfVar desc) argTy - Synth reqMethodAccess -> do - ctx <- srcPosCtx <$> getErrCtx - return $ DictHole (AlwaysEqual ctx) argTy reqMethodAccess +getImplicitArg desc inf argTy = undefined +-- getImplicitArg desc inf argTy = case inf of +-- Unify -> Var <$> freshInferenceName (ImplicitArgInfVar desc) argTy +-- Synth reqMethodAccess -> do +-- ctx <- srcPosCtx <$> getErrCtx +-- return $ DictHole (AlwaysEqual ctx) argTy reqMethodAccess withBlockDecls :: EmitsBoth o @@ -998,8 +1010,8 @@ checkOrInferRho hint uExprWithSrc@(WithSrcE pos expr) reqTy = do withReducibleEmissions msg $ checkUType rhs UDepPair lhs rhs -> do case reqTy of - Check (DepPairTy ty@(DepPairType _ (_ :> lhsTy) _)) -> do - lhs' <- checkSigmaDependent noHint lhs lhsTy + Check (DepPairTy ty) -> do + lhs' <- checkSigmaDependent noHint lhs (depPairLeftTy ty) rhsTy <- instantiate ty [lhs'] rhs' <- checkSigma noHint rhs rhsTy return $ DepPair lhs' rhs' ty @@ -1074,15 +1086,16 @@ checkOrInferRho hint uExprWithSrc@(WithSrcE pos expr) reqTy = do {-# INLINE inferAndInstantiate #-} applyFromLiteralMethod :: EmitsBoth n => SourceName -> CAtom n -> DefaultType -> CAtom n -> InfererM i n (CAtom n) -applyFromLiteralMethod methodName defaultVal defaultTy litVal = do - lookupSourceMap methodName >>= \case - Nothing -> return defaultVal - Just ~(UMethodVar methodName') -> do - MethodBinding className _ <- lookupEnv methodName' - resultTyVar <- freshInferenceName MiscInfVar TyKind - dictTy <- DictTy <$> dictType className [Var resultTyVar] - addDefault (atomVarName resultTyVar) defaultTy - emitExpr =<< mkApplyMethod (DictHole (AlwaysEqual emptySrcPosCtx) dictTy Full) 0 [litVal] +applyFromLiteralMethod methodName defaultVal defaultTy litVal = undefined +-- applyFromLiteralMethod methodName defaultVal defaultTy litVal = do +-- lookupSourceMap methodName >>= \case +-- Nothing -> return defaultVal +-- Just ~(UMethodVar methodName') -> do +-- MethodBinding className _ <- lookupEnv methodName' +-- resultTyVar <- freshInferenceName MiscInfVar TyKind +-- dictTy <- DictTy <$> dictType className [Var resultTyVar] +-- addDefault (atomVarName resultTyVar) defaultTy +-- emitExpr =<< mkApplyMethod (DictHole (AlwaysEqual emptySrcPosCtx) dictTy Full) 0 [litVal] -- atom that requires instantiation to become a rho type data SigmaAtom n = @@ -1158,30 +1171,31 @@ data FieldDef (n::S) = deriving (Show, Generic) getFieldDefs :: CType n -> InfererM i n (M.Map FieldName' (FieldDef n)) -getFieldDefs ty = case ty of - NewtypeTyCon (UserADTType _ tyName params) -> do - TyConBinding ~(Just tyDef) (DotMethods dotMethods) <- lookupEnv tyName - instantiateTyConDef tyDef params >>= \case - StructFields fields -> do - let projFields = enumerate fields <&> \(i, (field, _)) -> - [(FieldName field, FieldProj i), (FieldNum i, FieldProj i)] - let methodFields = M.toList dotMethods <&> \(field, f) -> - (FieldName field, FieldDotMethod f params) - return $ M.fromList $ concat projFields ++ methodFields - ADTCons _ -> noFields "" - RefTy _ valTy -> case valTy of - RefTy _ _ -> noFields "" - _ -> do - valFields <- getFieldDefs valTy - return $ M.filter isProj valFields - where isProj = \case - FieldProj _ -> True - _ -> False - ProdTy ts -> return $ M.fromList $ enumerate ts <&> \(i, _) -> (FieldNum i, FieldProj i) - TabPi _ -> noFields "\nArray indexing uses [] now." - _ -> noFields "" - where - noFields s = throw TypeErr $ "Can't get fields for type " ++ pprint ty ++ s +getFieldDefs ty = undefined +-- getFieldDefs ty = case ty of +-- NewtypeTyCon (UserADTType _ tyName params) -> do +-- TyConBinding ~(Just tyDef) (DotMethods dotMethods) <- lookupEnv tyName +-- instantiateTyConDef tyDef params >>= \case +-- StructFields fields -> do +-- let projFields = enumerate fields <&> \(i, (field, _)) -> +-- [(FieldName field, FieldProj i), (FieldNum i, FieldProj i)] +-- let methodFields = M.toList dotMethods <&> \(field, f) -> +-- (FieldName field, FieldDotMethod f params) +-- return $ M.fromList $ concat projFields ++ methodFields +-- ADTCons _ -> noFields "" +-- RefTy _ valTy -> case valTy of +-- RefTy _ _ -> noFields "" +-- _ -> do +-- valFields <- getFieldDefs valTy +-- return $ M.filter isProj valFields +-- where isProj = \case +-- FieldProj _ -> True +-- _ -> False +-- ProdTy ts -> return $ M.fromList $ enumerate ts <&> \(i, _) -> (FieldNum i, FieldProj i) +-- TabPi _ -> noFields "\nArray indexing uses [] now." +-- _ -> noFields "" +-- where +-- noFields s = throw TypeErr $ "Can't get fields for type " ++ pprint ty ++ s instantiateSigma :: forall i o. EmitsBoth o => SigmaAtom o -> InfererM i o (CAtom o) instantiateSigma sigmaAtom = case getType sigmaAtom of @@ -1226,55 +1240,57 @@ etaExpandExplicits :: EmitsInf o => SourceName -> CorePiType o -> (forall o'. (EmitsBoth o', DExt o o') => [CAtom o'] -> InfererM i o' (CAtom o')) -> InfererM i o (CoreLamExpr o) -etaExpandExplicits fSourceName (CorePiType _ explsTop bsTop (EffTy effs _)) contTop = do - Abs bs body <- go explsTop bsTop \xs -> do - effs' <- applySubst (bsTop@@>(SubstVal<$>xs)) effs - withAllowedEffects effs' do - body <- buildBlockInf $ contTop $ sinkList xs - return $ PairE effs' body - let (expls, bs') = unzipAttrs bs - coreLamExpr ExplicitApp expls $ Abs bs' body - where - go :: (EmitsInf o, SinkableE e, RenameE e, SubstE AtomSubstVal e, HoistableE e ) - => [Explicitness] -> Nest CBinder o any - -> (forall o'. (EmitsInf o', DExt o o') => [CAtom o'] -> InfererM i o' (e o')) - -> InfererM i o (Abs (Nest (WithExpl CBinder)) e o) - go [] Empty cont = getDistinct >>= \Distinct -> Abs Empty <$> cont [] - go (expl:expls) (Nest (b:>ty) rest) cont = case expl of - Explicit -> do - prependAbs <$> buildAbsInfWithExpl (getNameHint b) expl ty \v -> do - Abs rest' UnitE <- applyRename (b@>atomVarName v) $ Abs rest UnitE - go expls rest' \args -> cont (sink (Var v) : args) - Inferred argSourceName infMech -> do - arg <- getImplicitArg (fSourceName, fromMaybe "_" argSourceName) infMech ty - Abs rest' UnitE <- applySubst (b@>SubstVal arg) $ Abs rest UnitE - go expls rest' \args -> cont (sink arg : args) - go _ _ _ = error "zip error" +etaExpandExplicits fSourceName piTy@(CorePiType _ explsTop bsTop _) contTop = undefined +-- etaExpandExplicits fSourceName piTy@(CorePiType _ explsTop bsTop _) contTop = do +-- Abs bs body <- go explsTop bsTop \xs -> do +-- EffTy effs _ <- instantiate piTy xs +-- withAllowedEffects effs do +-- body <- buildBlockInf $ contTop $ sinkList xs +-- return $ PairE effs body +-- let (expls, bs') = unzipAttrs bs +-- coreLamExpr ExplicitApp expls $ Abs bs' body +-- where +-- go :: (EmitsInf o, SinkableE e, RenameE e, SubstE AtomSubstVal e, HoistableE e ) +-- => [Explicitness] -> CBinders o any +-- -> (forall o'. (EmitsInf o', DExt o o') => [CAtom o'] -> InfererM i o' (e o')) +-- -> InfererM i o (Abs (Nest (WithExpl CBinderAndDecls)) e o) +-- go [] Empty cont = getDistinct >>= \Distinct -> Abs Empty <$> cont [] +-- go (expl:expls) (Nest b rest) cont = case expl of +-- Explicit -> do +-- prependAbs <$> buildAbsInfWithExpl (getNameHint b) expl (binderType b) \v -> do +-- Abs rest' UnitE <- instantiateNames (Abs b $ Abs rest UnitE) [atomVarName v] +-- go expls rest' \args -> cont (sink (Var v) : args) +-- Inferred argSourceName infMech -> do +-- arg <- getImplicitArg (fSourceName, fromMaybe "_" argSourceName) infMech (binderType b) +-- Abs rest' UnitE <- instantiate (Abs b $ Abs rest UnitE) [arg] +-- go expls rest' \args -> cont (sink arg : args) +-- go _ _ _ = error "zip error" buildLamInf :: EmitsInf o => CorePiType o -> (forall o' . (EmitsBoth o', DExt o o') => [(Explicitness, CAtom o')] -> CType o' -> InfererM i o' (CAtom o')) -> InfererM i o (CoreLamExpr o) -buildLamInf (CorePiType appExpl explsTop bsTop effTy) contTop = do - ab <- go explsTop bsTop \xs -> do - let (expls, xs') = unzip xs - EffTy effs' resultTy' <- applySubst (bsTop@@>(SubstVal<$>xs')) effTy - withAllowedEffects effs' do - body <- buildBlockInf $ contTop (zip expls $ sinkList xs') (sink resultTy') - return $ PairE effs' body - coreLamExpr appExpl explsTop ab - where - go :: (EmitsInf o, HoistableE e, SinkableE e, SubstE AtomSubstVal e, RenameE e) - => [Explicitness] -> Nest CBinder o any - -> (forall o'. (EmitsInf o', DExt o o') => [(Explicitness, CAtom o')] -> InfererM i o' (e o')) - -> InfererM i o (Abs (Nest CBinder) e o) - go [] Empty cont = getDistinct >>= \Distinct -> Abs Empty <$> cont [] - go (expl:expls) (Nest b rest) cont = do - prependAbs <$> buildAbsInf (getNameHint b) expl (binderType b) \v -> do - Abs rest' UnitE <- applyRename (b@>atomVarName v) $ Abs rest UnitE - go expls rest' \args -> cont $ (expl, sink $ Var v) : args - go _ _ _ = error "zip error" +buildLamInf piTy@(CorePiType appExpl explsTop bsTop _) contTop = undefined +-- buildLamInf piTy@(CorePiType appExpl explsTop bsTop _) contTop = do +-- ab <- go explsTop bsTop \xs -> do +-- let (expls, xs') = unzip xs +-- EffTy effs' resultTy' <- instantiate piTy xs' +-- withAllowedEffects effs' do +-- body <- buildBlockInf $ contTop (zip expls $ sinkList xs') (sink resultTy') +-- return $ PairE effs' body +-- coreLamExpr appExpl explsTop ab +-- where +-- go :: (EmitsInf o, HoistableE e, SinkableE e, SubstE AtomSubstVal e, RenameE e) +-- => [Explicitness] -> CBinders o any +-- -> (forall o'. (EmitsInf o', DExt o o') => [(Explicitness, CAtom o')] -> InfererM i o' (e o')) +-- -> InfererM i o (Abs CBinders e o) +-- go [] Empty cont = getDistinct >>= \Distinct -> Abs Empty <$> cont [] +-- go (expl:expls) (Nest b rest) cont = do +-- prependAbs <$> buildAbsInfWithDecls (getNameHint b) expl (binderType b) \v -> do +-- Abs rest' UnitE <- instantiateNames (Abs b $ Abs rest UnitE) [atomVarName v] +-- go expls rest' \args -> cont $ (expl, sink $ Var v) : args +-- go _ _ _ = error "zip error" class ExplicitArg (e::E) where checkExplicitArg :: EmitsBoth o => IsDependent -> e i -> CType o -> InfererM i o (CAtom o) @@ -1342,7 +1358,7 @@ checkOrInferApp f' posArgs namedArgs reqTy = do ty <- return $ getType x constrainTypesEq req ty -maybeInterpretPunsAsTyCons :: RequiredTy CType n -> SigmaAtom n -> InfererM i n (SigmaAtom n) +maybeInterpretPunsAsTyCons :: Emits n => RequiredTy CType n -> SigmaAtom n -> InfererM i n (SigmaAtom n) maybeInterpretPunsAsTyCons (Check TyKind) (SigmaUVar sn _ (UPunVar v)) = do let v' = UTyConVar v ty <- getUVarType v' @@ -1406,7 +1422,7 @@ applyDataCon tc conIx topArgs = do where conTys = conDefs <&> \(DataConDef _ _ rty _) -> rty return $ NewtypeCon (UserADTData sn tc params) repVal where - wrap :: EnvReader m => CType n -> [CAtom n] -> m n (CAtom n) + wrap :: Emits n => CType n -> [CAtom n] -> InfererM i n (CAtom n) wrap _ [arg] = return $ arg wrap rty args = case rty of ProdTy tys -> @@ -1416,9 +1432,9 @@ applyDataCon tc conIx topArgs = do where nargs = length args; ntys = length tys (curArgs, remArgs) = splitAt (ntys - 1) args - DepPairTy dpt@(DepPairType _ b rty') -> do - rty'' <- applySubst (b@>SubstVal h) rty' - ans <- wrap rty'' t + DepPairTy dpt -> do + rty' <- instantiate dpt [h] + ans <- wrap rty' t return $ DepPair h ans dpt where h:t = args _ -> error $ "Unexpected data con representation type: " ++ pprint rty @@ -1430,33 +1446,35 @@ emitExprWithEffects expr = do checkArity :: [Explicitness] -> [a] -> InfererM i o () checkArity expls args = do - let arity = length [() | Explicit <- expls] + let explArity = length [() | Explicit <- expls] let numArgs = length args - when (numArgs /= arity) do + when (numArgs /= explArity) do throw TypeErr $ "Wrong number of positional arguments provided. Expected " ++ - pprint arity ++ " but got " ++ pprint numArgs + pprint explArity ++ " but got " ++ pprint numArgs -- TODO: check that there are no extra named args provided inferMixedArgs :: forall arg i o e . (ExplicitArg arg, EmitsBoth o, SubstE (SubstVal Atom) e, SinkableE e, HoistableE e) => SourceName -> [Explicitness] - -> Abs (Nest CBinder) e o -> [arg i] -> [(SourceName, arg i)] + -> Abs CBinders e o -> [arg i] -> [(SourceName, arg i)] -> InfererM i o [CAtom o] inferMixedArgs fSourceName explsTop bsAbs posArgs namedArgs = do checkNamedArgValidity explsTop (map fst namedArgs) liftM fst $ runStreamReaderT1 posArgs $ go explsTop bsAbs where go :: (EmitsBoth o, SubstE (SubstVal Atom) e, SinkableE e, HoistableE e) - => [Explicitness] -> Abs (Nest CBinder) e o + => [Explicitness] -> Abs CBinders e o -> StreamReaderT1 (arg i) (InfererM i) o [CAtom o] go [] (Abs Empty _) = return [] go (expl:expls) (Abs (Nest b bs) result) = do let rest = Abs bs result - let isDependent = binderName b `isFreeIn` rest + isDependent <- return case tryAsConst (Abs b rest) of + Nothing -> True + Just _ -> False arg <- inferMixedArg isDependent (binderType b) expl arg' <- lift11 $ zonk arg - rest' <- applySubst (b @> SubstVal arg') rest + rest' <- lift11 $ instantiate (Abs b rest) [arg'] (arg:) <$> go expls rest' go _ _ = error "zip error" @@ -1491,14 +1509,15 @@ checkNamedArgValidity expls offeredNames = do ++ "\nShould be one of: " ++ pprint acceptedNames inferPrimArg :: EmitsBoth o => UExpr i -> InfererM i o (CAtom o) -inferPrimArg x = do - xBlock <- buildBlockInf $ inferRho noHint x - EffTy _ ty <- blockEffTy xBlock - case ty of - TyKind -> cheapReduce xBlock >>= \case - Just reduced -> return reduced - _ -> throw CompilerErr "Type args to primops must be reducible" - _ -> emitBlock xBlock +inferPrimArg x = undefined +-- inferPrimArg x = do +-- xBlock <- buildBlockInf $ inferRho noHint x +-- EffTy _ ty <- blockEffTy xBlock +-- case ty of +-- TyKind -> cheapReduce xBlock >>= \case +-- Just reduced -> return reduced +-- _ -> throw CompilerErr "Type args to primops must be reducible" +-- _ -> emitBlock xBlock matchPrimApp :: Emits o => PrimName -> [CAtom o] -> InfererM i o (CAtom o) matchPrimApp = \case @@ -1541,7 +1560,7 @@ matchPrimApp = \case lam1 :: Fallible m => CAtom n -> m (LamExpr CoreIR n) lam1 x = do ExplicitCoreLam (UnaryNest b) body <- return x - return $ UnaryLamExpr b body + return $ LamExpr (UnaryNest b) body lam0 :: Fallible m => CAtom n -> m (CBlock n) lam0 x = do @@ -1558,7 +1577,7 @@ matchPrimApp = \case _ -> return $ Right x return $ fromJust $ toOp $ GenericOpRep op tyArgs dataArgs [] -pattern ExplicitCoreLam :: Nest CBinder n l -> CBlock l -> CAtom n +pattern ExplicitCoreLam :: CBinders n l -> CBlock l -> CAtom n pattern ExplicitCoreLam bs body <- Lam (CoreLamExpr _ (LamExpr bs body)) -- === n-ary applications === @@ -1575,14 +1594,16 @@ inferNaryTabAppArgs => CType o -> [UExpr i] -> InfererM i o [CAtom o] inferNaryTabAppArgs _ [] = return [] inferNaryTabAppArgs tabTy (arg:rest) = do - TabPiType _ b resultTy <- fromTabPiType True tabTy + tabPi@(TabPiType _ b _) <- fromTabPiType True tabTy let ixTy = binderType b - let isDependent = binderName b `isFreeIn` resultTy + isDependent <- return case tryAsConst tabPi of + Nothing -> True + Just _ -> False arg' <- if isDependent - then checkSigmaDependent (getNameHint b) arg ixTy - else checkSigma (getNameHint b) arg ixTy + then checkSigmaDependent (getNameHint tabPi) arg ixTy + else checkSigma (getNameHint tabPi) arg ixTy arg'' <- zonk arg' - resultTy' <- applySubst (b @> SubstVal arg'') resultTy + resultTy' <- instantiate tabPi [arg''] rest' <- inferNaryTabAppArgs resultTy' rest return $ arg'':rest' @@ -1597,15 +1618,16 @@ checkSigmaDependent hint e@(WithSrcE ctx _) ty = addSrcContext ctx $ withReducibleEmissions :: ( EmitsInf o, SinkableE e, RenameE e, SubstE AtomSubstVal e - , HoistableE e, CheaplyReducibleE CoreIR e e) + , HoistableE e) => String -> (forall o' . (EmitsBoth o', DExt o o') => InfererM i o' (e o')) -> InfererM i o (e o) -withReducibleEmissions msg cont = do - Abs decls result <- buildDeclsInf cont - cheapReduceWithDecls decls result >>= \case - Just t -> return t - _ -> throw TypeErr msg +withReducibleEmissions msg cont = undefined +-- withReducibleEmissions msg cont = do +-- Abs decls result <- buildDeclsInf cont +-- cheapReduceWithDecls decls result >>= \case +-- Just t -> return t +-- _ -> throw TypeErr msg -- === sorting case alternatives === @@ -1662,13 +1684,13 @@ buildSortedCase scrut alts resultTy = do -- TODO: cache this with the instance def (requires a recursive binding) instanceFun :: EnvReader m => InstanceName n -> AppExplicitness -> m n (CAtom n) -instanceFun instanceName appExpl = do - InstanceDef _ expls bs _ _ <- lookupInstanceDef instanceName - ab <- liftEnvReaderM $ refreshAbs (Abs bs UnitE) \bs' UnitE -> do - args <- mapM toAtomVar $ nestToNames bs' - result <- mkDictAtom $ InstanceDict (sink instanceName) (Var <$> args) - return $ Abs bs' (PairE Pure (WithoutDecls result)) - Lam <$> coreLamExpr appExpl (snd<$>expls) ab +instanceFun instanceName appExpl = undefined +-- instanceFun instanceName appExpl = do +-- InstanceDef _ expls bs _ _ <- lookupInstanceDef instanceName +-- ab <- liftEnvReaderM $ refreshAbs (Abs bs UnitE) \bs' UnitE -> do +-- result <- mkDictAtom $ InstanceDict (sink instanceName) (Var <$> bindersVars bs') +-- return $ Abs bs' (PairE Pure (WithoutDecls result)) +-- Lam <$> coreLamExpr appExpl (snd<$>expls) ab checkMaybeAnnExpr :: EmitsBoth o => NameHint -> Maybe (UType i) -> UExpr i -> InfererM i o (CAtom o) @@ -1726,7 +1748,7 @@ inferDotMethod tc (Abs uparamBs (Abs selfB lam)) = do Abs paramBs'' (Abs selfB' lam') <- return ab return $ prependCoreLamExpr (paramBs'' >>> UnaryNest selfB') lam' -prependCoreLamExpr :: Nest (WithExpl CBinder) n l -> CoreLamExpr l -> CoreLamExpr n +prependCoreLamExpr :: Nest (WithExpl CBinderAndDecls) n l -> CoreLamExpr l -> CoreLamExpr n prependCoreLamExpr bs e = case e of CoreLamExpr (CorePiType appExpl piExpls piBs effTy) (LamExpr lamBs body) -> do let (expls, bs') = unzipAttrs bs @@ -1742,12 +1764,12 @@ inferDataCon (sourceName, UDataDefTrail argBs) = do let (repTy, projIdxs) = dataConRepTy argBs'' return $ DataConDef sourceName argBs'' repTy projIdxs -dataConRepTy :: EmptyAbs (Nest CBinder) n -> (CType n, [[Projection]]) +dataConRepTy :: EmptyAbs CBinders n -> (CType n, [[Projection]]) dataConRepTy (Abs topBs UnitE) = case topBs of Empty -> (UnitTy, []) _ -> go [] [UnwrapNewtype] topBs where - go :: [CType l] -> [Projection] -> Nest (Binder CoreIR) l p -> (CType l, [[Projection]]) + go :: [CType l] -> [Projection] -> CBinders l p -> (CType l, [[Projection]]) go revAcc projIdxs = \case Empty -> case revAcc of [] -> error "should never happen" @@ -1789,8 +1811,8 @@ inferClassDef className methodNames paramBs@(expls, paramBs') methods = do return $ ClassDef className methodNames paramNames roleExpls bs' scs mtys identifySuperclasses - :: RenameE e => Abs (Nest (WithRoleExpl CBinder)) e n - -> InfererM i n (Abs (PairB (Nest (WithRoleExpl CBinder)) (Nest CBinder)) e n) + :: RenameE e => Abs (Nest (WithRoleExpl CBinderAndDecls)) e n + -> InfererM i n (Abs (PairB (Nest (WithRoleExpl CBinderAndDecls)) CBinders) e n) identifySuperclasses ab = do refreshAbs ab \bs e -> do bs' <- partitionBinders bs \b@(WithAttrB (_, expl) b') -> case expl of @@ -1803,7 +1825,7 @@ withUBinders :: (EmitsInf o, HasNamesE e, SubstE AtomSubstVal e, SinkableE e) => UAnnExplBinders req i i' -> (forall o'. (EmitsInf o', DExt o o') => [CAtomVar o'] -> InfererM i' o' (e o')) - -> InfererM i o (Abs (Nest (WithExpl CBinder)) e o) + -> InfererM i o (Abs (Nest (WithExpl CBinderAndDecls)) e o) withUBinders bs cont = case bs of ([], Empty) -> getDistinct >>= \Distinct -> Abs Empty <$> cont [] (expl:expls, Nest (UAnnBinder b ann cs) rest) -> do @@ -1819,7 +1841,7 @@ withConstraintBinders => [UConstraint i] -> CAtomVar o -> (forall o'. (EmitsInf o', DExt o o') => InfererM i o' (e o')) - -> InfererM i o (Abs (Nest (WithExpl CBinder)) e o) + -> InfererM i o (Abs (Nest (WithExpl CBinderAndDecls)) e o) withConstraintBinders [] _ cont = getDistinct >>= \Distinct -> Abs Empty <$> cont withConstraintBinders (c:cs) v cont = do Type dictTy <- withReducibleEmissions "Can't reduce interface constraint" do @@ -1832,12 +1854,12 @@ withRoleUBinders :: forall i i' o e req. (EmitsInf o, HasNamesE e, SubstE AtomSubstVal e, SinkableE e) => UAnnExplBinders req i i' -> (forall o'. (EmitsInf o', DExt o o') => InfererM i' o' (e o')) - -> InfererM i o (Abs (Nest (WithRoleExpl CBinder)) e o) + -> InfererM i o (Abs (Nest (WithRoleExpl CBinderAndDecls)) e o) withRoleUBinders roleBs cont = case roleBs of ([], Empty) -> getDistinct >>= \Distinct -> Abs Empty <$> cont (expl:expls, Nest (UAnnBinder b ann cs) rest) -> do ann' <- checkAnn (getSourceName b) ann - Abs b' (Abs bs' e) <- buildAbsInf (getNameHint b) expl ann' \v -> do + Abs b' (Abs bs' e) <- buildAbsInfWithDecls (getNameHint b) expl ann' \v -> do Abs ds (Abs bs' e) <- withConstraintBinders cs v $ extendSubst (b@>sink (atomVarName v)) $ withRoleUBinders (expls, rest) cont let ds' = fmapNest (\(WithAttrB expl' b') -> WithAttrB (DictParam, expl') b') ds @@ -1847,48 +1869,49 @@ withRoleUBinders roleBs cont = case roleBs of _ -> error "zip error" inferULam :: EmitsInf o => ULamExpr i -> InfererM i o (CoreLamExpr o) -inferULam (ULamExpr bs appExpl effs resultTy body) = do - ab <- withUBinders bs \_ -> do - effs' <- fromMaybe Pure <$> mapM checkUEffRow effs - resultTy' <- mapM checkUType resultTy - body' <- buildBlockInf $ withAllowedEffects (sink effs') do - case resultTy' of - Nothing -> withBlockDecls body \result -> inferSigma noHint result - Just resultTy'' -> - withBlockDecls body \result -> - checkSigma noHint result (sink resultTy'') - return (PairE effs' body') - Abs bs' (PairE effs' body') <- return ab - let (expls, bs'') = unzipAttrs bs' - case appExpl of - ImplicitApp -> checkImplicitLamRestrictions bs'' effs' - ExplicitApp -> return () - coreLamExpr appExpl expls $ Abs bs'' $ PairE effs' body' - -checkImplicitLamRestrictions :: Nest CBinder o o' -> EffectRow CoreIR o' -> InfererM i o () +inferULam (ULamExpr bs appExpl effs resultTy body) = undefined +-- inferULam (ULamExpr bs appExpl effs resultTy body) = do +-- ab <- withUBinders bs \_ -> do +-- effs' <- fromMaybe Pure <$> mapM checkUEffRow effs +-- resultTy' <- mapM checkUType resultTy +-- body' <- buildBlockInf $ withAllowedEffects (sink effs') do +-- case resultTy' of +-- Nothing -> withBlockDecls body \result -> inferSigma noHint result +-- Just resultTy'' -> +-- withBlockDecls body \result -> +-- checkSigma noHint result (sink resultTy'') +-- return (PairE effs' body') +-- Abs bs' (PairE effs' body') <- return ab +-- let (expls, bs'') = unzipAttrs bs' +-- case appExpl of +-- ImplicitApp -> checkImplicitLamRestrictions bs'' effs' +-- ExplicitApp -> return () +-- coreLamExpr appExpl expls $ Abs bs'' $ PairE effs' body' + +checkImplicitLamRestrictions :: CBinders o o' -> EffectRow CoreIR o' -> InfererM i o () checkImplicitLamRestrictions _ _ = return () -- TODO checkUForExpr :: EmitsBoth o => UForExpr i -> TabPiType CoreIR o -> InfererM i o (LamExpr CoreIR o) -checkUForExpr (UForExpr (UAnnBinder bFor ann cs) body) tabPi@(TabPiType _ bPi _) = do - unless (null cs) $ throw TypeErr "`for` binders shouldn't have constraints" - let iTy = binderAnn bPi - case ann of - UNoAnn -> return () - UAnn forAnn -> checkUType forAnn >>= constrainTypesEq iTy - Abs b body' <- buildAbsInf (getNameHint bFor) Explicit iTy \i -> do - extendRenamer (bFor@>atomVarName i) do - TabPiType _ bPi' resultTy <- sinkM tabPi - resultTy' <- applyRename (bPi'@>atomVarName i) resultTy - buildBlockInf do - withBlockDecls body \result -> - checkSigma noHint result $ sink resultTy' - return $ LamExpr (UnaryNest b) body' +checkUForExpr (UForExpr (UAnnBinder bFor ann cs) body) tabPi@(TabPiType _ bPi _) = undefined +-- checkUForExpr (UForExpr (UAnnBinder bFor ann cs) body) tabPi@(TabPiType _ bPi _) = do +-- unless (null cs) $ throw TypeErr "`for` binders shouldn't have constraints" +-- let iTy = binderType bPi +-- case ann of +-- UNoAnn -> return () +-- UAnn forAnn -> checkUType forAnn >>= constrainTypesEq iTy +-- Abs b body' <- buildAbsInfWithDecls (getNameHint bFor) Explicit iTy \i -> do +-- extendRenamer (bFor@>atomVarName i) do +-- resultTy <- instantiate tabPi [Var i] +-- buildBlockInf do +-- withBlockDecls body \result -> +-- checkSigma noHint result $ sink resultTy +-- return $ LamExpr (UnaryNest b) body' inferUForExpr :: EmitsBoth o => UForExpr i -> InfererM i o (LamExpr CoreIR o) inferUForExpr (UForExpr (UAnnBinder bFor ann cs) body) = do unless (null cs) $ throw TypeErr "`for` binders shouldn't have constraints" iTy <- checkAnn (getSourceName bFor) ann - Abs b body' <- buildAbsInf (getNameHint bFor) Explicit iTy \i -> + Abs b body' <- buildAbsInfWithDecls (getNameHint bFor) Explicit iTy \i -> extendRenamer (bFor@>atomVarName i) $ buildBlockInf $ withBlockDecls body \result -> checkOrInferRho noHint result Infer @@ -1896,12 +1919,12 @@ inferUForExpr (UForExpr (UAnnBinder bFor ann cs) body) = do checkULam :: EmitsInf o => ULamExpr i -> CorePiType o -> InfererM i o (CoreLamExpr o) checkULam (ULamExpr (_, lamBs) lamAppExpl lamEffs lamResultTy body) - (CorePiType piAppExpl expls piBs effTy) = do + piTy@(CorePiType piAppExpl expls piBs _) = do checkArity expls (nestToList (const ()) lamBs) when (piAppExpl /= lamAppExpl) $ throw TypeErr $ "Wrong arrow. Expected " ++ pprint piAppExpl ++ " got " ++ pprint lamAppExpl Abs explBs body' <- checkLamBinders expls piBs lamBs \vs -> do - EffTy piEffs' piResultTy' <- applyRename (piBs@@>map atomVarName vs) effTy + EffTy piEffs' piResultTy' <- instantiateNames piTy (atomVarName <$> vs) case lamResultTy of Nothing -> return () Just t -> checkUType t >>= constrainTypesEq piResultTy' @@ -1919,16 +1942,17 @@ checkULam (ULamExpr (_, lamBs) lamAppExpl lamEffs lamResultTy body) checkLamBinders :: (EmitsInf o, SinkableE e, HoistableE e, SubstE AtomSubstVal e, RenameE e) - => [Explicitness] -> Nest CBinder o any + => [Explicitness] -> CBinders o any -> Nest UOptAnnBinder i i' -> (forall o'. (EmitsInf o', DExt o o') => [CAtomVar o'] -> InfererM i' o' (e o')) - -> InfererM i o (Abs (Nest (WithExpl CBinder)) e o) + -> InfererM i o (Abs (Nest (WithExpl CBinderAndDecls)) e o) checkLamBinders [] Empty Empty cont = getDistinct >>= \Distinct -> Abs Empty <$> cont [] -checkLamBinders (piExpl:piExpls) (Nest (piB:>piAnn) piBs) lamBs cont = do +checkLamBinders (piExpl:piExpls) (Nest piB piBs) lamBs cont = do + let piAnn = binderType piB prependAbs <$> case piExpl of Inferred _ _ -> buildAbsInfWithExpl (getNameHint piB) piExpl piAnn \v -> do - Abs piBs' UnitE <- applyRename (piB@>atomVarName v) $ Abs piBs UnitE + Abs piBs' UnitE <- instantiateNames (Abs piB $ Abs piBs UnitE) [atomVarName v] checkLamBinders piExpls piBs' lamBs \vs -> cont (sink v:vs) Explicit -> case lamBs of @@ -1938,43 +1962,45 @@ checkLamBinders (piExpl:piExpls) (Nest (piB:>piAnn) piBs) lamBs cont = do UNoAnn -> return () buildAbsInfWithExpl (getNameHint lamB) Explicit piAnn \v -> do concatAbs <$> withConstraintBinders cs v do - Abs piBs' UnitE <- applyRename (piB@>sink (atomVarName v)) $ Abs piBs UnitE + Abs piBs' UnitE <- instantiateNames (Abs piB $ Abs piBs UnitE) [sink $ atomVarName v] extendRenamer (lamB@>sink (atomVarName v)) $ checkLamBinders piExpls piBs' lamBsRest \vs -> cont (sink v:vs) Empty -> error "zip error" checkLamBinders _ _ _ _ = error "zip error" -checkInstanceParams :: EmitsInf o => [Explicitness] -> Nest CBinder o any -> [UExpr i] -> InfererM i o [CAtom o] -checkInstanceParams expls bsTop paramsTop = do - checkArity expls paramsTop - go bsTop paramsTop - where - go :: EmitsInf o => Nest CBinder o any -> [UExpr i] -> InfererM i o [CAtom o] - go Empty [] = return [] - go (Nest (b:>ty) bs) (x:xs) = do - x' <- checkUParam ty x - Abs bs' UnitE <- applySubst (b@>SubstVal x') $ Abs bs UnitE - (x':) <$> go bs' xs - go _ _ = error "zip error" +checkInstanceParams :: EmitsInf o => [Explicitness] -> CBinders o any -> [UExpr i] -> InfererM i o [CAtom o] +checkInstanceParams expls bsTop paramsTop = undefined +-- checkInstanceParams expls bsTop paramsTop = do +-- checkArity expls paramsTop +-- go bsTop paramsTop +-- where +-- go :: EmitsInf o => CBinders o any -> [UExpr i] -> InfererM i o [CAtom o] +-- go Empty [] = return [] +-- go (Nest b bs) (x:xs) = do +-- x' <- checkUParam (binderType b) x +-- Abs bs' UnitE <- instantiate (Abs b $ Abs bs UnitE) [x'] +-- (x':) <$> go bs' xs +-- go _ _ = error "zip error" checkInstanceBody :: EmitsInf o => ClassName o -> [CAtom o] -> [UMethodDef i] -> InfererM i o (InstanceBody o) -checkInstanceBody className params methods = do - ClassDef _ methodNames _ _ paramBs scBs methodTys <- lookupClassDef className - Abs scBs' methodTys' <- applySubst (paramBs @@> (SubstVal <$> params)) $ Abs scBs $ ListE methodTys - superclassTys <- superclassDictTys scBs' - superclassDicts <- mapM (flip trySynthTerm Full) superclassTys - ListE methodTys'' <- applySubst (scBs'@@>(SubstVal<$>superclassDicts)) methodTys' - methodsChecked <- mapM (checkMethodDef className methodTys'') methods - let (idxs, methods') = unzip $ sortOn fst $ methodsChecked - forM_ (repeated idxs) \i -> - throw TypeErr $ "Duplicate method: " ++ pprint (methodNames!!i) - forM_ ([0..(length methodTys'' - 1)] `listDiff` idxs) \i -> - throw TypeErr $ "Missing method: " ++ pprint (methodNames!!i) - return $ InstanceBody superclassDicts methods' - -superclassDictTys :: Nest CBinder o o' -> InfererM i o [CType o] +checkInstanceBody className params methods = undefined +-- checkInstanceBody className params methods = do +-- classDef@(ClassDef _ methodNames _ _ _ _ _) <- lookupClassDef className +-- superclassAbs@(Abs scBs' _) <- instantiate classDef params +-- superclassTys <- superclassDictTys scBs' +-- superclassDicts <- mapM (flip trySynthTerm Full) superclassTys +-- ListE methodTys'' <- instantiate superclassAbs superclassDicts +-- methodsChecked <- mapM (checkMethodDef className methodTys'') methods +-- let (idxs, methods') = unzip $ sortOn fst $ methodsChecked +-- forM_ (repeated idxs) \i -> +-- throw TypeErr $ "Duplicate method: " ++ pprint (methodNames!!i) +-- forM_ ([0..(length methodTys'' - 1)] `listDiff` idxs) \i -> +-- throw TypeErr $ "Missing method: " ++ pprint (methodNames!!i) +-- return $ InstanceBody superclassDicts methods' + +superclassDictTys :: CBinders o o' -> InfererM i o [CType o] superclassDictTys Empty = return [] superclassDictTys (Nest b bs) = do Abs bs' UnitE <- liftHoistExcept $ hoist b $ Abs bs UnitE @@ -2039,38 +2065,39 @@ checkCasePat :: EmitsBoth o -> CType o -> (forall o'. (EmitsBoth o', Ext o o') => InfererM i' o' (CAtom o')) -> InfererM i o (Alt CoreIR o) -checkCasePat (WithSrcB pos pat) scrutineeTy cont = addSrcContext pos $ case pat of - UPatCon ~(InternalName _ _ conName) ps -> do - (dataDefName, con) <- renameM conName >>= lookupDataCon - TyConDef sourceName roleExpls paramBs (ADTCons cons) <- lookupTyCon dataDefName - DataConDef _ _ repTy idxs <- return $ cons !! con - when (length idxs /= nestLength ps) $ throw TypeErr $ - "Unexpected number of pattern binders. Expected " ++ show (length idxs) - ++ " got " ++ show (nestLength ps) - (params, repTy') <- inferParams sourceName roleExpls (Abs paramBs repTy) - constrainTypesEq scrutineeTy $ TypeCon sourceName dataDefName params - buildAltInf repTy' \arg -> do - args <- forM idxs \projs -> do - ans <- normalizeNaryProj (init projs) (Var arg) - emit $ Atom ans - bindLetPats ps args $ cont - _ -> throw TypeErr $ "Case patterns must start with a data constructor or variant pattern" +checkCasePat (WithSrcB pos pat) scrutineeTy cont = undefined +-- checkCasePat (WithSrcB pos pat) scrutineeTy cont = addSrcContext pos $ case pat of +-- UPatCon ~(InternalName _ _ conName) ps -> do +-- (dataDefName, con) <- renameM conName >>= lookupDataCon +-- TyConDef sourceName roleExpls paramBs (ADTCons cons) <- lookupTyCon dataDefName +-- DataConDef _ _ repTy idxs <- return $ cons !! con +-- when (length idxs /= nestLength ps) $ throw TypeErr $ +-- "Unexpected number of pattern binders. Expected " ++ show (length idxs) +-- ++ " got " ++ show (nestLength ps) +-- (params, repTy') <- inferParams sourceName roleExpls (Abs paramBs repTy) +-- constrainTypesEq scrutineeTy $ TypeCon sourceName dataDefName params +-- buildAltInf repTy' \arg -> do +-- args <- forM idxs \projs -> do +-- ans <- normalizeNaryProj (init projs) (Var arg) +-- emit $ Atom ans +-- bindLetPats ps args $ cont +-- _ -> throw TypeErr $ "Case patterns must start with a data constructor or variant pattern" inferParams :: (EmitsBoth o, HasNamesE e, SinkableE e, SubstE AtomSubstVal e) - => SourceName -> [RoleExpl] -> Abs (Nest CBinder) e o -> InfererM i o (TyConParams o, e o) + => SourceName -> [RoleExpl] -> Abs CBinders e o -> InfererM i o (TyConParams o, e o) inferParams sourceName roleExpls (Abs paramBs bodyTop) = do let expls = snd <$> roleExpls (params, e') <- go expls (Abs paramBs bodyTop) return (TyConParams expls params, e') where go :: (EmitsBoth o, HasNamesE e, SinkableE e, SubstE AtomSubstVal e) - => [Explicitness] -> Abs (Nest CBinder) e o -> InfererM i o ([CAtom o], e o) + => [Explicitness] -> Abs CBinders e o -> InfererM i o ([CAtom o], e o) go [] (Abs Empty body) = return ([], body) - go (expl:expls) (Abs (Nest (b:>ty) bs) body) = do + go (expl:expls) (Abs (Nest b bs) body) = do x <- case expl of - Explicit -> Var <$> freshInferenceName (TypeInstantiationInfVar sourceName) ty - Inferred argName infMech -> getImplicitArg (sourceName, fromMaybe "_" argName) infMech ty - rest <- applySubst (b@>SubstVal x) $ Abs bs body + Explicit -> Var <$> freshInferenceName (TypeInstantiationInfVar sourceName) (binderType b) + Inferred argName infMech -> getImplicitArg (sourceName, fromMaybe "_" argName) infMech (binderType b) + rest <- instantiate (Abs b $ Abs bs body) [x] (params, body') <- go expls rest return (x:params, body') go _ _ = error "zip error" @@ -2084,14 +2111,14 @@ bindLetPats _ _ _ = error "mismatched number of args" bindLetPat :: EmitsBoth o => UPat i i' -> CAtomVar o -> InfererM i' o a -> InfererM i o a bindLetPat (WithSrcB pos pat) v cont = addSrcContext pos $ case pat of UPatBinder b -> extendSubst (b @> atomVarName v) cont - UPatProd ps -> do - let n = nestLength ps - ty <- return $ getType v - _ <- fromProdType n ty - x <- zonk $ Var v - xs <- forM (iota n) \i -> do - normalizeProj (ProjectProduct i) x >>= emit . Atom - bindLetPats ps xs cont + -- UPatProd ps -> do + -- let n = nestLength ps + -- ty <- return $ getType v + -- _ <- fromProdType n ty + -- x <- zonk $ Var v + -- xs <- forM (iota n) \i -> do + -- normalizeProj (ProjectProduct i) x >>= emit . Atom + -- bindLetPats ps xs cont UPatDepPair (PairB p1 p2) -> do let x = Var v ty <- return $ getType x @@ -2102,20 +2129,20 @@ bindLetPat (WithSrcB pos pat) v cont = addSrcContext pos $ case pat of x2 <- getSnd x' >>= zonk >>= emit . Atom bindLetPat p2 x2 do cont - UPatCon ~(InternalName _ _ conName) ps -> do - (dataDefName, _) <- lookupDataCon =<< renameM conName - TyConDef sourceName roleExpls paramBs cons <- lookupTyCon dataDefName - case cons of - ADTCons [DataConDef _ _ _ idxss] -> do - when (length idxss /= nestLength ps) $ throw TypeErr $ - "Unexpected number of pattern binders. Expected " ++ show (length idxss) - ++ " got " ++ show (nestLength ps) - (params, UnitE) <- inferParams sourceName roleExpls (Abs paramBs UnitE) - constrainVarTy v $ TypeCon sourceName dataDefName params - x <- cheapNormalize =<< zonk (Var v) - xs <- forM idxss \idxs -> normalizeNaryProj idxs x >>= emit . Atom - bindLetPats ps xs cont - _ -> throw TypeErr $ "sum type constructor in can't-fail pattern" + -- UPatCon ~(InternalName _ _ conName) ps -> do + -- (dataDefName, _) <- lookupDataCon =<< renameM conName + -- TyConDef sourceName roleExpls paramBs cons <- lookupTyCon dataDefName + -- case cons of + -- ADTCons [DataConDef _ _ _ idxss] -> do + -- when (length idxss /= nestLength ps) $ throw TypeErr $ + -- "Unexpected number of pattern binders. Expected " ++ show (length idxss) + -- ++ " got " ++ show (nestLength ps) + -- (params, UnitE) <- inferParams sourceName roleExpls (Abs paramBs UnitE) + -- constrainVarTy v $ TypeCon sourceName dataDefName params + -- x <- cheapNormalize =<< zonk (Var v) + -- xs <- forM idxss \idxs -> normalizeNaryProj idxs x >>= emit . Atom + -- bindLetPats ps xs cont + -- _ -> throw TypeErr $ "sum type constructor in can't-fail pattern" UPatTable ps -> do elemTy <- freshType let n = fromIntegral (nestLength ps) :: Word32 @@ -2147,36 +2174,37 @@ checkUParam k uty@(WithSrcE pos _) = addSrcContext pos $ inferTabCon :: forall i o. EmitsBoth o => NameHint -> [UExpr i] -> RequiredTy CType o -> InfererM i o (CAtom o) -inferTabCon hint xs reqTy = do - let n = fromIntegral (length xs) :: Word32 - let finTy = FinConst n - ctx <- srcPosCtx <$> getErrCtx - let dataDictHole dTy = Just $ WhenIRE $ DictHole (AlwaysEqual ctx) dTy Full - case reqTy of - Infer -> do - elemTy <- case xs of - [] -> freshType - (x:_) -> getType <$> inferRho noHint x - ixTy <- asIxType finTy - let tabTy = ixTy ==> elemTy - xs' <- forM xs \x -> checkRho noHint x elemTy - dTy <- DictTy <$> dataDictType elemTy - liftM Var $ emitHinted hint $ TabCon (dataDictHole dTy) tabTy xs' - Check tabTy -> do - TabPiType _ b elemTy <- fromTabPiType True tabTy - constrainTypesEq (binderType b) finTy - xs' <- forM (enumerate xs) \(i, x) -> do - let i' = NewtypeCon (FinCon (NatVal n)) (NatVal $ fromIntegral i) :: CAtom o - elemTy' <- applySubst (b@>SubstVal i') elemTy - checkRho noHint x elemTy' - dTy <- case hoist b elemTy of - HoistSuccess elemTy' -> DictTy <$> dataDictType elemTy' - HoistFailure _ -> ignoreExcept <$> liftEnvReaderT do - withFreshBinder noHint finTy \b' -> do - elemTy' <- applyRename (b@>binderName b') elemTy - dTy <- DictTy <$> dataDictType elemTy' - return $ Pi $ CorePiType ImplicitApp [Inferred Nothing Unify] (UnaryNest b') (EffTy Pure dTy) - liftM Var $ emitHinted hint $ TabCon (dataDictHole dTy) tabTy xs' +inferTabCon hint xs reqTy = undefined +-- inferTabCon hint xs reqTy = do +-- let n = fromIntegral (length xs) :: Word32 +-- let finTy = FinConst n +-- ctx <- srcPosCtx <$> getErrCtx +-- let dataDictHole dTy = Just $ WhenIRE $ DictHole (AlwaysEqual ctx) dTy Full +-- case reqTy of +-- Infer -> do +-- elemTy <- case xs of +-- [] -> freshType +-- (x:_) -> getType <$> inferRho noHint x +-- ixTy <- asIxType finTy +-- let tabTy = ixTy ==> elemTy +-- xs' <- forM xs \x -> checkRho noHint x elemTy +-- dTy <- DictTy <$> dataDictType elemTy +-- liftM Var $ emitHinted hint $ TabCon (dataDictHole dTy) tabTy xs' +-- Check ty -> do +-- tabTy@(TabPiType _ b _) <- fromTabPiType True ty +-- constrainTypesEq (binderType b) finTy +-- xs' <- forM (enumerate xs) \(i, x) -> do +-- let i' = NewtypeCon (FinCon (NatVal n)) (NatVal $ fromIntegral i) :: CAtom o +-- elemTy' <- instantiate tabTy [i'] +-- checkRho noHint x elemTy' +-- dTy <- case tryAsConst tabTy of +-- Nothing -> ignoreExcept <$> liftEnvReaderT do +-- withFreshBinder noHint finTy \b' -> do +-- elemTy' <- instantiate tabTy [Var $ binderVar b'] +-- dTy <- DictTy <$> dataDictType elemTy' +-- return $ Pi $ CorePiType ImplicitApp [Inferred Nothing Unify] (UnaryNest (BD b')) (EffTy Pure dTy) +-- Just elemTy' -> DictTy <$> dataDictType elemTy' +-- liftM Var $ emitHinted hint $ TabCon (dataDictHole dTy) ty xs' -- Bool flag is just to tweak the reported error message fromTabPiType :: EmitsBoth o => Bool -> CType o -> InfererM i o (TabPiType CoreIR o) @@ -2223,11 +2251,12 @@ openEffectRow (EffectRow effs NoTail) = extendEffRow effs <$> freshEff openEffectRow effRow = return effRow asIxType :: CType o -> InfererM i o (IxType CoreIR o) -asIxType ty = do - dictTy <- DictTy <$> ixDictType ty - ctx <- srcPosCtx <$> getErrCtx - return $ IxType ty $ IxDictAtom $ DictHole (AlwaysEqual ctx) dictTy Full -{-# SCC asIxType #-} +asIxType ty = undefined +-- asIxType ty = do +-- dictTy <- DictTy <$> ixDictType ty +-- ctx <- srcPosCtx <$> getErrCtx +-- return $ IxType ty $ IxDictAtom $ DictHole (AlwaysEqual ctx) dictTy Full +-- {-# SCC asIxType #-} -- === Solver === @@ -2536,28 +2565,30 @@ instance Unifiable CorePiType where go (Abs bsTop1 effTy1) (Abs bsTop2 effTy2) where go :: EmitsInf n - => Abs (Nest CBinder) (EffTy CoreIR) n - -> Abs (Nest CBinder) (EffTy CoreIR) n + => Abs CBinders (EffTy CoreIR) n + -> Abs CBinders (EffTy CoreIR) n -> SolverM n () - go (Abs Empty (EffTy e1 t1)) (Abs Empty (EffTy e2 t2)) = unify t1 t2 >> unify e1 e2 - go (Abs (Nest (b1:>t1) bs1) rest1) - (Abs (Nest (b2:>t2) bs2) rest2) = do - unify t1 t2 - v <- freshSkolemName t1 - ab1 <- zonk =<< applySubst (b1@>SubstVal (Var v)) (Abs bs1 rest1) - ab2 <- zonk =<< applySubst (b2@>SubstVal (Var v)) (Abs bs2 rest2) - go ab1 ab2 - go _ _ = empty + go = undefined + -- go (Abs Empty (EffTy e1 t1)) (Abs Empty (EffTy e2 t2)) = unify t1 t2 >> unify e1 e2 + -- go (Abs (Nest b1 bs1) rest1) + -- (Abs (Nest b2 bs2) rest2) = do + -- unify (binderType b1) (binderType b2) + -- v <- freshSkolemName (binderType b1) + -- ab1 <- zonk =<< instantiate (Abs b1 (Abs bs1 rest1)) [Var v] + -- ab2 <- zonk =<< instantiate (Abs b2 (Abs bs2 rest2)) [Var v] + -- go ab1 ab2 + -- go _ _ = empty unifyTabPiType :: EmitsInf n => TabPiType CoreIR n -> TabPiType CoreIR n -> SolverM n () -unifyTabPiType (TabPiType _ b1 ty1) (TabPiType _ b2 ty2) = do - let ann1 = binderType b1 - let ann2 = binderType b2 - unify ann1 ann2 - v <- freshSkolemName ann1 - ty1' <- applySubst (b1@>SubstVal (Var v)) ty1 - ty2' <- applySubst (b2@>SubstVal (Var v)) ty2 - unify ty1' ty2' +unifyTabPiType (TabPiType _ b1 ty1) (TabPiType _ b2 ty2) = undefined +-- unifyTabPiType (TabPiType _ b1 ty1) (TabPiType _ b2 ty2) = do +-- let ann1 = binderType b1 +-- let ann2 = binderType b2 +-- unify ann1 ann2 +-- v <- freshSkolemName ann1 +-- ty1' <- instantiate (Abs b1 ty1) [Var v] +-- ty2' <- instantiate (Abs b2 ty2) [Var v] +-- unify ty1' ty2' extendSolution :: CAtomName n -> CAtom n -> SolverM n () extendSolution v t = @@ -2648,38 +2679,40 @@ generalizeDictAndUnify ty dict = do zonk dict' generalizeDictRec :: EmitsInf n => Dict n -> SolverM n (Dict n) -generalizeDictRec dict = do - -- TODO: we should be able to avoid the normalization here . We only need it - -- because we sometimes end up with superclass projections. But they shouldn't - -- really be allowed to occur in the post-simplification IR. - DictCon _ dict' <- cheapNormalize dict - mkDictAtom =<< case dict' of - InstanceDict instanceName args -> do - InstanceDef _ roleExpls bs _ _ <- lookupInstanceDef instanceName - args' <- generalizeInstanceArgs roleExpls bs args - return $ InstanceDict instanceName args' - IxFin _ -> IxFin <$> Var <$> freshInferenceName MiscInfVar NatTy - InstantiatedGiven _ _ -> notSimplifiedDict - SuperclassProj _ _ -> notSimplifiedDict - DataData ty -> DataData <$> TyVar <$> freshInferenceName MiscInfVar ty - where notSimplifiedDict = error $ "Not a simplified dict: " ++ pprint dict - -generalizeInstanceArgs :: EmitsInf n => [RoleExpl] -> Nest CBinder n l -> [CAtom n] -> SolverM n [CAtom n] -generalizeInstanceArgs [] Empty [] = return [] -generalizeInstanceArgs ((role,_):expls) (Nest (b:>ty) bs) (arg:args) = do - arg' <- case role of - -- XXX: for `TypeParam` we can just emit a fresh inference name rather than - -- traversing the whole type like we do in `Generalize.hs`. The reason is - -- that it's valid to implement `generalizeDict` by synthesizing an entirely - -- fresh dictionary, and if we were to do that, we would infer this type - -- parameter exactly as we do here, using inference. - TypeParam -> Var <$> freshInferenceName MiscInfVar TyKind - DictParam -> generalizeDictAndUnify ty arg - DataParam -> Var <$> freshInferenceName MiscInfVar ty - Abs bs' UnitE <- applySubst (b@>SubstVal arg') (Abs bs UnitE) - args' <- generalizeInstanceArgs expls bs' args - return $ arg':args' -generalizeInstanceArgs _ _ _ = error "zip error" +generalizeDictRec dict = undefined +-- generalizeDictRec dict = do +-- -- TODO: we should be able to avoid the normalization here . We only need it +-- -- because we sometimes end up with superclass projections. But they shouldn't +-- -- really be allowed to occur in the post-simplification IR. +-- DictCon _ dict' <- cheapNormalize dict +-- mkDictAtom =<< case dict' of +-- InstanceDict instanceName args -> do +-- InstanceDef _ roleExpls bs _ _ <- lookupInstanceDef instanceName +-- args' <- generalizeInstanceArgs roleExpls bs args +-- return $ InstanceDict instanceName args' +-- IxFin _ -> IxFin <$> Var <$> freshInferenceName MiscInfVar NatTy +-- InstantiatedGiven _ _ -> notSimplifiedDict +-- SuperclassProj _ _ -> notSimplifiedDict +-- DataData ty -> DataData <$> TyVar <$> freshInferenceName MiscInfVar ty +-- where notSimplifiedDict = error $ "Not a simplified dict: " ++ pprint dict + +generalizeInstanceArgs :: EmitsInf n => [RoleExpl] -> CBinders n l -> [CAtom n] -> SolverM n [CAtom n] +generalizeInstanceArgs [] Empty [] = undefined +-- generalizeInstanceArgs [] Empty [] = return [] +-- generalizeInstanceArgs ((role,_):expls) (Nest b bs) (arg:args) = do +-- arg' <- case role of +-- -- XXX: for `TypeParam` we can just emit a fresh inference name rather than +-- -- traversing the whole type like we do in `Generalize.hs`. The reason is +-- -- that it's valid to implement `generalizeDict` by synthesizing an entirely +-- -- fresh dictionary, and if we were to do that, we would infer this type +-- -- parameter exactly as we do here, using inference. +-- TypeParam -> Var <$> freshInferenceName MiscInfVar TyKind +-- DictParam -> generalizeDictAndUnify (binderType b) arg +-- DataParam -> Var <$> freshInferenceName MiscInfVar (binderType b) +-- Abs bs' UnitE <- instantiate (Abs b (Abs bs UnitE)) [arg'] +-- args' <- generalizeInstanceArgs expls bs' args +-- return $ arg':args' +-- generalizeInstanceArgs _ _ _ = error "zip error" synthInstanceDefAndAddSynthCandidate :: (Mut n, TopBuilder m, EnvReader m, Fallible1 m) => InstanceDef n -> m n (InstanceName n) @@ -2703,9 +2736,9 @@ pattern InstanceDefAbsBody :: [CAtom n] -> [CAtom n] -> [CAtom n] -> [CAtom n] pattern InstanceDefAbsBody params superclasses doneMethods todoMethods = ListE params `PairE` (ListE superclasses) `PairE` (ListE doneMethods) `PairE` (ListE todoMethods) -type InstanceDefAbsT n = ([RoleExpl], Abs (Nest CBinder) InstanceDefAbsBodyT n) +type InstanceDefAbsT n = ([RoleExpl], Abs CBinders InstanceDefAbsBodyT n) -pattern InstanceDefAbs :: [RoleExpl] -> Nest CBinder h n -> [CAtom n] -> [CAtom n] -> [CAtom n] -> [CAtom n] +pattern InstanceDefAbs :: [RoleExpl] -> CBinders h n -> [CAtom n] -> [CAtom n] -> [CAtom n] -> [CAtom n] -> InstanceDefAbsT h pattern InstanceDefAbs expls bs params superclasses doneMethods todoMethods = (expls, Abs bs (InstanceDefAbsBody params superclasses doneMethods todoMethods)) @@ -2747,20 +2780,21 @@ synthInstanceDef (InstanceDef className expls bs params body) = do -- main entrypoint to dictionary synthesizer trySynthTerm :: (Fallible1 m, EnvReader m) => CType n -> RequiredMethodAccess -> m n (SynthAtom n) -trySynthTerm ty reqMethodAccess = do - hasInferenceVars ty >>= \case - True -> throw TypeErr "Can't synthesize a dictionary for a type with inference vars" - False -> do - synthTy <- liftExcept $ typeAsSynthType ty - solutions <- liftSyntherM $ synthTerm synthTy reqMethodAccess - case solutions of - [] -> throw TypeErr $ "Couldn't synthesize a class dictionary for: " ++ pprint ty - [d] -> cheapNormalize d -- normalize to reduce code size - _ -> throw TypeErr $ "Multiple candidate class dictionaries for: " ++ pprint ty -{-# SCC trySynthTerm #-} +trySynthTerm ty reqMethodAccess = undefined +-- trySynthTerm ty reqMethodAccess = do +-- hasInferenceVars ty >>= \case +-- True -> throw TypeErr "Can't synthesize a dictionary for a type with inference vars" +-- False -> do +-- synthTy <- liftExcept $ typeAsSynthType ty +-- solutions <- liftSyntherM $ synthTerm synthTy reqMethodAccess +-- case solutions of +-- [] -> throw TypeErr $ "Couldn't synthesize a class dictionary for: " ++ pprint ty +-- [d] -> cheapNormalize d -- normalize to reduce code size +-- _ -> throw TypeErr $ "Multiple candidate class dictionaries for: " ++ pprint ty +-- {-# SCC trySynthTerm #-} type SynthAtom = CAtom -type SynthPiType n = ([Explicitness], Abs (Nest CBinder) DictType n) +type SynthPiType n = ([Explicitness], Abs CBinders DictType n) data SynthType n = SynthDictType (DictType n) | SynthPiType (SynthPiType n) @@ -2853,7 +2887,7 @@ getSuperclassClosurePure env givens newGivens = synthTy <- return $ getSynthType synthExpr superclasses <- case synthTy of SynthPiType _ -> return [] - SynthDictType dTy -> getSuperclassTys dTy + -- SynthDictType dTy -> getSuperclassTys dTy forM (enumerate superclasses) \(i, ty) -> do return $ DictCon ty $ SuperclassProj synthExpr i @@ -2881,7 +2915,7 @@ synthTerm targetTy reqMethodAccess = confuseGHC >>= \_ -> case targetTy of {-# SCC synthTerm #-} coreLamExpr :: EnvReader m => AppExplicitness - -> [Explicitness] -> Abs (Nest CBinder) (PairE (EffectRow CoreIR) CBlock) n + -> [Explicitness] -> Abs CBinders (PairE (EffectRow CoreIR) CBlock) n -> m n (CoreLamExpr n) coreLamExpr appExpl expls ab = liftEnvReaderM do refreshAbs ab \bs' (PairE effs' body') -> do @@ -2889,30 +2923,31 @@ coreLamExpr appExpl expls ab = liftEnvReaderM do return $ CoreLamExpr (CorePiType appExpl expls bs' (EffTy effs' resultTy)) (LamExpr bs' body') withGivenBinders - :: (SinkableE e, RenameE e) => [Explicitness] -> Abs (Nest CBinder) e n - -> (forall l. DExt n l => Nest CBinder n l -> e l -> SyntherM l a) + :: (SinkableE e, RenameE e) => [Explicitness] -> Abs CBinders e n + -> (forall l. DExt n l => CBinders n l -> e l -> SyntherM l a) -> SyntherM n a -withGivenBinders explsTop (Abs bsTop e) contTop = - runSubstReaderT idSubst $ go explsTop bsTop \bsTop' -> do - e' <- renameM e - liftSubstReaderT $ contTop bsTop' e' - where - go :: [Explicitness] -> Nest CBinder i i' - -> (forall o'. DExt o o' => Nest CBinder o o' -> SubstReaderT Name SyntherM i' o' a) - -> SubstReaderT Name SyntherM i o a - go expls bs cont = case (expls, bs) of - ([], Empty) -> getDistinct >>= \Distinct -> cont Empty - (expl:explsRest, Nest b rest) -> do - argTy <- renameM $ binderType b - withFreshBinder (getNameHint b) argTy \b' -> do - givens <- case expl of - Inferred _ (Synth _) -> return [Var $ binderVar b'] - _ -> return [] - s <- getSubst - liftSubstReaderT $ extendGivens givens $ - runSubstReaderT (s <>> b@>binderName b') $ - go explsRest rest \rest' -> cont (Nest b' rest') - _ -> error "zip error" +withGivenBinders explsTop (Abs bsTop e) contTop = undefined +-- withGivenBinders explsTop (Abs bsTop e) contTop = +-- runSubstReaderT idSubst $ go explsTop bsTop \bsTop' -> do +-- e' <- renameM e +-- liftSubstReaderT $ contTop bsTop' e' +-- where +-- go :: [Explicitness] -> CBinders i i' +-- -> (forall o'. DExt o o' => CBinders o o' -> SubstReaderT Name SyntherM i' o' a) +-- -> SubstReaderT Name SyntherM i o a +-- go expls bs cont = case (expls, bs) of +-- ([], Empty) -> getDistinct >>= \Distinct -> cont Empty +-- (expl:explsRest, Nest (BD b) rest) -> do +-- argTy <- renameM $ binderType b +-- withFreshBinder (getNameHint b) argTy \b' -> do +-- givens <- case expl of +-- Inferred _ (Synth _) -> return [Var $ binderVar b'] +-- _ -> return [] +-- s <- getSubst +-- liftSubstReaderT $ extendGivens givens $ +-- runSubstReaderT (s <>> b@>binderName b') $ +-- go explsRest rest \rest' -> cont (Nest (BD b') rest') +-- _ -> error "zip error" isMethodAccessAllowedBy :: EnvReader m => RequiredMethodAccess -> InstanceName n -> m n Bool isMethodAccessAllowedBy access instanceName = do @@ -2945,30 +2980,32 @@ synthDictFromInstance targetTy@(DictType _ targetClass _) = do return $ DictCon (DictTy targetTy) $ InstanceDict candidate args instantiateSynthArgs :: DictType n -> SynthPiType n -> SyntherM n [CAtom n] -instantiateSynthArgs targetTop (explsTop, Abs bsTop resultTyTop) = do - ListE args <- (liftExceptAlt =<<) $ liftSolverM $ solveLocal do - args <- runSubstReaderT idSubst $ go (sink targetTop) explsTop (sink $ Abs bsTop resultTyTop) - zonk $ ListE args - forM args \case - DictHole _ argTy req -> liftExceptAlt (typeAsSynthType argTy) >>= flip synthTerm req - arg -> return arg - where - go :: EmitsInf o - => DictType o -> [Explicitness] -> Abs (Nest CBinder) DictType i - -> SubstReaderT AtomSubstVal SolverM i o [CAtom o] - go target allExpls (Abs bs proposed) = case (allExpls, bs) of - ([], Empty) -> do - proposed' <- substM proposed - liftSubstReaderT $ unify target proposed' - return [] - (expl:expls, Nest b rest) -> do - argTy <- substM $ binderType b - arg <- liftSubstReaderT case expl of - Explicit -> error "instances shouldn't have explicit args" - Inferred _ Unify -> Var <$> freshInferenceName MiscInfVar argTy - Inferred _ (Synth req) -> return $ DictHole (AlwaysEqual emptySrcPosCtx) argTy req - liftM (arg:) $ extendSubst (b@>SubstVal arg) $ go target expls (Abs rest proposed) - _ -> error "zip error" +instantiateSynthArgs targetTop (explsTop, Abs bsTop resultTyTop) = undefined +-- instantiateSynthArgs targetTop (explsTop, Abs bsTop resultTyTop) = do +-- ListE args <- (liftExceptAlt =<<) $ liftSolverM $ solveLocal do +-- args <- runSubstReaderT idSubst $ go (sink targetTop) explsTop (sink $ Abs bsTop resultTyTop) +-- zonk $ ListE args +-- forM args \case +-- DictHole _ argTy req -> liftExceptAlt (typeAsSynthType argTy) >>= flip synthTerm req +-- arg -> return arg +-- where +-- go :: EmitsInf o +-- => DictType o -> [Explicitness] -> Abs CBinders DictType i +-- -> SubstReaderT AtomSubstVal SolverM i o [CAtom o] +-- go target allExpls (Abs bs proposed) = undefined + -- go target allExpls (Abs bs proposed) = case (allExpls, bs) of + -- ([], Empty) -> do + -- proposed' <- substM proposed + -- liftSubstReaderT $ unify target proposed' + -- return [] + -- (expl:expls, Nest b rest) -> do + -- argTy <- substM $ binderType b + -- arg <- liftSubstReaderT case expl of + -- Explicit -> error "instances shouldn't have explicit args" + -- Inferred _ Unify -> Var <$> freshInferenceName MiscInfVar argTy + -- Inferred _ (Synth req) -> return $ DictHole (AlwaysEqual emptySrcPosCtx) argTy req + -- liftM (arg:) $ extendSubstBD b [SubstVal arg] $ go target expls (Abs rest proposed) + -- _ -> error "zip error" synthDictForData :: forall n. DictType n -> SyntherM n (SynthAtom n) synthDictForData dictTy@(DictType "Data" dName [Type ty]) = case ty of @@ -2976,11 +3013,12 @@ synthDictForData dictTy@(DictType "Data" dName [Type ty]) = case ty of -- The "Var" case is different TyVar _ -> synthDictFromGiven dictTy TabPi (TabPiType _ b eltTy) -> recurBinder (Abs b eltTy) >> success - DepPairTy (DepPairType _ b@(_:>l) r) -> do - recur l >> recurBinder (Abs b r) >> success - NewtypeTyCon nt -> do - (_, ty') <- unwrapNewtypeType nt - recur ty' >> success + DepPairTy (DepPairType _ b r) -> do + recur (binderType b) >> recurBinder (Abs b r) >> success + NewtypeTyCon nt -> undefined + -- NewtypeTyCon nt -> do + -- (_, ty') <- unwrapNewtypeType nt + -- recur ty' >> success TC con -> case con of BaseType _ -> success ProdType as -> mapM_ recur as >> success @@ -3045,23 +3083,23 @@ instance DictSynthTraversable (TopLam CoreIR) where dsTraverse (TopLam d ty lam) = TopLam d <$> visitPiDefault ty <*> visitLamNoEmits lam instance DictSynthTraversable CAtom where - dsTraverse atom = case atom of - DictHole (AlwaysEqual ctx) ty access -> do - ty' <- cheapNormalize =<< dsTraverse ty - ans <- liftEnvReaderT $ addSrcContext ctx $ trySynthTerm ty' access - case ans of - Failure errs -> put (LiftE errs) >> renameM atom - Success d -> return d - Lam (CoreLamExpr piTy@(CorePiType _ expls _ _) (LamExpr bsLam (Abs decls result))) -> do - Pi piTy' <- dsTraverse $ Pi piTy - lam' <- dsTraverseExplBinders expls bsLam \bsLam' -> do - visitDeclsNoEmits decls \decls' -> do - LamExpr bsLam' <$> Abs decls' <$> dsTraverse result - return $ Lam $ CoreLamExpr piTy' lam' - Var _ -> renameM atom - SimpInCore _ -> renameM atom - ProjectElt _ _ _ -> renameM atom - _ -> visitAtomPartial atom + dsTraverse atom = undefined + -- dsTraverse atom = case atom of + -- DictHole (AlwaysEqual ctx) ty access -> do + -- ty' <- cheapNormalize =<< dsTraverse ty + -- ans <- liftEnvReaderT $ addSrcContext ctx $ trySynthTerm ty' access + -- case ans of + -- Failure errs -> put (LiftE errs) >> renameM atom + -- Success d -> return d + -- Lam (CoreLamExpr piTy@(CorePiType _ expls _ _) (LamExpr bsLam (Abs decls result))) -> do + -- Pi piTy' <- dsTraverse $ Pi piTy + -- lam' <- dsTraverseExplBinders expls bsLam \bsLam' -> do + -- visitDeclsNoEmits decls \decls' -> do + -- LamExpr bsLam' <$> Abs decls' <$> dsTraverse result + -- return $ Lam $ CoreLamExpr piTy' lam' + -- Var _ -> renameM atom + -- SimpInCore _ -> renameM atom + -- _ -> visitAtomPartial atom instance DictSynthTraversable CType where dsTraverse ty = case ty of @@ -3069,23 +3107,22 @@ instance DictSynthTraversable CType where dsTraverseExplBinders expls bs \bs' -> do CorePiType appExpl expls bs' <$> (EffTy <$> renameM effs <*> dsTraverse resultTy) TyVar _ -> renameM ty - ProjectEltTy _ _ _ -> renameM ty _ -> visitTypePartial ty instance DictSynthTraversable DataConDefs where dsTraverse = visitGeneric dsTraverseExplBinders - :: [Explicitness] -> Nest CBinder i i' - -> (forall o'. DExt o o' => Nest CBinder o o' -> DictSynthTraverserM i' o' a) + :: [Explicitness] -> CBinders i i' + -> (forall o'. DExt o o' => CBinders o o' -> DictSynthTraverserM i' o' a) -> DictSynthTraverserM i o a dsTraverseExplBinders [] Empty cont = getDistinct >>= \Distinct -> cont Empty -dsTraverseExplBinders (expl:expls) (Nest b bs) cont = do - ty <- dsTraverse $ binderType b - withFreshBinder (getNameHint b) ty \b' -> do - let v = binderName b' - extendSynthCandidatesDict expl v $ extendRenamer (b@>v) do - dsTraverseExplBinders expls bs \bs' -> cont $ Nest b' bs' -dsTraverseExplBinders _ _ _ = error "zip error" +-- dsTraverseExplBinders (expl:expls) (Nest (BD b) bs) cont = do +-- ty <- dsTraverse $ binderType b +-- withFreshBinder (getNameHint b) ty \b' -> do +-- let v = binderName b' +-- extendSynthCandidatesDict expl v $ extendRenamer (b@>v) do +-- dsTraverseExplBinders expls bs \bs' -> cont $ Nest (BD b') bs' +-- dsTraverseExplBinders _ _ _ = error "zip error" extendSynthCandidatesDict :: Explicitness -> CAtomName n -> DictSynthTraverserM i n a -> DictSynthTraverserM i n a extendSynthCandidatesDict c v cont = DictSynthTraverserM do @@ -3111,28 +3148,30 @@ buildBlockInf :: EmitsInf n => (forall l. (EmitsBoth l, DExt n l) => InfererM i l (CAtom l)) -> InfererM i n (CBlock n) -buildBlockInf cont = do - Abs decls (PairE result ty) <- buildDeclsInf do - ans <- cont - ty <- cheapNormalize $ getType ans - return $ PairE ans ty - let msg = "Block:" <> nest 1 (prettyBlock decls result) <> line - <> group ("Of type:" <> nest 2 (line <> pretty ty)) <> line - void $ liftHoistExcept' (docAsStr msg) $ hoist decls ty - return $ Abs decls result -{-# INLINE buildBlockInf #-} +buildBlockInf cont = undefined +-- buildBlockInf cont = do +-- Abs decls (PairE result ty) <- buildDeclsInf do +-- ans <- cont +-- ty <- cheapNormalize $ getType ans +-- return $ PairE ans ty +-- let msg = "Block:" <> nest 1 (prettyBlock decls result) <> line +-- <> group ("Of type:" <> nest 2 (line <> pretty ty)) <> line +-- void $ liftHoistExcept' (docAsStr msg) $ hoist decls ty +-- return $ Abs decls result +-- {-# INLINE buildBlockInf #-} buildBlockInfWithRecon :: (EmitsInf n, RenameE e, HoistableE e, SinkableE e) => (forall l. (EmitsBoth l, DExt n l) => InfererM i l (e l)) -> InfererM i n (PairE CBlock (ReconAbs CoreIR e) n) -buildBlockInfWithRecon cont = do - ab <- buildDeclsInfUnzonked cont - (block, recon) <- refreshAbs ab \decls result -> do - (newResult, recon) <- telescopicCapture decls result - return (Abs decls newResult, recon) - return $ PairE block recon -{-# INLINE buildBlockInfWithRecon #-} +buildBlockInfWithRecon cont = undefined +-- buildBlockInfWithRecon cont = do +-- ab <- buildDeclsInfUnzonked cont +-- (block, recon) <- refreshAbs ab \decls result -> do +-- (newResult, recon) <- telescopicCapture decls result +-- return (Abs decls newResult, recon) +-- return $ PairE block recon +-- {-# INLINE buildBlockInfWithRecon #-} buildTabPiInf :: EmitsInf n @@ -3141,7 +3180,7 @@ buildTabPiInf -> InfererM i n (TabPiType CoreIR n) buildTabPiInf hint (IxType t d) body = do Abs b resultTy <- buildAbsInf hint Explicit t \v -> withoutEffects $ body v - return $ TabPiType d b resultTy + return $ TabPiType d (PlainBD b) resultTy buildDepPairTyInf :: EmitsInf n @@ -3150,7 +3189,7 @@ buildDepPairTyInf -> InfererM i n (DepPairType CoreIR n) buildDepPairTyInf hint expl ty body = do Abs b resultTy <- buildAbsInf hint Explicit ty body - return $ DepPairType expl b resultTy + return $ DepPairType expl (PlainBD b) resultTy buildAltInf :: EmitsInf n @@ -3270,7 +3309,7 @@ instance BindsEnv InfOutFrag where toEnvFrag (InfOutFrag frag _ _) = toEnvFrag frag instance GenericE SynthType where - type RepE SynthType = EitherE2 DictType (PairE (LiftE [Explicitness]) (Abs (Nest CBinder) DictType)) + type RepE SynthType = EitherE2 DictType (PairE (LiftE [Explicitness]) (Abs CBinders DictType)) fromE (SynthDictType d) = Case0 d fromE (SynthPiType (expl, t)) = Case1 (PairE (LiftE expl) t) toE (Case0 d) = SynthDictType d diff --git a/src/lib/Inline.hs b/src/lib/Inline.hs index bcf5bdc64..c3db61eae 100644 --- a/src/lib/Inline.hs +++ b/src/lib/Inline.hs @@ -11,7 +11,6 @@ import Data.List.NonEmpty qualified as NE import Builder import Core import Err -import CheapReduction import IRVariants import Name import Subst @@ -19,6 +18,7 @@ import Occurrence hiding (Var) import Optimize import Types.Core import Types.Primitives +import Visitor -- === External API === @@ -280,10 +280,6 @@ inlineExpr ctx = \case inlineAtom :: Emits o => Context SExpr e o -> SAtom i -> InlineM i o (e o) inlineAtom ctx = \case Var name -> inlineName ctx name - ProjectElt _ i x -> do - let (idxs, v) = asNaryProj i x - ans <- normalizeNaryProj (NE.toList idxs) =<< inline Stop (Var v) - reconstruct ctx $ Atom ans atom -> (Atom <$> visitAtomPartial atom) >>= reconstruct ctx inlineName :: Emits o => Context SExpr e o -> SAtomVar i -> InlineM i o (e o) @@ -319,15 +315,15 @@ instance Inlinable SLam where inlineDecls decls $ inline Stop ans withBinders - :: Nest SBinder i i' - -> (forall o'. DExt o o' => Nest SBinder o o' -> InlineM i' o' a) + :: SBinders i i' + -> (forall o'. DExt o o' => SBinders o o' -> InlineM i' o' a) -> InlineM i o a withBinders Empty cont = getDistinct >>= \Distinct -> cont Empty -withBinders (Nest (b:>ty) bs) cont = do - ty' <- buildScopedAssumeNoDecls $ inline Stop ty - withFreshBinder (getNameHint b) ty' \b' -> - extendRenamer (b@>binderName b') do - withBinders bs \bs' -> cont $ Nest b' bs' +-- withBinders (Nest (BD (b:>ty)) bs) cont = do +-- ty' <- buildScopedAssumeNoDecls $ inline Stop ty +-- withFreshBinder (getNameHint b) ty' \b' -> +-- extendRenamer (b@>binderName b') do +-- withBinders bs \bs' -> cont $ Nest (BD b') bs' instance Inlinable (PiType SimpIR) where inline ctx (PiType bs effTy) = @@ -381,8 +377,7 @@ reconstructTabApp ctx expr ixs = ixsPref' <- mapM (inline $ EmitToNameCtx Stop) ixsPref let ixsPref'' = [v | AtomVar v _ <- ixsPref'] s <- getSubst - let moreSubst = bs @@> map Rename ixsPref'' - dropSubst $ extendSubst moreSubst do + dropSubst $ extendSubstBD bs (Rename <$> ixsPref'') do -- Decision here. These decls have already been processed by the -- inliner once, so their occurrence information is stale (and should -- have been erased). Do we rerun occurrence analysis, or just complete diff --git a/src/lib/JAX/ToSimp.hs b/src/lib/JAX/ToSimp.hs index e2e183955..dc9d3810e 100644 --- a/src/lib/JAX/ToSimp.hs +++ b/src/lib/JAX/ToSimp.hs @@ -46,7 +46,7 @@ simplifyJaxpr (Jaxpr invars constvars eqns outvars) = do simplifyJBinders :: Nest JBinder i i' - -> (forall o'. DExt o o' => Nest SBinder o o' -> JaxSimpM i' o' a) + -> (forall o'. DExt o o' => SBinders o o' -> JaxSimpM i' o' a) -> JaxSimpM i o a simplifyJBinders Empty cont = getDistinct >>= \Distinct -> cont Empty simplifyJBinders (Nest jb jbs) cont = case jb of @@ -55,7 +55,7 @@ simplifyJBinders (Nest jb jbs) cont = case jb of ty <- simplifyJTy jTy withFreshBinder (getNameHint suffix) ty \b' -> do extendSubst (b @> Rename (binderName b')) do - simplifyJBinders jbs \bs' -> cont (Nest b' bs') + simplifyJBinders jbs \bs' -> cont (Nest (PlainBD b') bs') simplifyJTy :: JVarType -> JaxSimpM i o (SType o) simplifyJTy JArrayName{shape, dtype} = go shape $ simplifyDType dtype where diff --git a/src/lib/Linearize.hs b/src/lib/Linearize.hs index d32b5230a..c17390536 100644 --- a/src/lib/Linearize.hs +++ b/src/lib/Linearize.hs @@ -17,7 +17,6 @@ import GHC.Stack import Builder import Core -import CheapReduction import Imp import IRVariants import MTL1 @@ -72,6 +71,9 @@ extendActiveSubst => b i i' -> SAtomVar o -> PrimalM i' o a -> PrimalM i o a extendActiveSubst b v cont = extendSubst (b@>atomVarName v) $ extendActivePrimals v cont +extendActiveSubstBD :: BinderAndDecls SimpIR i i' -> SAtomVar o -> PrimalM i' o a -> PrimalM i o a +extendActiveSubstBD (BD b decls) v cont = undefined -- extendActiveSubst b v cont + extendActiveEffs :: Effect SimpIR o -> PrimalM i o a -> PrimalM i o a extendActiveEffs eff = local \primals -> primals { activeEffs = extendEffRow (eSetSingleton eff) (activeEffs primals)} @@ -169,7 +171,7 @@ isActive e = do vs <- (S.fromList . map atomVarName . activeVars) <$> getActivePrimals return $ any (`S.member` vs) (freeAtomVarsList e) --- === converision between monadic and reified version of functions === +-- === conversion between monadic and reified version of functions === tangentFunAsLambda :: Emits o @@ -181,10 +183,10 @@ tangentFunAsLambda cont = do buildLamExpr tangentTys \tangentVars -> do liftTangentM (TangentArgs $ map sink tangentVars) cont -getTangentArgTys :: (Fallible1 m, EnvExtender m) => [SAtomVar n] -> m n (EmptyAbs (Nest SBinder) n) +getTangentArgTys :: (Fallible1 m, EnvExtender m) => [SAtomVar n] -> m n (EmptyAbs SBinders n) getTangentArgTys topVs = go mempty topVs where go :: (Fallible1 m, EnvExtender m) - => EMap SAtomName SAtomVar n -> [SAtomVar n] -> m n (EmptyAbs (Nest SBinder) n) + => EMap SAtomName SAtomVar n -> [SAtomVar n] -> m n (EmptyAbs SBinders n) go _ [] = return $ EmptyAbs Empty go heapMap (v:vs) = case getType v of -- This is a hack to handle heaps/references. They normally come in pairs @@ -195,7 +197,7 @@ getTangentArgTys topVs = go mempty topVs where withFreshBinder (getNameHint v) (TC HeapType) \hb -> do let newHeapMap = sink heapMap <> eMapSingleton (sink (atomVarName v)) (binderVar hb) Abs bs UnitE <- go newHeapMap $ sinkList vs - return $ EmptyAbs $ Nest hb bs + return $ EmptyAbs $ Nest (PlainBD hb) bs RefTy (Var h) referentTy -> do case lookupEMap heapMap (atomVarName h) of Nothing -> error "shouldn't happen?" @@ -204,12 +206,12 @@ getTangentArgTys topVs = go mempty topVs where let refTy = RefTy (Var h') tt withFreshBinder (getNameHint v) refTy \refb -> do Abs bs UnitE <- go (sink heapMap) $ sinkList vs - return $ EmptyAbs $ Nest refb bs + return $ EmptyAbs $ Nest (PlainBD refb) bs ty -> do tt <- tangentType ty withFreshBinder (getNameHint v) tt \b -> do Abs bs UnitE <- go (sink heapMap) $ sinkList vs - return $ EmptyAbs $ Nest b bs + return $ EmptyAbs $ Nest (PlainBD b) bs class ReconFunctor (f :: E -> E) where capture @@ -232,11 +234,12 @@ data ObligateReconAbs (e::E) (n::S) = ObligateRecon (SType n) (ReconAbs SimpIR e n) instance ReconFunctor MaybeReconAbs where - capture locals original toCapture = do - (reconVal, recon) <- telescopicCapture locals toCapture - case recon of - Abs (ReconBinders _ Empty) toCapture' -> return (original, TrivialRecon toCapture') - _ -> return (PairVal original reconVal, ReconWithData recon) + capture locals original toCapture = undefined + -- capture locals original toCapture = do + -- (reconVal, recon) <- telescopicCapture locals toCapture + -- case recon of + -- Abs (ReconBinders _ Empty) toCapture' -> return (original, TrivialRecon toCapture') + -- _ -> return (PairVal original reconVal, ReconWithData recon) reconstruct primalAux recon = case recon of TrivialRecon linLam -> return (primalAux, linLam) @@ -246,11 +249,12 @@ instance ReconFunctor MaybeReconAbs where return (primal, linLam') instance ReconFunctor ObligateReconAbs where - capture locals original toCapture = do - (reconVal, recon) <- telescopicCapture locals toCapture - -- TODO: telescopicCapture should probably return the hoisted type - reconValTy <- return $ ignoreHoistFailure $ hoist locals $ getType reconVal - return (PairVal original reconVal, ObligateRecon reconValTy recon) + capture locals original toCapture = undefined + -- capture locals original toCapture = do + -- (reconVal, recon) <- telescopicCapture locals toCapture + -- -- TODO: telescopicCapture should probably return the hoisted type + -- reconValTy <- return $ ignoreHoistFailure $ hoist locals $ getType reconVal + -- return (PairVal original reconVal, ObligateRecon reconValTy recon) reconstruct primalAux recon = case recon of ObligateRecon _ reconAbs -> do @@ -276,9 +280,9 @@ linearizeBlockDefuncGeneral locals block = do -- Inverse of tangentFunAsLambda. Should be used inside a returned tangent action. applyLinLam :: Emits o => SLam i -> SubstReaderT AtomSubstVal TangentM i o (Atom SimpIR o) -applyLinLam (LamExpr bs body) = do +applyLinLam lam = do TangentArgs args <- liftSubstReaderT $ getTangentArgs - extendSubst (bs @@> ((Rename . atomVarName) <$> args)) do + withInstantiated lam (Var <$> args) \body -> substM body >>= emitBlock -- === actual linearization passs === @@ -289,29 +293,30 @@ linearize f x = runPrimalMInit $ linearizeLambdaApp f x {-# SCC linearize #-} linearizeTopLam :: STopLam n -> [Active] -> DoubleBuilder SimpIR n (STopLam n, STopLam n) -linearizeTopLam (TopLam False _ (LamExpr bs body)) actives = do - (primalFun, tangentFun) <- runPrimalMInit $ refreshBinders bs \bs' frag -> extendSubst frag do - let allPrimals = bindersVars bs' - activeVs <- catMaybes <$> forM (zip actives allPrimals) \(active, v) -> case active of - True -> return $ Just v - False -> return $ Nothing - (body', linLamAbs) <- extendActivePrimalss activeVs do - linearizeBlockDefuncGeneral emptyOutFrag body - let primalFun = LamExpr bs' body' - ObligateRecon ty (Abs bsRecon (LamExpr bsTangent tangentBody)) <- return linLamAbs - tangentFun <- withFreshBinder "residuals" ty \bResidual -> do - xs <- unpackTelescope bsRecon $ Var $ binderVar bResidual - Abs bsTangent' UnitE <- applySubst (bsRecon @@> map SubstVal xs) (Abs bsTangent UnitE) - tangentTy <- ProdTy <$> typesFromNonDepBinderNest bsTangent' - withFreshBinder "t" tangentTy \bTangent -> do - tangentBody' <- buildBlock do - ts <- getUnpacked $ Var $ sink $ binderVar bTangent - let substFrag = bsRecon @@> map (SubstVal . sink) xs - <.> bsTangent @@> map (SubstVal . sink) ts - emitBlock =<< applySubst substFrag tangentBody - return $ LamExpr (bs' >>> BinaryNest bResidual bTangent) tangentBody' - return (primalFun, tangentFun) - (,) <$> asTopLam primalFun <*> asTopLam tangentFun +linearizeTopLam (TopLam False _ (LamExpr bs body)) actives = undefined +-- linearizeTopLam (TopLam False _ (LamExpr bs body)) actives = do +-- (primalFun, tangentFun) <- runPrimalMInit $ refreshBinders bs \bs' frag -> extendSubst frag do +-- let allPrimals = bindersVars bs' +-- activeVs <- catMaybes <$> forM (zip actives allPrimals) \(active, v) -> case active of +-- True -> return $ Just v +-- False -> return $ Nothing +-- (body', linLamAbs) <- extendActivePrimalss activeVs do +-- linearizeBlockDefuncGeneral emptyOutFrag body +-- let primalFun = LamExpr bs' body' +-- ObligateRecon ty (Abs bsRecon (LamExpr bsTangent tangentBody)) <- return linLamAbs +-- tangentFun <- withFreshBinder "residuals" ty \bResidual -> do +-- xs <- unpackTelescope bsRecon $ Var $ binderVar bResidual +-- Abs bsTangent' UnitE <- applySubst (bsRecon @@> map SubstVal xs) (Abs bsTangent UnitE) +-- tangentTy <- ProdTy <$> typesFromNonDepBinderNest bsTangent' +-- withFreshBinder "t" tangentTy \bTangent -> do +-- tangentBody' <- buildBlock do +-- ts <- getUnpacked $ Var $ sink $ binderVar bTangent +-- let substFrag = bsRecon @@> map (SubstVal . sink) xs +-- <.> (fmapNest (\(BD b) -> b) bsTangent) @@> map (SubstVal . sink) ts +-- emitBlock =<< applySubst substFrag tangentBody +-- return $ LamExpr (bs' >>> BinaryNest (PlainBD bResidual) (PlainBD bTangent)) tangentBody' +-- return (primalFun, tangentFun) +-- (,) <$> asTopLam primalFun <*> asTopLam tangentFun linearizeTopLam (TopLam True _ _) _ = error "expected a non-destination-passing function" -- reify the tangent builder as a lambda @@ -334,12 +339,6 @@ linearizeAtom atom = case atom of Con con -> linearizePrimCon con DepPair _ _ _ -> notImplemented PtrVar _ _ -> emitZeroT - ProjectElt _ i x -> do - WithTangent x' tx <- linearizeAtom x - xi <- normalizeProj i x' - return $ WithTangent xi do - t <- tx - normalizeProj i t RepValAtom _ -> emitZeroT where emitZeroT = withZeroT $ renameM atom @@ -428,6 +427,12 @@ linearizeExpr expr = case expr of ty' <- renameM ty seqLin (map linearizeAtom xs) `bindLin` \(ComposeE xs') -> emitExpr $ TabCon Nothing (sink ty') xs' + ProjectElt _ i x -> undefined + -- WithTangent x' tx <- linearizeAtom x + -- xi <- normalizeProj i x' + -- return $ WithTangent xi do + -- t <- tx + -- normalizeProj i t linearizeOp :: Emits o => PrimOp SimpIR i -> LinM i o SAtom SAtom linearizeOp op = case op of @@ -659,11 +664,11 @@ linearizeHof hof = case hof of linearizeEffectFun :: RWS -> SLam i -> PrimalM i o (SLam o, LinLamAbs o) linearizeEffectFun rws (BinaryLamExpr hB refB body) = do withFreshBinder noHint (TC HeapType) \h -> do - bTy <- extendSubst (hB@>binderName h) $ renameM $ binderType refB + bTy <- extendSubstBD hB [binderName h] $ renameM $ binderType refB withFreshBinder noHint bTy \b -> do let ref = binderVar b hVar <- sinkM $ binderVar h - (body', linLam) <- extendActiveSubst hB hVar $ extendActiveSubst refB ref $ + (body', linLam) <- extendActiveSubstBD hB hVar $ extendActiveSubstBD refB ref $ -- TODO: maybe we should check whether we need to extend the active effects extendActiveEffs (RWSEffect rws (Var hVar)) do linearizeBlockDefunc body @@ -671,7 +676,7 @@ linearizeEffectFun rws (BinaryLamExpr hB refB body) = do -- ensures that such references can never be *used* once the effect runner -- returns, but technically it's legal to return them. let linLam' = ignoreHoistFailure $ hoist (PairB h b) linLam - return (BinaryLamExpr h b body', linLam') + return (BinaryLamExpr (PlainBD h) (PlainBD b) body', linLam') linearizeEffectFun _ _ = error "expect effect function to be a binary lambda" withT :: PrimalM i o (e1 o) diff --git a/src/lib/Lower.hs b/src/lib/Lower.hs index 0c441b298..6dec28625 100644 --- a/src/lib/Lower.hs +++ b/src/lib/Lower.hs @@ -21,7 +21,6 @@ import Unsafe.Coerce import Builder import Core import Imp -import CheapReduction import IRVariants import Name import Subst @@ -29,6 +28,7 @@ import QueryType import Types.Core import Types.Primitives import Util (enumerate) +import Visitor -- === For loop resolution === @@ -64,12 +64,12 @@ type DestBlock = Abs (SBinder) SBlock lowerFullySequential :: EnvReader m => Bool -> STopLam n -> m n (STopLam n) lowerFullySequential wantDestStyle (TopLam False piTy (LamExpr bs body)) = liftEnvReaderM $ do lam <- case wantDestStyle of - True -> do - refreshAbs (Abs bs body) \bs' body' -> do - xs <- bindersToAtoms bs' - EffTy _ resultTy <- instantiate (sink piTy) xs - Abs b body'' <- lowerFullySequentialBlock resultTy body' - return $ LamExpr (bs' >>> UnaryNest b) body'' + -- True -> do + -- refreshAbs (Abs bs body) \bs' body' -> do + -- let xs = Var <$> bindersVars bs' + -- EffTy _ resultTy <- instantiate piTy xs + -- Abs b body'' <- lowerFullySequentialBlock resultTy body' + -- return $ LamExpr (bs' >>> UnaryNest (PlainBD b)) body'' False -> do refreshAbs (Abs bs body) \bs' body' -> do body'' <- lowerFullySequentialBlockNoDest body' @@ -143,7 +143,7 @@ lowerFor ansTy maybeDest dir ixTy (UnaryLamExpr (ib:>ty) body) = do let destTy = getType initDest body' <- buildUnaryLamExpr noHint (PairTy ty' destTy) \b' -> do (i, destProd) <- fromPair $ Var b' - dest <- normalizeProj (ProjectProduct 0) destProd + dest <- getProj 0 destProd idest <- emitOp =<< mkIndexRef dest i extendSubst (ib @> SubstVal i) $ lowerBlockWithDest idest body $> UnitVal ans <- emitSeq dir ixTy' initDest body' >>= getProj 0 @@ -237,12 +237,13 @@ lookupDest = flip lookupNameMap -- -- XXX: When adding more cases, be careful about potentially repeated vars in the output! decomposeDest :: Emits o => Dest SimpIR o -> SAtom i' -> LowerM i o (Maybe (DestAssignment i' o)) -decomposeDest dest = \case - Var v -> return $ Just $ singletonNameMap (atomVarName v) $ FullDest dest - ProjectElt _ p x -> do - (ps, v) <- return $ asNaryProj p x - return $ Just $ singletonNameMap (atomVarName v) $ ProjDest ps dest - _ -> return Nothing +decomposeDest dest = undefined +-- decomposeDest dest = \case +-- Var v -> return $ Just $ singletonNameMap (atomVarName v) $ FullDest dest +-- ProjectElt _ p x -> do +-- (ps, v) <- return $ asNaryProj p x +-- return $ Just $ singletonNameMap (atomVarName v) $ ProjDest ps dest +-- _ -> return Nothing lowerBlockWithDest :: Emits o => Dest SimpIR o -> SBlock i -> LowerM i o (SAtom o) lowerBlockWithDest dest (Abs decls ans) = do @@ -323,13 +324,13 @@ lowerExprWithDest dest expr = case expr of :: SType o -> LamExpr SimpIR i -> (Maybe (Dest SimpIR o) -> LamExpr SimpIR o -> LowerM i o (Hof SimpIR o)) -> LowerM i o (SExpr o) - traverseRWS referentTy (LamExpr (BinaryNest hb rb) body) cont = do + traverseRWS referentTy lam@(LamExpr (BinaryNest _ rb) _) cont = do unpackRWSDest dest >>= \case Nothing -> generic Just (bodyDest, refDest) -> do hof <- cont refDest =<< buildEffLam (getNameHint rb) referentTy \hb' rb' -> - extendRenamer (hb@>atomVarName hb' <.> rb@>atomVarName rb') do + withInstantiated lam [Var hb', Var rb'] \body -> case bodyDest of Nothing -> lowerBlock body Just bd -> lowerBlockWithDest (sink bd) body @@ -349,11 +350,12 @@ lowerExprWithDest dest expr = case expr of ProjDest _ _ -> return Nothing place :: Emits o => ProjDest o -> SAtom o -> LowerM i o () -place pd x = case pd of - FullDest d -> void $ emitOp $ DAMOp $ Place d x - ProjDest p d -> do - x' <- normalizeNaryProj (NE.toList p) x - void $ emitOp $ DAMOp $ Place d x' +place pd x = undefined +-- place pd x = case pd of +-- FullDest d -> void $ emitOp $ DAMOp $ Place d x +-- ProjDest p d -> do +-- x' <- normalizeNaryProj (NE.toList p) x +-- void $ emitOp $ DAMOp $ Place d x' -- === Extensions to the name system === diff --git a/src/lib/OccAnalysis.hs b/src/lib/OccAnalysis.hs index bff364f47..eb61f6768 100644 --- a/src/lib/OccAnalysis.hs +++ b/src/lib/OccAnalysis.hs @@ -12,7 +12,6 @@ import Data.Maybe (fromMaybe) import Control.Monad.Reader.Class import Core -import CheapReduction import IRVariants import Name import MTL1 @@ -21,6 +20,7 @@ import Occurrence qualified as Occ import Types.Core import Types.Primitives import QueryType +import Visitor -- === External API === @@ -239,7 +239,6 @@ instance HasOCC SAtom where modify (<> FV (singletonNameMapE n $ AccessInfo One a)) ty' <- occTy ty return $ Var (AtomVar n ty') - ProjectElt t i x -> ProjectElt <$> occ a t <*> pure i <*> occ a x atom -> runOCCMVisitor a $ visitAtomPartial atom instance HasOCC SType where @@ -451,12 +450,13 @@ instance HasOCC (Hof SimpIR) where oneShot :: Access n -> [IxExpr n] -> LamExpr SimpIR n -> OCCM n (LamExpr SimpIR n) oneShot acc [] (LamExpr Empty body) = LamExpr Empty <$> occNest acc body -oneShot acc (ix:ixs) (LamExpr (Nest b bs) body) = do - occWithBinder (Abs b (LamExpr bs body)) \b' restLam -> - extend b' (sink ix) do - LamExpr bs' body' <- oneShot (sink acc) (map sink ixs) restLam - return $ LamExpr (Nest b' bs') body' -oneShot _ _ _ = error "zip error" +oneShot acc (ix:ixs) (LamExpr (Nest _ bs) body) = undefined +-- oneShot acc (ix:ixs) (LamExpr (Nest (BD b) bs) body) = do +-- occWithBinder (Abs b (LamExpr bs body)) \b' restLam -> +-- extend b' (sink ix) do +-- LamExpr bs' body' <- oneShot (sink acc) (map sink ixs) restLam +-- return $ LamExpr (Nest (BD b') bs') body' +-- oneShot _ _ _ = error "zip error" -- Going under a lambda binder. occWithBinder diff --git a/src/lib/Optimize.hs b/src/lib/Optimize.hs index e4331e484..5162c0054 100644 --- a/src/lib/Optimize.hs +++ b/src/lib/Optimize.hs @@ -14,6 +14,7 @@ import Data.Word import Data.Bits import Data.Bits.Floating import Data.List +import Control.Category ((>>>)) import Control.Monad import Control.Monad.State.Strict import GHC.Float @@ -25,11 +26,11 @@ import Name import Subst import IRVariants import Core -import CheapReduction import Builder import QueryType import Util (iota) import Err +import Visitor optimize :: EnvReader m => STopLam n -> m n (STopLam n) optimize = dceTop -- Clean up user code @@ -258,8 +259,8 @@ ulExpr expr = case expr of extendSubst (b' @> SubstVal (IdxRepVal i)) $ emitSubstBlock block' inc $ fromIntegral n -- To account for the TabCon we emit below getLamExprType body' >>= \case - PiType (UnaryNest (tb:>_)) (EffTy _ valTy) -> do - let tabTy = TabPi $ TabPiType (IxDictRawFin (IdxRepVal n)) (tb:>IdxRepTy) valTy + PiType (UnaryNest tb) (EffTy _ valTy) -> do + let tabTy = TabPi $ TabPiType (IxDictRawFin (IdxRepVal n)) tb valTy emitExpr $ TabCon Nothing tabTy vals _ -> error "Expected `for` body to have a Pi type" _ -> error "Expected `for` body to be a lambda expression" @@ -311,56 +312,57 @@ hoistLoopInvariant = liftLamExpr hoistLoopInvariantBlock licmExpr :: Emits o => SExpr i -> LICMM i o (SAtom o) licmExpr = \case - PrimOp (DAMOp (Seq _ dir ix (ProdVal dests) (LamExpr (UnaryNest b) body))) -> do - ix' <- substM ix - dests' <- mapM visitAtom dests - let numCarriesOriginal = length dests' - Abs hdecls destsAndBody <- visitBinders (UnaryNest b) \(UnaryNest b') -> do - -- First, traverse the block, to allow any Hofs inside it to hoist their own decls. - Abs decls ans <- buildBlock $ visitBlockEmits body - -- Now, we process the decls and decide which ones to hoist. - liftEnvReaderM $ runSubstReaderT idSubst $ - seqLICM REmpty mempty (asNameBinder b') REmpty decls ans - PairE (ListE extraDests) ab <- emitDecls $ Abs hdecls destsAndBody - extraDests' <- mapM toAtomVar extraDests - -- Append the destinations of hoisted Allocs as loop carried values. - let dests'' = ProdVal $ dests' ++ (Var <$> extraDests') - let carryTy = getType dests'' - let lbTy = case ix' of IxType ixTy _ -> PairTy ixTy carryTy - extraDestsTyped <- forM extraDests' \(AtomVar d t) -> return (d, t) - Abs extraDestBs (Abs lb bodyAbs) <- return $ abstractFreeVars extraDestsTyped ab - body' <- withFreshBinder noHint lbTy \lb' -> do - (oldIx, allCarries) <- fromPair $ Var $ binderVar lb' - (oldCarries, newCarries) <- splitAt numCarriesOriginal <$> getUnpacked allCarries - let oldLoopBinderVal = PairVal oldIx (ProdVal oldCarries) - let s = extraDestBs @@> map SubstVal newCarries <.> lb @> SubstVal oldLoopBinderVal - block <- applySubst s bodyAbs - return $ UnaryLamExpr lb' block - emitSeq dir ix' dests'' body' + PrimOp (DAMOp (Seq _ dir ix (ProdVal dests) (LamExpr (UnaryNest b) body))) -> undefined + -- PrimOp (DAMOp (Seq _ dir ix (ProdVal dests) (LamExpr (UnaryNest b) body))) -> do + -- ix' <- substM ix + -- dests' <- mapM visitAtom dests + -- let numCarriesOriginal = length dests' + -- Abs hdecls destsAndBody <- visitBinders (UnaryNest b) \(UnaryNest b') -> do + -- -- First, traverse the block, to allow any Hofs inside it to hoist their own decls. + -- Abs decls ans <- buildBlock $ visitBlockEmits body + -- -- Now, we process the decls and decide which ones to hoist. + -- liftEnvReaderM $ runSubstReaderT idSubst $ + -- seqLICM REmpty mempty b' REmpty decls ans + -- PairE (ListE extraDests) ab <- emitDecls $ Abs hdecls destsAndBody + -- extraDests' <- mapM toAtomVar extraDests + -- -- Append the destinations of hoisted Allocs as loop carried values. + -- let dests'' = ProdVal $ dests' ++ (Var <$> extraDests') + -- let carryTy = getType dests'' + -- let lbTy = case ix' of IxType ixTy _ -> PairTy ixTy carryTy + -- extraDestsTyped <- forM extraDests' \(AtomVar d t) -> return (d, t) + -- Abs extraDestBs (Abs lb bodyAbs) <- return $ abstractFreeVars extraDestsTyped ab + -- let extraDestBs' = fmapNest PlainBD extraDestBs + -- body' <- withFreshBinder noHint lbTy \lb' -> do + -- (oldIx, allCarries) <- fromPair $ Var $ binderVar lb' + -- (oldCarries, newCarries) <- splitAt numCarriesOriginal <$> getUnpacked allCarries + -- let oldLoopBinderVal = PairVal oldIx (ProdVal oldCarries) + -- block <- instantiate (Abs (extraDestBs' >>> UnaryNest lb) bodyAbs) (newCarries <> [oldLoopBinderVal]) + -- return $ UnaryLamExpr lb' block + -- emitSeq dir ix' dests'' body' PrimOp (Hof (TypedHof _ (For dir ix (LamExpr (UnaryNest b) body)))) -> do ix' <- substM ix Abs hdecls destsAndBody <- visitBinders (UnaryNest b) \(UnaryNest b') -> do Abs decls ans <- buildBlock $ visitBlockEmits body liftEnvReaderM $ runSubstReaderT idSubst $ - seqLICM REmpty mempty (asNameBinder b') REmpty decls ans + seqLICM REmpty mempty b' REmpty decls ans PairE (ListE []) (Abs lnb bodyAbs) <- emitDecls $ Abs hdecls destsAndBody ixTy <- substM $ binderType b body' <- withFreshBinder noHint ixTy \i -> do - block <- applyRename (lnb@>binderName i) bodyAbs + block <- instantiateNames (Abs lnb bodyAbs) [binderName i] return $ UnaryLamExpr i block emitHof $ For dir ix' body' expr -> visitGeneric expr >>= emitExpr seqLICM :: RNest SDecl n1 n2 -- hoisted decls -> [SAtomName n2] -- hoisted dests - -> AtomNameBinder SimpIR n2 n3 -- loop binder + -> BinderAndDecls SimpIR n2 n3 -- loop binder -> RNest SDecl n3 n4 -- loop-dependent decls -> Nest SDecl m1 m2 -- decls remaining to process -> SAtom m2 -- loop result -> SubstReaderT AtomSubstVal EnvReaderM m1 n4 (Abs (Nest SDecl) -- hoisted decls (PairE (ListE SAtomName) -- hoisted allocs (these should go in the loop carry) - (Abs (AtomNameBinder SimpIR) -- loop binder + (Abs (BinderAndDecls SimpIR) -- loop binder (Abs (Nest SDecl) -- non-hoisted decls SAtom))) n1) -- final result seqLICM !top !topDestNames !lb !reg decls ans = case decls of @@ -426,7 +428,6 @@ instance Color c => HasDCE (Name c) where instance HasDCE SAtom where dce = \case Var n -> modify (<> FV (freeVarsE n)) $> Var n - ProjectElt t i x -> ProjectElt <$> dce t <*> pure i <*> dce x atom -> visitAtomPartial atom instance HasDCE SType where dce = visitTypePartial diff --git a/src/lib/PPrint.hs b/src/lib/PPrint.hs index 23bc7ea60..235a14836 100644 --- a/src/lib/PPrint.hs +++ b/src/lib/PPrint.hs @@ -41,7 +41,7 @@ import Types.Imp import Types.Misc import Types.Primitives import Types.Source -import QueryTypePure +import QueryType import Util (Tree (..)) -- A DocPrec is a slightly context-aware Doc, specifically one that @@ -159,6 +159,10 @@ instance PrettyPrec a => PrettyPrec [a] where instance PrettyE ann => Pretty (BinderP c ann n l) where pretty (b:>ty) = p b <> ":" <> p ty +instance IRRep r => Pretty (BinderAndDecls r n l) where + pretty (BD b Empty) = pretty b + pretty (BD b ds) = pretty b <> pretty ds + instance IRRep r => Pretty (Expr r n) where pretty = prettyFromPrettyPrec instance IRRep r => PrettyPrec (Expr r n) where prettyPrec (Atom x) = prettyPrec x @@ -169,6 +173,8 @@ instance IRRep r => PrettyPrec (Expr r n) where prettyPrec (TabCon _ _ es) = atPrec ArgPrec $ list $ pApp <$> es prettyPrec (PrimOp op) = prettyPrec op prettyPrec (ApplyMethod _ d i xs) = atPrec AppPrec $ "applyMethod" <+> p d <+> p i <+> p xs + prettyPrec (ProjectElt _ idxs v) = atPrec LowestPrec $ "ProjectElt" <+> p idxs <+> p v + prettyPrec (DictHole _ e _) = atPrec LowestPrec $ "synthesize" <+> pApp e prettyPrecCase :: IRRep r => Doc ann -> Atom r n -> [Alt r n] -> EffectRow r n -> DocPrec ann prettyPrecCase name e alts effs = atPrec LowestPrec $ @@ -251,10 +257,8 @@ instance IRRep r => PrettyPrec (Atom r n) where PtrVar _ v -> atPrec ArgPrec $ p v DictCon _ d -> atPrec LowestPrec $ p d RepValAtom x -> atPrec LowestPrec $ pretty x - ProjectElt _ idxs v -> atPrec LowestPrec $ "ProjectElt" <+> p idxs <+> p v NewtypeCon con x -> prettyPrecNewtype con x SimpInCore x -> prettyPrec x - DictHole _ e _ -> atPrec LowestPrec $ "synthesize" <+> pApp e TypeAsAtom ty -> prettyPrec ty instance IRRep r => Pretty (Type r n) where pretty = prettyFromPrettyPrec @@ -267,8 +271,6 @@ instance IRRep r => PrettyPrec (Type r n) where DictTy t -> atPrec LowestPrec $ p t NewtypeTyCon con -> prettyPrec con TyVar v -> atPrec ArgPrec $ p v - ProjectEltTy _ idxs v -> - atPrec LowestPrec $ "ProjectElt" <+> p idxs <+> p v instance Pretty (SimpInCore n) where pretty = prettyFromPrettyPrec instance PrettyPrec (SimpInCore n) where @@ -324,16 +326,16 @@ withExplParens (Inferred _ Unify) x = braces $ x withExplParens (Inferred _ (Synth _)) x = brackets x instance IRRep r => Pretty (TabPiType r n) where - pretty (TabPiType dict (b:>ty) body) = let + pretty (TabPiType dict (BD (b:>ty) ds) body) = let prettyBody = case body of Pi subpi -> pretty subpi _ -> pLowest body prettyBinder = case dict of - IxDictRawFin n -> if binderName b `isFreeIn` body + IxDictRawFin n -> if binderName b `isFreeIn` (Abs ds body) then parens $ p b <> ":" <> prettyTy else prettyTy where prettyTy = "RawFin" <+> p n - _ -> prettyBinderHelper (b:>ty) body + _ -> prettyBinderHelper (b:>ty) (Abs ds body) in prettyBinder <> prettyIxDict dict <> (group $ line <> "=>" <+> prettyBody) -- A helper to let us turn dict printing on and off. We mostly want it off to diff --git a/src/lib/QueryType.hs b/src/lib/QueryType.hs index 50a976816..eedce70fd 100644 --- a/src/lib/QueryType.hs +++ b/src/lib/QueryType.hs @@ -1,430 +1,315 @@ --- Copyright 2022 Google LLC +-- Copyright 2023 Google LLC -- -- Use of this source code is governed by a BSD-style -- license that can be found in the LICENSE file or at -- https://developers.google.com/open-source/licenses/bsd -module QueryType (module QueryType, module QueryTypePure, toAtomVar) where - -import Control.Category ((>>>)) -import Control.Monad -import Data.List (elemIndex) -import Data.Functor ((<&>)) +module QueryType where import Types.Primitives import Types.Core -import Types.Source -import Types.Imp import IRVariants -import Core -import Err -import Name hiding (withFreshM) -import Subst -import Util -import PPrint () -import QueryTypePure -import CheapReduction - -sourceNameType :: (EnvReader m, Fallible1 m) => SourceName -> m n (Type CoreIR n) -sourceNameType v = do - lookupSourceMap v >>= \case - Nothing -> throw UnboundVarErr $ pprint v - Just uvar -> getUVarType uvar - --- === Exposed helpers for querying types and effects === - -caseAltsBinderTys :: (EnvReader m, IRRep r) => Type r n -> m n [Type r n] -caseAltsBinderTys ty = case ty of - SumTy types -> return types - NewtypeTyCon t -> case t of - UserADTType _ defName params -> do - def <- lookupTyCon defName - ~(ADTCons cons) <- instantiateTyConDef def params - return [repTy | DataConDef _ _ repTy _ <- cons] - _ -> error msg - _ -> error msg - where msg = "Case analysis only supported on ADTs, not on " ++ pprint ty - -extendEffect :: IRRep r => Effect r n -> EffectRow r n -> EffectRow r n -extendEffect eff (EffectRow effs t) = EffectRow (effs <> eSetSingleton eff) t - -blockEffTy :: (EnvReader m, IRRep r) => Block r n -> m n (EffTy r n) -blockEffTy block = liftEnvReaderM $ refreshAbs block \decls result -> do - effs <- declsEffects decls mempty - return $ ignoreHoistFailure $ hoist decls $ EffTy effs $ getType result - where - declsEffects :: IRRep r => Nest (Decl r) n l -> EffectRow r l -> EnvReaderM l (EffectRow r l) - declsEffects Empty !acc = return acc - declsEffects n@(Nest (Let _ (DeclBinding _ expr)) rest) !acc = withExtEvidence n do - expr' <- sinkM expr - declsEffects rest $ acc <> getEffects expr' - -blockTy :: (EnvReader m, IRRep r) => Block r n -> m n (Type r n) -blockTy b = blockEffTy b <&> \(EffTy _ t) -> t - -piTypeWithoutDest :: PiType SimpIR n -> PiType SimpIR n -piTypeWithoutDest (PiType bsRefB _) = - case popNest bsRefB of - Just (PairB bs (_:>RawRefTy ansTy)) -> do - PiType bs $ EffTy Pure ansTy -- XXX: we ignore the effects here - _ -> error "expected trailing dest binder" - -blockEff :: (EnvReader m, IRRep r) => Block r n -> m n (EffectRow r n) -blockEff b = blockEffTy b <&> \(EffTy eff _) -> eff - -typeOfApp :: (IRRep r, EnvReader m) => Type r n -> [Atom r n] -> m n (Type r n) -typeOfApp (Pi piTy) xs = withSubstReaderT $ - withInstantiated piTy xs \(EffTy _ ty) -> substM ty -typeOfApp _ _ = error "expected a pi type" - -typeOfTabApp :: (IRRep r, EnvReader m) => Type r n -> [Atom r n] -> m n (Type r n) -typeOfTabApp t [] = return t -typeOfTabApp (TabPi tabTy) (i:rest) = do - resultTy <- instantiate tabTy [i] - typeOfTabApp resultTy rest -typeOfTabApp ty _ = error $ "expected a table type. Got: " ++ pprint ty - -typeOfApplyMethod :: EnvReader m => CAtom n -> Int -> [CAtom n] -> m n (EffTy CoreIR n) -typeOfApplyMethod d i args = do - ty <- Pi <$> getMethodType d i - appEffTy ty args - -typeOfDictExpr :: EnvReader m => DictExpr n -> m n (CType n) -typeOfDictExpr e = liftM ignoreExcept $ liftEnvReaderT $ case e of - InstanceDict instanceName args -> do - instanceDef@(InstanceDef className _ _ _ _) <- lookupInstanceDef instanceName - sourceName <- getSourceName <$> lookupClassDef className - PairE (ListE params) _ <- instantiate instanceDef args - return $ DictTy $ DictType sourceName className params - InstantiatedGiven given args -> typeOfApp (getType given) args - SuperclassProj d i -> do - DictTy (DictType _ className params) <- return $ getType d - classDef <- lookupClassDef className - withSubstReaderT $ withInstantiated classDef params \(Abs superclasses _) -> do - substM $ getSuperclassType REmpty superclasses i - IxFin n -> liftM DictTy $ ixDictType $ NewtypeTyCon $ Fin n - DataData ty -> DictTy <$> dataDictType ty - -typeOfTopApp :: EnvReader m => TopFunName n -> [SAtom n] -> m n (EffTy SimpIR n) -typeOfTopApp f xs = do - piTy <- getTypeTopFun f - instantiate piTy xs - -typeOfIndexRef :: (EnvReader m, Fallible1 m, IRRep r) => Type r n -> Atom r n -> m n (Type r n) -typeOfIndexRef (TC (RefType h s)) i = do - TabPi tabPi <- return s - eltTy <- instantiate tabPi [i] - return $ TC $ RefType h eltTy -typeOfIndexRef _ _ = error "expected a ref type" - -typeOfProjRef :: EnvReader m => Type r n -> Projection -> m n (Type r n) -typeOfProjRef (TC (RefType h s)) p = do - TC . RefType h <$> case p of - ProjectProduct i -> do - ~(ProdTy tys) <- return s - return $ tys !! i - UnwrapNewtype -> do - case s of - NewtypeTyCon tc -> snd <$> unwrapNewtypeType tc - _ -> error "expected a newtype" -typeOfProjRef _ _ = error "expected a reference" - -appEffTy :: (IRRep r, EnvReader m) => Type r n -> [Atom r n] -> m n (EffTy r n) -appEffTy (Pi piTy) xs = instantiate piTy xs -appEffTy t _ = error $ "expected a pi type, got: " ++ pprint t - -partialAppType :: (IRRep r, EnvReader m) => Type r n -> [Atom r n] -> m n (Type r n) -partialAppType (Pi (CorePiType appExpl expls bs effTy)) xs = do - (_, expls2) <- return $ splitAt (length xs) expls - PairB bs1 bs2 <- return $ splitNestAt (length xs) bs - instantiate (Abs bs1 (Pi $ CorePiType appExpl expls2 bs2 effTy)) xs -partialAppType _ _ = error "expected a pi type" - -effTyOfHof :: (EnvReader m, IRRep r) => Hof r n -> m n (EffTy r n) -effTyOfHof hof = EffTy <$> hofEffects hof <*> typeOfHof hof - -typeOfHof :: (EnvReader m, IRRep r) => Hof r n -> m n (Type r n) -typeOfHof = \case - For _ ixTy f -> getLamExprType f >>= \case - PiType (UnaryNest b) (EffTy _ eltTy) -> return $ TabTy (ixTypeDict ixTy) b eltTy - _ -> error "expected a unary pi type" - While _ -> return UnitTy - Linearize f _ -> getLamExprType f >>= \case - PiType (UnaryNest (binder:>a)) (EffTy Pure b) -> do - let b' = ignoreHoistFailure $ hoist binder b - let fLinTy = Pi $ nonDepPiType [a] Pure b' - return $ PairTy b' fLinTy - _ -> error "expected a unary pi type" - Transpose f _ -> getLamExprType f >>= \case - PiType (UnaryNest (_:>a)) _ -> return a - _ -> error "expected a unary pi type" - RunReader _ f -> do - (resultTy, _) <- getTypeRWSAction f - return resultTy - RunWriter _ _ f -> uncurry PairTy <$> getTypeRWSAction f - RunState _ _ f -> do - (resultTy, stateTy) <- getTypeRWSAction f - return $ PairTy resultTy stateTy - RunIO f -> blockTy f - RunInit f -> blockTy f - CatchException ty _ -> return ty - -hofEffects :: (EnvReader m, IRRep r) => Hof r n -> m n (EffectRow r n) -hofEffects = \case - For _ _ f -> functionEffs f - While body -> blockEff body - Linearize _ _ -> return Pure -- Body has to be a pure function - Transpose _ _ -> return Pure -- Body has to be a pure function - RunReader _ f -> rwsFunEffects Reader f - RunWriter d _ f -> maybeInit d <$> rwsFunEffects Writer f - RunState d _ f -> maybeInit d <$> rwsFunEffects State f - RunIO f -> deleteEff IOEffect <$> blockEff f - RunInit f -> deleteEff InitEffect <$> blockEff f - CatchException _ f -> deleteEff ExceptionEffect <$> blockEff f - where maybeInit :: IRRep r => Maybe (Atom r i) -> (EffectRow r o -> EffectRow r o) - maybeInit d = case d of Just _ -> (<>OneEffect InitEffect); Nothing -> id - -deleteEff :: IRRep r => Effect r n -> EffectRow r n -> EffectRow r n -deleteEff eff (EffectRow effs t) = EffectRow (effs `eSetDifference` eSetSingleton eff) t - -getMethodIndex :: EnvReader m => ClassName n -> SourceName -> m n Int -getMethodIndex className methodSourceName = do - ClassDef _ methodNames _ _ _ _ _ <- lookupClassDef className - case elemIndex methodSourceName methodNames of - Nothing -> error $ methodSourceName ++ " is not a method of " ++ pprint className - Just i -> return i -{-# INLINE getMethodIndex #-} - -getUVarType :: EnvReader m => UVar n -> m n (CType n) -getUVarType = \case - UAtomVar v -> getType <$> toAtomVar v - UTyConVar v -> getTyConNameType v - UDataConVar v -> getDataConNameType v - UPunVar v -> getStructDataConType v - UClassVar v -> do - ClassDef _ _ _ roleExpls bs _ _ <- lookupClassDef v - return $ Pi $ CorePiType ExplicitApp (map snd roleExpls) bs $ EffTy Pure TyKind - UMethodVar v -> getMethodNameType v - UEffectVar _ -> error "not implemented" - UEffectOpVar _ -> error "not implemented" - -getMethodNameType :: EnvReader m => MethodName n -> m n (CType n) -getMethodNameType v = liftEnvReaderM $ lookupEnv v >>= \case - MethodBinding className i -> do - ClassDef _ _ paramNames _ paramBs scBinders methodTys <- lookupClassDef className - refreshAbs (Abs paramBs $ Abs scBinders (methodTys !! i)) \paramBs' absPiTy -> do - let params = Var <$> bindersVars paramBs' - dictTy <- DictTy <$> dictType (sink className) params - withFreshBinder noHint dictTy \dictB -> do - scDicts <- getSuperclassDicts (Var $ binderVar dictB) - CorePiType appExpl methodExpls methodBs effTy <- instantiate (sink absPiTy) scDicts - let paramExpls = paramNames <&> \name -> Inferred name Unify - let expls = paramExpls <> [Inferred Nothing (Synth $ Partial $ succ i)] <> methodExpls - return $ Pi $ CorePiType appExpl expls (paramBs' >>> UnaryNest dictB >>> methodBs) effTy - -getMethodType :: EnvReader m => Dict n -> Int -> m n (CorePiType n) -getMethodType dict i = liftEnvReaderM $ withSubstReaderT do - ~(DictTy (DictType _ className params)) <- return $ getType dict - superclassDicts <- getSuperclassDicts dict - classDef <- lookupClassDef className - withInstantiated classDef params \ab -> do - withInstantiated ab superclassDicts \(ListE methodTys) -> - substM $ methodTys !! i - -getTyConNameType :: EnvReader m => TyConName n -> m n (Type CoreIR n) -getTyConNameType v = do - TyConDef _ expls bs _ <- lookupTyCon v - case bs of - Empty -> return TyKind - _ -> return $ Pi $ CorePiType ExplicitApp (snd <$> expls) bs $ EffTy Pure TyKind - -getDataConNameType :: EnvReader m => DataConName n -> m n (Type CoreIR n) -getDataConNameType dataCon = liftEnvReaderM $ withSubstReaderT do - (tyCon, i) <- lookupDataCon dataCon - tyConDef <- lookupTyCon tyCon - buildDataConType tyConDef \expls paramBs' paramVs params -> do - withInstantiatedNames tyConDef paramVs \(ADTCons dataCons) -> do - DataConDef _ ab _ _ <- renameM (dataCons !! i) - refreshAbs ab \dataBs UnitE -> do - let appExpl = case dataBs of Empty -> ImplicitApp - _ -> ExplicitApp - let resultTy = NewtypeTyCon $ UserADTType (getSourceName tyConDef) (sink tyCon) (sink params) - let dataExpls = nestToList (const $ Explicit) dataBs - return $ Pi $ CorePiType appExpl (expls <> dataExpls) (paramBs' >>> dataBs) (EffTy Pure resultTy) - -getStructDataConType :: EnvReader m => TyConName n -> m n (CType n) -getStructDataConType tyCon = liftEnvReaderM $ withSubstReaderT do - tyConDef <- lookupTyCon tyCon - buildDataConType tyConDef \expls paramBs' paramVs params -> do - withInstantiatedNames tyConDef paramVs \(StructFields fields) -> do - fieldTys <- forM fields \(_, t) -> renameM t - let resultTy = NewtypeTyCon $ UserADTType (getSourceName tyConDef) (sink tyCon) params - Abs dataBs resultTy' <- return $ typesAsBinderNest fieldTys resultTy - let dataExpls = nestToList (const Explicit) dataBs - return $ Pi $ CorePiType ExplicitApp (expls <> dataExpls) (paramBs' >>> dataBs) (EffTy Pure resultTy') - -buildDataConType - :: (EnvReader m, EnvExtender m) - => TyConDef n - -> (forall l. DExt n l => [Explicitness] -> Nest CBinder n l -> [CAtomName l] -> TyConParams l -> m l a) - -> m n a -buildDataConType (TyConDef _ roleExpls bs _) cont = do - let expls = snd <$> roleExpls - expls' <- forM expls \case - Explicit -> return $ Inferred Nothing Unify - expl -> return $ expl - refreshAbs (Abs bs UnitE) \bs' UnitE -> do - let vs = nestToNames bs' - vs' <- mapM toAtomVar vs - cont expls' bs' vs $ TyConParams expls (Var <$> vs') - -makeTyConParams :: EnvReader m => TyConName n -> [CAtom n] -> m n (TyConParams n) -makeTyConParams tc params = do - TyConDef _ expls _ _ <- lookupTyCon tc - return $ TyConParams (map snd expls) params - -getDataClassName :: (Fallible1 m, EnvReader m) => m n (ClassName n) -getDataClassName = lookupSourceMap "Data" >>= \case - Nothing -> throw CompilerErr $ "Data interface needed but not defined!" - Just (UClassVar v) -> return v - Just _ -> error "not a class var" - -dataDictType :: (Fallible1 m, EnvReader m) => CType n -> m n (DictType n) -dataDictType ty = do - dataClassName <- getDataClassName - dictType dataClassName [Type ty] - -getIxClassName :: (Fallible1 m, EnvReader m) => m n (ClassName n) -getIxClassName = lookupSourceMap "Ix" >>= \case - Nothing -> throw CompilerErr $ "Ix interface needed but not defined!" - Just (UClassVar v) -> return v - Just _ -> error "not a class var" - -dictType :: EnvReader m => ClassName n -> [CAtom n] -> m n (DictType n) -dictType className params = do - ClassDef sourceName _ _ _ _ _ _ <- lookupClassDef className - return $ DictType sourceName className params - -ixDictType :: (Fallible1 m, EnvReader m) => CType n -> m n (DictType n) -ixDictType ty = do - ixClassName <- getIxClassName - dictType ixClassName [Type ty] - -makePreludeMaybeTy :: EnvReader m => CType n -> m n (CType n) -makePreludeMaybeTy ty = do - ~(Just (UTyConVar tyConName)) <- lookupSourceMap "Maybe" - return $ TypeCon "Maybe" tyConName $ TyConParams [Explicit] [Type ty] - --- === computing effects === - -functionEffs :: (IRRep r, EnvReader m) => LamExpr r n -> m n (EffectRow r n) -functionEffs f = getLamExprType f >>= \case - PiType b (EffTy effs _) -> return $ ignoreHoistFailure $ hoist b effs - -rwsFunEffects :: (IRRep r, EnvReader m) => RWS -> LamExpr r n -> m n (EffectRow r n) -rwsFunEffects rws f = getLamExprType f >>= \case - PiType (BinaryNest h ref) et -> do - let effs' = ignoreHoistFailure $ hoist ref (etEff et) - let hVal = Var $ AtomVar (binderName h) (TC HeapType) - let effs'' = deleteEff (RWSEffect rws hVal) effs' - return $ ignoreHoistFailure $ hoist h effs'' - _ -> error "Expected a binary function type" - -getLamExprType :: (IRRep r, EnvReader m) => LamExpr r n -> m n (PiType r n) -getLamExprType (LamExpr bs body) = liftEnvReaderM $ - refreshAbs (Abs bs body) \bs' body' -> do - effTy <- blockEffTy body' - return $ PiType bs' effTy - -getTypeRWSAction :: (IRRep r, EnvReader m) => LamExpr r n -> m n (Type r n, Type r n) -getTypeRWSAction f = getLamExprType f >>= \case - PiType (BinaryNest regionBinder refBinder) (EffTy _ resultTy) -> do - case binderType refBinder of - RefTy _ referentTy -> do - let referentTy' = ignoreHoistFailure $ hoist regionBinder referentTy - let resultTy' = ignoreHoistFailure $ hoist (PairB regionBinder refBinder) resultTy - return (resultTy', referentTy') - _ -> error "expected a ref" - _ -> error "expected a pi type" - -getSuperclassDicts :: EnvReader m => CAtom n -> m n ([CAtom n]) -getSuperclassDicts dict = do - case getType dict of - DictTy dTy -> do - ts <- getSuperclassTys dTy - forM (enumerate ts) \(i, t) -> return $ DictCon t $ SuperclassProj dict i - _ -> error "expected a dict type" - -getSuperclassTys :: EnvReader m => DictType n -> m n [CType n] -getSuperclassTys (DictType _ className params) = do - ClassDef _ _ _ _ bs superclasses _ <- lookupClassDef className - forM [0 .. nestLength superclasses - 1] \i -> do - instantiate (Abs bs $ getSuperclassType REmpty superclasses i) params - -getTypeTopFun :: EnvReader m => TopFunName n -> m n (PiType SimpIR n) -getTypeTopFun f = lookupTopFun f >>= \case - DexTopFun _ (TopLam _ piTy _) _ -> return piTy - FFITopFun _ iTy -> liftIFunType iTy - -asTopLam :: (EnvReader m, IRRep r) => LamExpr r n -> m n (TopLam r n) -asTopLam lam = do - piTy <- getLamExprType lam - return $ TopLam False piTy lam - -liftIFunType :: (IRRep r, EnvReader m) => IFunType -> m n (PiType r n) -liftIFunType (IFunType _ argTys resultTys) = liftEnvReaderM $ go argTys where - go :: IRRep r => [BaseType] -> EnvReaderM n (PiType r n) - go = \case - [] -> return $ PiType Empty (EffTy (OneEffect IOEffect) resultTy) - where resultTy = case resultTys of - [] -> UnitTy - [t] -> BaseTy t - [t1, t2] -> PairTy (BaseTy t1) (BaseTy t2) - _ -> error $ "Not a valid FFI return type: " ++ pprint resultTys - t:ts -> withFreshBinder noHint (BaseTy t) \b -> do - PiType bs effTy <- go ts - return $ PiType (Nest b bs) effTy - --- === Data constraints === - -isData :: EnvReader m => Type CoreIR n -> m n Bool -isData ty = do - result <- liftEnvReaderT $ withSubstReaderT $ checkDataLike ty - case runFallibleM result of - Success () -> return True - Failure _ -> return False - -checkDataLike :: Type CoreIR i -> SubstReaderT Name FallibleEnvReaderM i o () -checkDataLike ty = case ty of - TyVar _ -> notData - TabPi (TabPiType _ b eltTy) -> do - renameBinders b \_ -> - checkDataLike eltTy - DepPairTy (DepPairType _ b@(_:>l) r) -> do - recur l - renameBinders b \_ -> checkDataLike r - NewtypeTyCon nt -> do - (_, ty') <- unwrapNewtypeType =<< renameM nt - dropSubst $ recur ty' - TC con -> case con of - BaseType _ -> return () - ProdType as -> mapM_ recur as - SumType cs -> mapM_ recur cs - RefType _ _ -> return () - HeapType -> return () - _ -> notData - _ -> notData - where - recur = checkDataLike - notData = throw TypeErr $ pprint ty - -checkExtends :: (Fallible m, IRRep r) => EffectRow r n -> EffectRow r n -> m () -checkExtends allowed (EffectRow effs effTail) = do - let (EffectRow allowedEffs allowedEffTail) = allowed - case effTail of - EffectRowTail _ -> assertEq allowedEffTail effTail "" - NoTail -> return () - forM_ (eSetToList effs) \eff -> unless (eff `eSetMember` allowedEffs) $ - throw CompilerErr $ "Unexpected effect: " ++ pprint eff ++ - "\nAllowed: " ++ pprint allowed - +import Name + +class HasType (r::IR) (e::E) | e -> r where + getType :: e n -> Type r n + +class HasEffects (e::E) (r::IR) | e -> r where + getEffects :: e n -> EffectRow r n + +isPure :: (IRRep r, HasEffects e r) => e n -> Bool +isPure e = case getEffects e of + Pure -> True + _ -> False + +-- === querying types implementation === + +instance IRRep r => HasType r (AtomBinding r) where + getType = \case + LetBound (DeclBinding _ e) -> getType e + MiscBound ty -> ty + SolverBound (InfVarBound ty _) -> ty + SolverBound (SkolemBound ty) -> ty + NoinlineFun ty _ -> ty + TopDataBound (RepVal ty _) -> ty + FFIFunBound piTy _ -> Pi piTy + +litType :: LitVal -> BaseType +litType v = case v of + Int64Lit _ -> Scalar Int64Type + Int32Lit _ -> Scalar Int32Type + Word8Lit _ -> Scalar Word8Type + Word32Lit _ -> Scalar Word32Type + Word64Lit _ -> Scalar Word64Type + Float64Lit _ -> Scalar Float64Type + Float32Lit _ -> Scalar Float32Type + PtrLit ty _ -> PtrType ty + +typeBinOp :: BinOp -> BaseType -> BaseType +typeBinOp binop xTy = case binop of + IAdd -> xTy; ISub -> xTy + IMul -> xTy; IDiv -> xTy + IRem -> xTy; + ICmp _ -> Scalar Word8Type + FAdd -> xTy; FSub -> xTy + FMul -> xTy; FDiv -> xTy; + FPow -> xTy + FCmp _ -> Scalar Word8Type + BAnd -> xTy; BOr -> xTy + BXor -> xTy + BShL -> xTy; BShR -> xTy + +typeUnOp :: UnOp -> BaseType -> BaseType +typeUnOp = const id -- All unary ops preserve the type of the input + + +instance IRRep r => HasType r (AtomVar r) where + getType (AtomVar _ ty) = ty + {-# INLINE getType #-} + +instance IRRep r => HasType r (Atom r) where + getType atom = case atom of + Var name -> getType name + Lam (CoreLamExpr piTy _) -> Pi piTy + DepPair _ _ ty -> DepPairTy ty + Con con -> getType con + Eff _ -> EffKind + PtrVar t _ -> PtrTy t + DictCon ty _ -> ty + NewtypeCon con _ -> getNewtypeType con + RepValAtom (RepVal ty _) -> ty + SimpInCore x -> getType x + TypeAsAtom ty -> getType ty + +instance IRRep r => HasType r (Type r) where + getType = \case + NewtypeTyCon con -> getType con + Pi _ -> TyKind + TabPi _ -> TyKind + DepPairTy _ -> TyKind + TC _ -> TyKind + DictTy _ -> TyKind + TyVar v -> getType v + +instance HasType CoreIR SimpInCore where + getType = \case + LiftSimp t _ -> t + LiftSimpFun piTy _ -> Pi $ piTy + TabLam t _ -> TabPi $ t + ACase _ _ t -> t + +instance HasType CoreIR NewtypeTyCon where + getType _ = TyKind + +getNewtypeType :: NewtypeCon n -> CType n +getNewtypeType con = case con of + NatCon -> NewtypeTyCon Nat + FinCon n -> NewtypeTyCon $ Fin n + UserADTData sn d params -> NewtypeTyCon $ UserADTType sn d params + +instance IRRep r => HasType r (Con r) where + getType = \case + Lit l -> BaseTy $ litType l + ProdCon xs -> ProdTy $ map getType xs + SumCon tys _ _ -> SumTy tys + HeapVal -> TC HeapType + +instance IRRep r => HasType r (Expr r) where + getType expr = case expr of + App (EffTy _ ty) _ _ -> ty + TopApp (EffTy _ ty) _ _ -> ty + TabApp t _ _ -> t + Atom x -> getType x + TabCon _ ty _ -> ty + PrimOp op -> getType op + Case _ _ (EffTy _ resultTy) -> resultTy + ApplyMethod (EffTy _ t) _ _ _ -> t + ProjectElt t _ _ -> t + DictHole _ ty _ -> ty + +instance IRRep r => HasType r (DAMOp r) where + getType = \case + AllocDest ty -> RawRefTy ty + Place _ _ -> UnitTy + Freeze ref -> case getType ref of + RawRefTy ty -> ty + ty -> error $ "Not a reference type: " ++ show ty + Seq _ _ _ cinit _ -> getType cinit + RememberDest _ d _ -> getType d + +instance IRRep r => HasType r (PrimOp r) where + getType primOp = case primOp of + BinOp op x _ -> TC $ BaseType $ typeBinOp op $ getTypeBaseType x + UnOp op x -> TC $ BaseType $ typeUnOp op $ getTypeBaseType x + Hof (TypedHof (EffTy _ ty) _) -> ty + MemOp op -> getType op + MiscOp op -> getType op + VectorOp op -> getType op + DAMOp op -> getType op + RefOp ref m -> case getType ref of + TC (RefType _ s) -> case m of + MGet -> s + MPut _ -> UnitTy + MAsk -> s + MExtend _ _ -> UnitTy + IndexRef t _ -> t + ProjRef t _ -> t + _ -> error "not a reference type" + +getTypeBaseType :: (IRRep r, HasType r e) => e n -> BaseType +getTypeBaseType e = case getType e of + TC (BaseType b) -> b + ty -> error $ "Expected a base type. Got: " ++ show ty + +instance IRRep r => HasType r (MemOp r) where + getType = \case + IOAlloc _ -> PtrTy (CPU, Scalar Word8Type) + IOFree _ -> UnitTy + PtrOffset arr _ -> getType arr + PtrLoad ptr -> do + let PtrTy (_, t) = getType ptr + BaseTy t + PtrStore _ _ -> UnitTy + +instance IRRep r => HasType r (VectorOp r) where + getType = \case + VectorBroadcast _ vty -> vty + VectorIota vty -> vty + VectorIdx _ _ vty -> vty + VectorSubref ref _ vty -> case getType ref of + TC (RefType h _) -> TC $ RefType h vty + ty -> error $ "Not a reference type: " ++ show ty + +instance IRRep r => HasType r (MiscOp r) where + getType = \case + Select _ x _ -> getType x + ThrowError t -> t + ThrowException t -> t + CastOp t _ -> t + BitcastOp t _ -> t + UnsafeCoerce t _ -> t + GarbageVal t -> t + SumTag _ -> TagRepTy + ToEnum t _ -> t + OutputStream -> BaseTy $ hostPtrTy $ Scalar Word8Type + where hostPtrTy ty = PtrType (CPU, ty) + ShowAny _ -> rawStrType -- TODO: constrain `ShowAny` to have `HasCore r` + ShowScalar _ -> PairTy IdxRepTy $ rawFinTabType (IdxRepVal showStringBufferSize) CharRepTy + +rawStrType :: IRRep r => Type r n +rawStrType = case newName "n" of + Abs b v -> do + let tabTy = rawFinTabType (Var $ AtomVar v IdxRepTy) CharRepTy + DepPairTy $ DepPairType ExplicitDepPair (PlainBD (b:>IdxRepTy)) tabTy + +-- `n` argument is IdxRepVal, not Nat +rawFinTabType :: IRRep r => Atom r n -> Type r n -> Type r n +rawFinTabType n eltTy = IxType IdxRepTy (IxDictRawFin n) ==> eltTy + +depPairLeftTy :: IRRep r => DepPairType r n -> Type r n +depPairLeftTy (DepPairType _ b _) = binderType b +{-# INLINE depPairLeftTy #-} + +tabIxType :: IRRep r => TabPiType r n -> IxType r n +tabIxType (TabPiType d b _) = IxType (binderType b) d + +typesAsBinderNest + :: (SinkableE e, HoistableE e, IRRep r) + => [Type r n] -> e n -> Abs (Binders r) e n +typesAsBinderNest types body = + case toConstBinderNest types body of + Abs bs body' -> Abs (fmapNest PlainBD bs) body' + +nonDepPiType :: [CType n] -> EffectRow CoreIR n -> CType n -> CorePiType n +nonDepPiType argTys eff resultTy = case typesAsBinderNest argTys (PairE eff resultTy) of + Abs bs (PairE eff' resultTy') -> do + let expls = nestToList (const Explicit) bs + CorePiType ExplicitApp expls bs $ EffTy eff' resultTy' + +nonDepTabPiType :: IRRep r => IxType r n -> Type r n -> TabPiType r n +nonDepTabPiType (IxType t d) resultTy = + case toConstAbsPure resultTy of + Abs b resultTy' -> TabPiType d (PlainBD (b:>t)) resultTy' + +corePiTypeToPiType :: CorePiType n -> PiType CoreIR n +corePiTypeToPiType (CorePiType _ _ bs effTy) = PiType bs effTy + +coreLamToTopLam :: CoreLamExpr n -> TopLam CoreIR n +coreLamToTopLam (CoreLamExpr ty f) = TopLam False (corePiTypeToPiType ty) f + +(==>) :: IRRep r => IxType r n -> Type r n -> Type r n +a ==> b = TabPi $ nonDepTabPiType a b + +litFinIxTy :: Int -> IxType r n +litFinIxTy n = finIxTy $ IdxRepVal $ fromIntegral n + +finIxTy :: Atom r n -> IxType r n +finIxTy n = IxType IdxRepTy (IxDictRawFin n) + +ixTyFromDict :: IRRep r => IxDict r n -> IxType r n +ixTyFromDict ixDict = flip IxType ixDict $ case ixDict of + IxDictAtom dict -> case getType dict of + DictTy (DictType "Ix" _ [Type iTy]) -> iTy + _ -> error $ "Not an Ix dict: " ++ show dict + IxDictRawFin _ -> IdxRepTy + IxDictSpecialized n _ _ -> n + +-- === querying effects implementation === + +instance IRRep r => HasEffects (Expr r) r where + getEffects = \case + Atom _ -> Pure + App (EffTy eff _) _ _ -> eff + TopApp (EffTy eff _) _ _ -> eff + TabApp _ _ _ -> Pure + Case _ _ (EffTy effs _) -> effs + TabCon _ _ _ -> Pure + ApplyMethod (EffTy eff _) _ _ _ -> eff + PrimOp primOp -> getEffects primOp + +instance IRRep r => HasEffects (DeclBinding r) r where + getEffects (DeclBinding _ expr) = getEffects expr + {-# INLINE getEffects #-} + +instance IRRep r => HasEffects (PrimOp r) r where + getEffects = \case + UnOp _ _ -> Pure + BinOp _ _ _ -> Pure + VectorOp _ -> Pure + MemOp op -> case op of + IOAlloc _ -> OneEffect IOEffect + IOFree _ -> OneEffect IOEffect + PtrLoad _ -> OneEffect IOEffect + PtrStore _ _ -> OneEffect IOEffect + PtrOffset _ _ -> Pure + MiscOp op -> case op of + ThrowException _ -> OneEffect ExceptionEffect + Select _ _ _ -> Pure + ThrowError _ -> Pure + CastOp _ _ -> Pure + UnsafeCoerce _ _ -> Pure + GarbageVal _ -> Pure + BitcastOp _ _ -> Pure + SumTag _ -> Pure + ToEnum _ _ -> Pure + OutputStream -> Pure + ShowAny _ -> Pure + ShowScalar _ -> Pure + RefOp ref m -> case getType ref of + TC (RefType h _) -> case m of + MGet -> OneEffect (RWSEffect State h) + MPut _ -> OneEffect (RWSEffect State h) + MAsk -> OneEffect (RWSEffect Reader h) + -- XXX: We don't verify the base monoid. See note about RunWriter. + MExtend _ _ -> OneEffect (RWSEffect Writer h) + IndexRef _ _ -> Pure + ProjRef _ _ -> Pure + _ -> error "not a ref" + DAMOp op -> case op of + Place _ _ -> OneEffect InitEffect + Seq eff _ _ _ _ -> eff + RememberDest eff _ _ -> eff + AllocDest _ -> Pure -- is this correct? + Freeze _ -> Pure -- is this correct? + Hof (TypedHof (EffTy eff _) _) -> eff + {-# INLINE getEffects #-} diff --git a/src/lib/QueryTypePure.hs b/src/lib/QueryTypePure.hs deleted file mode 100644 index 9be267241..000000000 --- a/src/lib/QueryTypePure.hs +++ /dev/null @@ -1,316 +0,0 @@ --- Copyright 2023 Google LLC --- --- Use of this source code is governed by a BSD-style --- license that can be found in the LICENSE file or at --- https://developers.google.com/open-source/licenses/bsd - -module QueryTypePure where - -import Types.Primitives -import Types.Core -import IRVariants -import Name - -class HasType (r::IR) (e::E) | e -> r where - getType :: e n -> Type r n - -class HasEffects (e::E) (r::IR) | e -> r where - getEffects :: e n -> EffectRow r n - -isPure :: (IRRep r, HasEffects e r) => e n -> Bool -isPure e = case getEffects e of - Pure -> True - _ -> False - --- === querying types implementation === - -instance IRRep r => HasType r (AtomBinding r) where - getType = \case - LetBound (DeclBinding _ e) -> getType e - MiscBound ty -> ty - SolverBound (InfVarBound ty _) -> ty - SolverBound (SkolemBound ty) -> ty - NoinlineFun ty _ -> ty - TopDataBound (RepVal ty _) -> ty - FFIFunBound piTy _ -> Pi piTy - -litType :: LitVal -> BaseType -litType v = case v of - Int64Lit _ -> Scalar Int64Type - Int32Lit _ -> Scalar Int32Type - Word8Lit _ -> Scalar Word8Type - Word32Lit _ -> Scalar Word32Type - Word64Lit _ -> Scalar Word64Type - Float64Lit _ -> Scalar Float64Type - Float32Lit _ -> Scalar Float32Type - PtrLit ty _ -> PtrType ty - -typeBinOp :: BinOp -> BaseType -> BaseType -typeBinOp binop xTy = case binop of - IAdd -> xTy; ISub -> xTy - IMul -> xTy; IDiv -> xTy - IRem -> xTy; - ICmp _ -> Scalar Word8Type - FAdd -> xTy; FSub -> xTy - FMul -> xTy; FDiv -> xTy; - FPow -> xTy - FCmp _ -> Scalar Word8Type - BAnd -> xTy; BOr -> xTy - BXor -> xTy - BShL -> xTy; BShR -> xTy - -typeUnOp :: UnOp -> BaseType -> BaseType -typeUnOp = const id -- All unary ops preserve the type of the input - - -instance IRRep r => HasType r (AtomVar r) where - getType (AtomVar _ ty) = ty - {-# INLINE getType #-} - -instance IRRep r => HasType r (Atom r) where - getType atom = case atom of - Var name -> getType name - Lam (CoreLamExpr piTy _) -> Pi piTy - DepPair _ _ ty -> DepPairTy ty - Con con -> getType con - Eff _ -> EffKind - PtrVar t _ -> PtrTy t - DictCon ty _ -> ty - NewtypeCon con _ -> getNewtypeType con - RepValAtom (RepVal ty _) -> ty - ProjectElt t _ _ -> t - SimpInCore x -> getType x - DictHole _ ty _ -> ty - TypeAsAtom ty -> getType ty - -instance IRRep r => HasType r (Type r) where - getType = \case - NewtypeTyCon con -> getType con - Pi _ -> TyKind - TabPi _ -> TyKind - DepPairTy _ -> TyKind - TC _ -> TyKind - DictTy _ -> TyKind - TyVar v -> getType v - ProjectEltTy t _ _ -> t - -instance HasType CoreIR SimpInCore where - getType = \case - LiftSimp t _ -> t - LiftSimpFun piTy _ -> Pi $ piTy - TabLam t _ -> TabPi $ t - ACase _ _ t -> t - -instance HasType CoreIR NewtypeTyCon where - getType _ = TyKind - -getNewtypeType :: NewtypeCon n -> CType n -getNewtypeType con = case con of - NatCon -> NewtypeTyCon Nat - FinCon n -> NewtypeTyCon $ Fin n - UserADTData sn d params -> NewtypeTyCon $ UserADTType sn d params - -instance IRRep r => HasType r (Con r) where - getType = \case - Lit l -> BaseTy $ litType l - ProdCon xs -> ProdTy $ map getType xs - SumCon tys _ _ -> SumTy tys - HeapVal -> TC HeapType - -getSuperclassType :: RNest CBinder n l -> Nest CBinder l l' -> Int -> CType n -getSuperclassType _ Empty = error "bad index" -getSuperclassType bsAbove (Nest b@(_:>t) bs) = \case - 0 -> ignoreHoistFailure $ hoist bsAbove t - i -> getSuperclassType (RNest bsAbove b) bs (i-1) - -instance IRRep r => HasType r (Expr r) where - getType expr = case expr of - App (EffTy _ ty) _ _ -> ty - TopApp (EffTy _ ty) _ _ -> ty - TabApp t _ _ -> t - Atom x -> getType x - TabCon _ ty _ -> ty - PrimOp op -> getType op - Case _ _ (EffTy _ resultTy) -> resultTy - ApplyMethod (EffTy _ t) _ _ _ -> t - -instance IRRep r => HasType r (DAMOp r) where - getType = \case - AllocDest ty -> RawRefTy ty - Place _ _ -> UnitTy - Freeze ref -> case getType ref of - RawRefTy ty -> ty - ty -> error $ "Not a reference type: " ++ show ty - Seq _ _ _ cinit _ -> getType cinit - RememberDest _ d _ -> getType d - -instance IRRep r => HasType r (PrimOp r) where - getType primOp = case primOp of - BinOp op x _ -> TC $ BaseType $ typeBinOp op $ getTypeBaseType x - UnOp op x -> TC $ BaseType $ typeUnOp op $ getTypeBaseType x - Hof (TypedHof (EffTy _ ty) _) -> ty - MemOp op -> getType op - MiscOp op -> getType op - VectorOp op -> getType op - DAMOp op -> getType op - RefOp ref m -> case getType ref of - TC (RefType _ s) -> case m of - MGet -> s - MPut _ -> UnitTy - MAsk -> s - MExtend _ _ -> UnitTy - IndexRef t _ -> t - ProjRef t _ -> t - _ -> error "not a reference type" - -getTypeBaseType :: (IRRep r, HasType r e) => e n -> BaseType -getTypeBaseType e = case getType e of - TC (BaseType b) -> b - ty -> error $ "Expected a base type. Got: " ++ show ty - -instance IRRep r => HasType r (MemOp r) where - getType = \case - IOAlloc _ -> PtrTy (CPU, Scalar Word8Type) - IOFree _ -> UnitTy - PtrOffset arr _ -> getType arr - PtrLoad ptr -> do - let PtrTy (_, t) = getType ptr - BaseTy t - PtrStore _ _ -> UnitTy - -instance IRRep r => HasType r (VectorOp r) where - getType = \case - VectorBroadcast _ vty -> vty - VectorIota vty -> vty - VectorIdx _ _ vty -> vty - VectorSubref ref _ vty -> case getType ref of - TC (RefType h _) -> TC $ RefType h vty - ty -> error $ "Not a reference type: " ++ show ty - -instance IRRep r => HasType r (MiscOp r) where - getType = \case - Select _ x _ -> getType x - ThrowError t -> t - ThrowException t -> t - CastOp t _ -> t - BitcastOp t _ -> t - UnsafeCoerce t _ -> t - GarbageVal t -> t - SumTag _ -> TagRepTy - ToEnum t _ -> t - OutputStream -> BaseTy $ hostPtrTy $ Scalar Word8Type - where hostPtrTy ty = PtrType (CPU, ty) - ShowAny _ -> rawStrType -- TODO: constrain `ShowAny` to have `HasCore r` - ShowScalar _ -> PairTy IdxRepTy $ rawFinTabType (IdxRepVal showStringBufferSize) CharRepTy - -rawStrType :: IRRep r => Type r n -rawStrType = case newName "n" of - Abs b v -> do - let tabTy = rawFinTabType (Var $ AtomVar v IdxRepTy) CharRepTy - DepPairTy $ DepPairType ExplicitDepPair (b:>IdxRepTy) tabTy - --- `n` argument is IdxRepVal, not Nat -rawFinTabType :: IRRep r => Atom r n -> Type r n -> Type r n -rawFinTabType n eltTy = IxType IdxRepTy (IxDictRawFin n) ==> eltTy - -tabIxType :: TabPiType r n -> IxType r n -tabIxType (TabPiType d (_:>t) _) = IxType t d - -typesAsBinderNest - :: (SinkableE e, HoistableE e, IRRep r) - => [Type r n] -> e n -> Abs (Nest (Binder r)) e n -typesAsBinderNest types body = toConstBinderNest types body - -nonDepPiType :: [CType n] -> EffectRow CoreIR n -> CType n -> CorePiType n -nonDepPiType argTys eff resultTy = case typesAsBinderNest argTys (PairE eff resultTy) of - Abs bs (PairE eff' resultTy') -> do - let expls = nestToList (const Explicit) bs - CorePiType ExplicitApp expls bs $ EffTy eff' resultTy' - -nonDepTabPiType :: IRRep r => IxType r n -> Type r n -> TabPiType r n -nonDepTabPiType (IxType t d) resultTy = - case toConstAbsPure resultTy of - Abs b resultTy' -> TabPiType d (b:>t) resultTy' - -corePiTypeToPiType :: CorePiType n -> PiType CoreIR n -corePiTypeToPiType (CorePiType _ _ bs effTy) = PiType bs effTy - -coreLamToTopLam :: CoreLamExpr n -> TopLam CoreIR n -coreLamToTopLam (CoreLamExpr ty f) = TopLam False (corePiTypeToPiType ty) f - -(==>) :: IRRep r => IxType r n -> Type r n -> Type r n -a ==> b = TabPi $ nonDepTabPiType a b - -litFinIxTy :: Int -> IxType r n -litFinIxTy n = finIxTy $ IdxRepVal $ fromIntegral n - -finIxTy :: Atom r n -> IxType r n -finIxTy n = IxType IdxRepTy (IxDictRawFin n) - -ixTyFromDict :: IRRep r => IxDict r n -> IxType r n -ixTyFromDict ixDict = flip IxType ixDict $ case ixDict of - IxDictAtom dict -> case getType dict of - DictTy (DictType "Ix" _ [Type iTy]) -> iTy - _ -> error $ "Not an Ix dict: " ++ show dict - IxDictRawFin _ -> IdxRepTy - IxDictSpecialized n _ _ -> n - --- === querying effects implementation === - -instance IRRep r => HasEffects (Expr r) r where - getEffects = \case - Atom _ -> Pure - App (EffTy eff _) _ _ -> eff - TopApp (EffTy eff _) _ _ -> eff - TabApp _ _ _ -> Pure - Case _ _ (EffTy effs _) -> effs - TabCon _ _ _ -> Pure - ApplyMethod (EffTy eff _) _ _ _ -> eff - PrimOp primOp -> getEffects primOp - -instance IRRep r => HasEffects (DeclBinding r) r where - getEffects (DeclBinding _ expr) = getEffects expr - {-# INLINE getEffects #-} - -instance IRRep r => HasEffects (PrimOp r) r where - getEffects = \case - UnOp _ _ -> Pure - BinOp _ _ _ -> Pure - VectorOp _ -> Pure - MemOp op -> case op of - IOAlloc _ -> OneEffect IOEffect - IOFree _ -> OneEffect IOEffect - PtrLoad _ -> OneEffect IOEffect - PtrStore _ _ -> OneEffect IOEffect - PtrOffset _ _ -> Pure - MiscOp op -> case op of - ThrowException _ -> OneEffect ExceptionEffect - Select _ _ _ -> Pure - ThrowError _ -> Pure - CastOp _ _ -> Pure - UnsafeCoerce _ _ -> Pure - GarbageVal _ -> Pure - BitcastOp _ _ -> Pure - SumTag _ -> Pure - ToEnum _ _ -> Pure - OutputStream -> Pure - ShowAny _ -> Pure - ShowScalar _ -> Pure - RefOp ref m -> case getType ref of - TC (RefType h _) -> case m of - MGet -> OneEffect (RWSEffect State h) - MPut _ -> OneEffect (RWSEffect State h) - MAsk -> OneEffect (RWSEffect Reader h) - -- XXX: We don't verify the base monoid. See note about RunWriter. - MExtend _ _ -> OneEffect (RWSEffect Writer h) - IndexRef _ _ -> Pure - ProjRef _ _ -> Pure - _ -> error "not a ref" - DAMOp op -> case op of - Place _ _ -> OneEffect InitEffect - Seq eff _ _ _ _ -> eff - RememberDest eff _ _ -> eff - AllocDest _ -> Pure -- is this correct? - Freeze _ -> Pure -- is this correct? - Hof (TypedHof (EffTy eff _) _) -> eff - {-# INLINE getEffects #-} diff --git a/src/lib/RuntimePrint.hs b/src/lib/RuntimePrint.hs index 4a4c2c6a5..41764e4a7 100644 --- a/src/lib/RuntimePrint.hs +++ b/src/lib/RuntimePrint.hs @@ -15,12 +15,12 @@ import Err import IRVariants import MTL1 import Name -import CheapReduction import Types.Core import Types.Source import Types.Primitives import QueryType import Util (enumerate) +import Visitor newtype Printer (n::S) (a :: *) = Printer { runPrinter' :: ReaderT1 (Atom CoreIR) (BuilderM CoreIR) n a } deriving ( Functor, Applicative, Monad, EnvReader, MonadReader (Atom CoreIR n) @@ -78,7 +78,6 @@ showAnyRec atom = case getType atom of parens $ sepBy ", " $ map rec xs -- TODO: traverse the type and print out data components TypeKind -> printAsConstant - ProjectEltTy _ _ _ -> error "not implemented" Pi _ -> printTypeOnly "function" TabPi _ -> brackets $ forEachTabElt atom \iOrd x -> do isFirst <- ieq iOrd (NatVal 0) @@ -94,7 +93,7 @@ showAnyRec atom = case getType atom of EffectRowKind -> printAsConstant -- hack to print strings nicely. TODO: make `Char` a newtype UserADTType "List" _ (TyConParams [Explicit] [Type Word8Ty]) -> do - charTab <- normalizeNaryProj [ProjectProduct 1, UnwrapNewtype] atom + charTab <- getProj 1 =<< unwrapNewtype atom emitCharLit '"' emitCharTab charTab emitCharLit '"' @@ -113,15 +112,16 @@ showAnyRec atom = case getType atom of rec =<< projectStruct i atom where showDataCon :: Emits n' => DataConDef n' -> CAtom n' -> Print n' - showDataCon (DataConDef sn _ _ projss) arg = do - case projss of - [] -> emitLit sn - _ -> parens do - emitLit (sn ++ " ") - sepBy " " $ projss <&> \projs -> - -- we use `init` to strip off the `UnwrapCompoundNewtype` since - -- we're already under the case alternative - rec =<< normalizeNaryProj (init projs) arg + showDataCon (DataConDef sn _ _ projss) arg = undefined + -- showDataCon (DataConDef sn _ _ projss) arg = do + -- case projss of + -- [] -> emitLit sn + -- _ -> parens do + -- emitLit (sn ++ " ") + -- sepBy " " $ projss <&> \projs -> + -- -- we use `init` to strip off the `UnwrapCompoundNewtype` since + -- -- we're already under the case alternative + -- rec =<< normalizeNaryProj (init projs) arg DepPairTy _ -> parens do (x, y) <- fromPair atom rec x >> emitLit " ,> " >> rec y @@ -169,10 +169,10 @@ withBuffer cont = do body <- buildBlock do cont $ sink $ Var $ binderVar b return UnitVal - let binders = BinaryNest h b + let binders = BinaryNest (PlainBD h) (PlainBD b) let expls = [Inferred Nothing Unify, Explicit] let piTy = CorePiType ExplicitApp expls binders $ EffTy eff UnitTy - let lam = LamExpr (BinaryNest h b) body + let lam = LamExpr (BinaryNest (PlainBD h) (PlainBD b)) body return $ Lam $ CoreLamExpr piTy lam applyPreludeFunction "with_stack_internal" [lam] @@ -200,7 +200,7 @@ stringLitAsCharTab s = do t <- finTabTyCore (NatVal $ fromIntegral $ length s) CharRepTy emitExpr $ TabCon Nothing t (map charRepVal s) -finTabTyCore :: (Fallible1 m, EnvReader m) => CAtom n -> CType n -> m n (CType n) +finTabTyCore :: CBuilderEmits m n => CAtom n -> CType n -> m n (CType n) finTabTyCore n eltTy = do d <- mkDictAtom $ IxFin n return $ IxType (FinTy n) (IxDictAtom d) ==> eltTy diff --git a/src/lib/Simplify.hs b/src/lib/Simplify.hs index 028e35981..705aa6769 100644 --- a/src/lib/Simplify.hs +++ b/src/lib/Simplify.hs @@ -18,7 +18,6 @@ import Data.Maybe import Data.Text.Prettyprint.Doc (Pretty (..), hardline) import Builder -import CheapReduction import CheckType import Core import Err @@ -85,10 +84,6 @@ tryAsDataAtom atom = do DepPair x y ty -> do DepPairTy ty' <- getRepType $ DepPairTy ty DepPair <$> go x <*> go y <*> pure ty' - ProjectElt _ UnwrapNewtype x -> go x - -- TODO: do we need to think about a case like `fst (1, \x.x)`, where - -- the projection is data but the argument isn't? - ProjectElt _ (ProjectProduct i) x -> normalizeProj (ProjectProduct i) =<< go x NewtypeCon _ x -> go x SimpInCore x -> case x of LiftSimp _ x' -> return x' @@ -98,7 +93,6 @@ tryAsDataAtom atom = do Lam _ -> notData DictCon _ _ -> notData Eff _ -> notData - DictHole _ _ _ -> notData TypeAsAtom _ -> notData where notData = error $ "Not runtime-representable data: " ++ pprint atom @@ -109,36 +103,35 @@ forceTabLam (PairE ixTy (Abs b ab)) = result <- applyRename (b@>(atomVarName v)) ab >>= emitDecls toDataAtomIgnoreRecon result -type NaryTabLamExpr = Abs (Nest SBinder) (Abs (Nest SDecl) CAtom) +type NaryTabLamExpr = Abs SBinders (Abs (Nest SDecl) CAtom) fromNaryTabLam :: Int -> CAtom n -> Maybe (Int, NaryTabLamExpr n) fromNaryTabLam maxDepth | maxDepth <= 0 = error "expected positive number of args" fromNaryTabLam maxDepth = \case SimpInCore (TabLam _ (PairE _ (Abs b body))) -> - extend <|> (Just $ (1, Abs (Nest b Empty) body)) + extend <|> (Just $ (1, Abs (Nest (PlainBD b) Empty) body)) where extend = case body of Abs Empty lam | maxDepth > 1 -> do (d, Abs (Nest b2 bs2) body2) <- fromNaryTabLam (maxDepth - 1) lam - return $ (d + 1, Abs (Nest b (Nest b2 bs2)) body2) + return $ (d + 1, Abs (Nest (PlainBD b) (Nest b2 bs2)) body2) _ -> Nothing _ -> Nothing -forceACase :: Emits n => SAtom n -> [Abs SBinder CAtom n] -> CType n -> SimplifyM i n (SAtom n) +forceACase :: Emits n => SAtom n -> [Abs SBinderAndDecls CAtom n] -> CType n -> SimplifyM i n (SAtom n) forceACase scrut alts resultTy = do resultTy' <- getRepType resultTy buildCase scrut resultTy' \i arg -> do - Abs b result <- return $ alts !! i - applySubst (b@>SubstVal arg) result >>= toDataAtomIgnoreRecon + instantiate (alts !! i) [arg] >>= toDataAtomIgnoreRecon -tryGetRepType :: Type CoreIR n -> SimplifyM i n (Maybe (SType n)) +tryGetRepType :: Emits n => Type CoreIR n -> SimplifyM i n (Maybe (SType n)) tryGetRepType t = isData t >>= \case False -> return Nothing True -> Just <$> getRepType t -getRepType :: Type CoreIR n -> SimplifyM i n (SType n) +getRepType :: Emits n => Type CoreIR n -> SimplifyM i n (SType n) getRepType ty = go ty where - go :: Type CoreIR n -> SimplifyM i n (SType n) + go :: Emits n => Type CoreIR n -> SimplifyM i n (SType n) go = \case TC con -> TC <$> case con of BaseType b -> return $ BaseType b @@ -147,28 +140,50 @@ getRepType ty = go ty where RefType h a -> RefType <$> toDataAtomIgnoreReconAssumeNoDecls h <*> go a TypeKind -> error $ notDataType HeapType -> return $ HeapType - DepPairTy (DepPairType expl b@(_:>l) r) -> do - l' <- go l - withFreshBinder (getNameHint b) l' \b' -> do - x <- liftSimpAtom (sink l) (Var $ binderVar b') - r' <- go =<< applySubst (b@>SubstVal x) r - return $ DepPairTy $ DepPairType expl b' r' + DepPairTy depPairTy@(DepPairType expl b _) -> do + let bTy = binderType b + l' <- go bTy + withFreshBinderAndDecls (getNameHint b) l' \v -> do + x <- liftSimpAtom (sink bTy) (Var v) + r' <- go =<< liftCoreBuilder (instantiate depPairTy [x]) + return \b' -> DepPairTy $ DepPairType expl b' r' TabPi tabTy -> do let ixTy = tabIxType tabTy IxType t' d' <- simplifyIxType ixTy - withFreshBinder (getNameHint tabTy) t' \b' -> do - x <- liftSimpAtom (sink $ ixTypeType ixTy) (Var $ binderVar b') - bodyTy' <- go =<< instantiate (sink tabTy) [x] - return $ TabPi $ TabPiType d' b' bodyTy' + withFreshBinderAndDecls (getNameHint tabTy) t' \v -> do + x <- liftSimpAtom (sink $ ixTypeType ixTy) (Var v) + bodyTy' <- go =<< liftCoreBuilder (instantiate tabTy [x]) + return \b' -> TabPi $ TabPiType d' b' bodyTy' NewtypeTyCon con -> do - (_, ty') <- unwrapNewtypeType con + (_, ty') <- liftCoreBuilder $ unwrapNewtypeType con go ty' Pi _ -> error notDataType DictTy _ -> error notDataType TyVar _ -> error "Shouldn't have type variables in CoreIR IR with SimpIR builder names" - ProjectEltTy _ _ _ -> error "Shouldn't have this left" where notDataType = "Not a type of runtime-representable data: " ++ pprint ty +liftSimpAtom :: Emits n => Type CoreIR n -> SAtom n -> SimplifyM i n (CAtom n) +liftSimpAtom ty simpAtom = case simpAtom of + Var _ -> justLift + RepValAtom _ -> justLift -- TODO(dougalm): should we make more effort to pull out products etc? + _ -> do + (cons , ty') <- liftCoreBuilder $ unwrapLeadingNewtypesType ty + atom <- case (ty', simpAtom) of + (BaseTy _ , Con (Lit v)) -> return $ Con $ Lit v + (ProdTy tys, Con (ProdCon xs)) -> Con . ProdCon <$> zipWithM rec tys xs + (SumTy tys, Con (SumCon _ i x)) -> Con . SumCon tys i <$> rec (tys!!i) x + (DepPairTy dpt, DepPair x1 x2 _) -> do + x1' <- rec (depPairLeftTy dpt) x1 + t2' <- liftCoreBuilder $ instantiate dpt [x1'] + x2' <- rec t2' x2 + return $ DepPair x1' x2' dpt + _ -> error $ "can't lift " <> pprint simpAtom <> " to " <> pprint ty' + return $ wrapNewtypesData cons atom + where + rec = liftSimpAtom + justLift = return $ SimpInCore $ LiftSimp ty simpAtom +{-# INLINE liftSimpAtom #-} + toDataAtom :: Emits n => CAtom n -> SimplifyM i n (SAtom n, Type CoreIR n) toDataAtom x = tryAsDataAtom x >>= \case Just x' -> return x' @@ -187,19 +202,24 @@ toDataAtomIgnoreReconAssumeNoDecls x = do Empty -> return result _ -> error "unexpected decls" -withSimplifiedBinders - :: Nest (Binder CoreIR) o any - -> (forall o'. DExt o o' => Nest (Binder SimpIR) o o' -> [CAtom o'] -> SimplifyM i o' a) +simplifyBinders + :: Emits o => Binders CoreIR i i' + -> (forall o'. DExt o o' => [CAtom o'] -> SimplifyM i' o' (Binders SimpIR o o' -> a)) -> SimplifyM i o a -withSimplifiedBinders Empty cont = getDistinct >>= \Distinct -> cont Empty [] -withSimplifiedBinders (Nest (bCore:>ty) bsCore) cont = do - simpTy <- getRepType ty - withFreshBinder (getNameHint bCore) simpTy \bSimp -> do - x <- liftSimpAtom (sink ty) (Var $ binderVar bSimp) - -- TODO: carry a substitution instead of doing N^2 work like this - Abs bsCore' UnitE <- applySubst (bCore@>SubstVal x) (EmptyAbs bsCore) - withSimplifiedBinders bsCore' \bsSimp xs -> - cont (Nest bSimp bsSimp) (sink x:xs) +simplifyBinders bs cont = case bs of + Empty -> do + Distinct <- getDistinct + f <- cont [] + return $ f Empty + Nest b bs -> do + cTy <- substM $ binderType b + sTy <- getRepType cTy + withFreshBinderAndDecls (getNameHint b) sTy \sVar -> do + x <- liftSimpAtom (sink cTy) (Var sVar) + extendSubstBD b [SubstVal x] do + simplifyBinders bs \xs -> do + f <- cont (sink x:xs) + return \sBinders -> \sBinder -> f (Nest sBinder sBinders) -- === Reconstructions === @@ -207,7 +227,7 @@ data ReconstructAtom (n::S) = CoerceRecon (Type CoreIR n) | LamRecon (ReconAbs SimpIR CAtom n) -applyRecon :: (EnvReader m, Fallible1 m) => ReconstructAtom n -> SAtom n -> m n (CAtom n) +applyRecon :: Emits n => ReconstructAtom n -> SAtom n -> SimplifyM i n (CAtom n) applyRecon (CoerceRecon ty) x = liftSimpAtom ty x applyRecon (LamRecon ab) x = applyReconAbs ab x @@ -235,6 +255,9 @@ liftSimplifyM cont = do liftDoubleBuilderToSimplifyM :: DoubleBuilder SimpIR o a -> SimplifyM i o a liftDoubleBuilderToSimplifyM cont = SimplifyM $ liftSubstReaderT cont +liftCoreBuilder :: Emits o => BuilderM CoreIR o a -> SimplifyM i o a +liftCoreBuilder = undefined + instance Simplifier SimplifyM deriving instance ScopableBuilder SimpIR (SimplifyM i) @@ -253,15 +276,16 @@ simplifyTopBlock _ = error "not a block (nullary lambda)" {-# SCC simplifyTopBlock #-} simplifyTopFunction :: (TopBuilder m, Mut n) => CTopLam n -> m n (STopLam n) -simplifyTopFunction (TopLam False _ f) = do - asTopLam =<< liftSimplifyM do - (lam, CoerceReconAbs) <- simplifyLam f - return lam -simplifyTopFunction _ = error "shouldn't be in destination-passing style already" -{-# SCC simplifyTopFunction #-} +simplifyTopFunction (TopLam False _ f) = undefined +-- simplifyTopFunction (TopLam False _ f) = do +-- asTopLam =<< liftSimplifyM do +-- (lam, CoerceReconAbs) <- simplifyLam f +-- return lam +-- simplifyTopFunction _ = error "shouldn't be in destination-passing style already" +-- {-# SCC simplifyTopFunction #-} applyReconTop :: (EnvReader m, Fallible1 m) => ReconstructAtom n -> SAtom n -> m n (CAtom n) -applyReconTop = applyRecon +applyReconTop = undefined -- applyRecon instance GenericE SimplifiedBlock where type RepE SimplifiedBlock = PairE SBlock ReconstructAtom @@ -369,20 +393,19 @@ defuncCaseCore :: Emits o -> SimplifyM i o (CAtom o) defuncCaseCore scrut resultTy cont = do tryAsDataAtom scrut >>= \case - Just (scrutSimp, _) -> do - altBinderTys <- caseAltsBinderTys $ getType scrut - defuncCase scrutSimp resultTy \i x -> do - let xCoreTy = altBinderTys !! i - x' <- liftSimpAtom (sink xCoreTy) x - cont i x' + -- Just (scrutSimp, _) -> do + -- altBinderTys <- caseAltsBinderTys $ getType scrut + -- defuncCase scrutSimp resultTy \i x -> do + -- let xCoreTy = altBinderTys !! i + -- x' <- liftSimpAtom (sink xCoreTy) x + -- cont i x' Nothing -> case trySelectBranch scrut of Just (i, arg) -> getDistinct >>= \Distinct -> cont i arg Nothing -> go scrut where go = \case SimpInCore (ACase scrutSimp alts _) -> do defuncCase scrutSimp resultTy \i x -> do - Abs altb altAtom <- return $ alts !! i - altAtom' <- applySubst (altb @> SubstVal x) altAtom + altAtom' <- instantiate (alts !! i) [x] cont i altAtom' NewtypeCon con scrut' | isSumCon con -> go scrut' _ -> nope @@ -416,7 +439,9 @@ defuncCase scrut resultTy cont = do caseResult <- emitExpr $ caseExpr (dataVal, sumVal) <- fromPair caseResult reconAlts <- forM (zip closureTys recons) \(ty, recon) -> - buildAbs noHint ty \v -> applyRecon (sink recon) (Var v) + withFreshBinderAndDecls noHint ty \v -> do + result <- applyRecon (sink recon) (Var v) + return \b -> Abs b result let nonDataVal = SimpInCore $ ACase sumVal reconAlts newNonDataTy Distinct <- getDistinct fromSplit split dataVal nonDataVal @@ -426,21 +451,22 @@ simplifyAlt -> SType o -> (forall o'. (Emits o', DExt o o') => SAtom o' -> SimplifyM i o' (CAtom o')) -> SimplifyM i o (Alt SimpIR o, SType o, ReconstructAtom o) -simplifyAlt split ty cont = do - withFreshBinder noHint ty \b -> do - ab <- buildScoped $ cont $ sink $ Var $ binderVar b - (body, recon) <- refreshAbs ab \decls result -> do - let locals = toScopeFrag b >>> toScopeFrag decls - -- TODO: this might be too cautious. The type only needs to - -- be hoistable above the decls. In principle it can still - -- mention vars from the lambda binders. - Distinct <- getDistinct - (resultData, resultNonData) <- toSplit split result - (newResult, reconAbs) <- telescopicCapture locals resultNonData - return (Abs decls (PairVal resultData newResult), LamRecon reconAbs) - EffTy _ (PairTy _ nonDataType) <- blockEffTy body - let nonDataType' = ignoreHoistFailure $ hoist b nonDataType - return (Abs b body, nonDataType', recon) +simplifyAlt split ty cont = undefined +-- simplifyAlt split ty cont = do +-- withFreshBinder noHint ty \b -> do +-- ab <- buildScoped $ cont $ sink $ binderAtom b +-- (body, recon) <- refreshAbs ab \decls result -> do +-- let locals = toScopeFrag b >>> toScopeFrag decls +-- -- TODO: this might be too cautious. The type only needs to +-- -- be hoistable above the decls. In principle it can still +-- -- mention vars from the lambda binders. +-- Distinct <- getDistinct +-- (resultData, resultNonData) <- toSplit split result +-- (newResult, reconAbs) <- telescopicCapture locals resultNonData +-- return (Abs decls (PairVal resultData newResult), LamRecon reconAbs) +-- EffTy _ (PairTy _ nonDataType) <- blockEffTy body +-- let nonDataType' = ignoreHoistFailure $ hoist b nonDataType +-- return (Abs b body, nonDataType', recon) simplifyApp :: forall i o. Emits o => NameHint -> CType o -> CAtom i -> [CAtom o] -> SimplifyM i o (CAtom o) @@ -457,7 +483,7 @@ simplifyApp hint resultTy f xs = case f of SimpInCore (ACase e alts _) -> dropSubst do defuncCase e resultTy \i x -> do Abs b body <- return $ alts !! i - extendSubst (b@>SubstVal x) do + extendSubstBD b [SubstVal x] do xs' <- mapM sinkM xs simplifyApp hint (sink resultTy) body xs' SimpInCore (LiftSimpFun _ lam) -> do @@ -485,12 +511,6 @@ simplifyAtomAndInline atom = confuseGHC >>= \_ -> case atom of Rename v' -> doInline =<< toAtomVar v' SubstVal (Var v') -> doInline v' SubstVal x -> return x - -- This is a hack because we weren't normalize the unwrapping of - -- `unit_type_scale` in `plot.dx`. We need a better system for deciding how to - -- normalize and inline. - ProjectElt _ i x -> do - x' <- simplifyAtom x >>= normalizeProj i - dropSubst $ simplifyAtomAndInline x' _ -> simplifyAtom atom >>= \case Var v -> doInline v ans -> return ans @@ -532,13 +552,13 @@ emitSpecialization s = do return name specializedFunCoreDefinition :: (Mut n, TopBuilder m) => SpecializationSpec n -> m n (TopLam CoreIR n) -specializedFunCoreDefinition (AppSpecialization f (Abs bs staticArgs)) = do - (asTopLam =<<) $ liftBuilder $ buildLamExpr (EmptyAbs bs) \runtimeArgs -> do +specializedFunCoreDefinition (AppSpecialization f ab) = do + (asTopLam =<<) $ liftBuilder $ buildLamExpr ab \runtimeArgs -> do -- This avoids an infinite loop. Otherwise, in simplifyTopFunction, -- where we eta-expand and try to simplify `App f args`, we would see `f` as a -- "noinline" function and defer its simplification. NoinlineFun _ f' <- lookupAtomName (atomVarName (sink f)) - ListE staticArgs' <- applyRename (bs@@>(atomVarName <$> runtimeArgs)) staticArgs + ListE staticArgs' <- instantiate ab (Var <$> runtimeArgs) naryApp f' staticArgs' simplifyTabApp :: forall i o. Emits o @@ -554,23 +574,23 @@ simplifyTabApp f@(SimpInCore sic) xs = case sic of atom <- emitDecls block' simplifyTabApp atom xsRest Nothing -> error "should never happen" - ACase e alts ty -> dropSubst do - resultTy <- typeOfTabApp ty xs - defuncCase e resultTy \i x -> do - Abs b body <- return $ alts !! i - extendSubst (b@>SubstVal x) do - xs' <- mapM sinkM xs - body' <- substM body - simplifyTabApp body' xs' - LiftSimp _ f' -> do - fTy <- return $ getType f - resultTy <- typeOfTabApp fTy xs - xs' <- mapM toDataAtomIgnoreRecon xs - liftSimpAtom resultTy =<< naryTabApp f' xs' + -- ACase e alts ty -> dropSubst do + -- resultTy <- typeOfTabApp ty xs + -- defuncCase e resultTy \i x -> do + -- Abs b body <- return $ alts !! i + -- extendSubst (b@>SubstVal x) do + -- xs' <- mapM sinkM xs + -- body' <- substM body + -- simplifyTabApp body' xs' + -- LiftSimp _ f' -> do + -- fTy <- return $ getType f + -- resultTy <- typeOfTabApp fTy xs + -- xs' <- mapM toDataAtomIgnoreRecon xs + -- liftSimpAtom resultTy =<< naryTabApp f' xs' LiftSimpFun _ _ -> error "not implemented" simplifyTabApp f _ = error $ "Unexpected table: " ++ pprint f -simplifyIxType :: IxType CoreIR o -> SimplifyM i o (IxType SimpIR o) +simplifyIxType :: Emits o => IxType CoreIR o -> SimplifyM i o (IxType SimpIR o) simplifyIxType (IxType t ixDict) = do t' <- getRepType t IxType t' <$> case ixDict of @@ -578,7 +598,7 @@ simplifyIxType (IxType t ixDict) = do n' <- toDataAtomIgnoreReconAssumeNoDecls n return $ IxDictRawFin n' IxDictAtom d -> do - (dictAbs, params) <- generalizeIxDict =<< cheapNormalize d + (dictAbs, params) <- generalizeIxDict d params' <- mapM toDataAtomIgnoreReconAssumeNoDecls params sdName <- requireIxDictCache dictAbs return $ IxDictSpecialized t' sdName params' @@ -605,11 +625,11 @@ requireIxDictCache dictAbs = do {-# INLINE requireIxDictCache #-} simplifyDictMethod :: Mut n => AbsDict n -> IxMethod -> TopBuilderM n (TopLam SimpIR n) -simplifyDictMethod absDict@(Abs bs dict) method = do +simplifyDictMethod absDict method = do ty <- liftEnvReaderM $ ixMethodType method absDict lamExpr <- liftBuilder $ buildTopLamFromPi ty \allArgs -> do - let (extraArgs, methodArgs) = splitAt (nestLength bs) allArgs - dict' <- applyRename (bs @@> (atomVarName <$> extraArgs)) dict + let (extraArgs, methodArgs) = splitAt (arity absDict) allArgs + dict' <- instantiate absDict (Var <$> extraArgs) emitExpr =<< mkApplyMethod dict' (fromEnum method) (Var <$> methodArgs) simplifyTopFunction lamExpr @@ -629,10 +649,8 @@ simplifyAtom atom = confuseGHC >>= \_ -> case atom of Con con -> Con <$> traverseOp con substM simplifyAtom (error "unexpected lambda") Eff eff -> Eff <$> substM eff PtrVar t v -> PtrVar t <$> substM v - DictCon t d -> (DictCon <$> substM t <*> substM d) >>= cheapNormalize - DictHole _ _ _ -> error "shouldn't have dict holes past inference" + DictCon t d -> DictCon <$> substM t <*> substM d NewtypeCon _ _ -> substM atom - ProjectElt _ i x -> normalizeProj i =<< simplifyAtom x SimpInCore _ -> substM atom TypeAsAtom _ -> substM atom @@ -653,29 +671,21 @@ simplifyVar v = do -- Assumes first order (args/results are "data", allowing newtypes), monormophic simplifyLam - :: LamExpr CoreIR i - -> SimplifyM i o (LamExpr SimpIR o, Abs (Nest (AtomNameBinder SimpIR)) ReconstructAtom o) -simplifyLam (LamExpr bsTop body) = case bsTop of - Nest (b:>ty) bs -> do - ty' <- substM ty - tySimp <- getRepType ty' - withFreshBinder (getNameHint b) tySimp \b''@(b':>_) -> do - x <- liftSimpAtom (sink ty') (Var $ binderVar b'') - extendSubst (b@>SubstVal x) do - (LamExpr bs' body', Abs bsRecon recon) <- simplifyLam $ LamExpr bs body - return (LamExpr (Nest (b':>tySimp) bs') body', Abs (Nest b' bsRecon) recon) - Empty -> do + :: Emits o => LamExpr CoreIR i + -> SimplifyM i o (LamExpr SimpIR o, Abs SBinders ReconstructAtom o) +simplifyLam (LamExpr bs body) = + simplifyBinders bs \_ -> do SimplifiedBlock body' recon <- buildSimplifiedBlock $ simplifyBlock body - return (LamExpr Empty body', Abs Empty recon) + return \bs' -> (LamExpr bs' body', Abs bs' recon) data SplitDataNonData n = SplitDataNonData { dataTy :: Type SimpIR n , nonDataTy :: Type CoreIR n , toSplit :: forall i l . CAtom l -> SimplifyM i l (SAtom l, CAtom l) - , fromSplit :: forall i l . DExt n l => SAtom l -> CAtom l -> SimplifyM i l (CAtom l) } + , fromSplit :: forall i l . (Emits l, DExt n l) => SAtom l -> CAtom l -> SimplifyM i l (CAtom l) } -- bijection between that type and a (data, non-data) pair type. -splitDataComponents :: Type CoreIR n -> SimplifyM i n (SplitDataNonData n) +splitDataComponents :: Emits n => Type CoreIR n -> SimplifyM i n (SplitDataNonData n) splitDataComponents = \case ProdTy tys -> do splits <- mapM splitDataComponents tys @@ -717,8 +727,8 @@ buildSimplifiedBlock cont = do case eitherResult of LeftE ans -> do (block, recon) <- refreshAbs (Abs decls ans) \decls' ans' -> do - (newResult, reconAbs) <- telescopicCapture (toScopeFrag decls') ans' - return (Abs decls' newResult, LamRecon reconAbs) + (Abs decls'' newResult, reconAbs) <- telescopicCapture (toScopeFrag decls') ans' + return (Abs (decls' >>> decls'') newResult, LamRecon reconAbs) return $ SimplifiedBlock block recon RightE (ans `PairE` ty) -> do let ty' = ignoreHoistFailure $ hoist (toScopeFrag decls) ty @@ -783,7 +793,7 @@ pattern CoerceReconAbs <- Abs _ (CoerceRecon _) applyDictMethod :: Emits o => CType o -> CAtom o -> Int -> [CAtom o] -> SimplifyM i o (CAtom o) applyDictMethod resultTy d i methodArgs = do - cheapNormalize d >>= \case + case d of DictCon _ (InstanceDict instanceName instanceArgs) -> dropSubst do instanceArgs' <- mapM simplifyAtom instanceArgs instanceDef <- lookupInstanceDef instanceName @@ -811,13 +821,15 @@ simplifyHof _hint resultTy = \case ans <- emitHof $ For d ixTypeSimp lam' case recon of CoerceRecon _ -> liftSimpAtom resultTy ans - LamRecon (Abs bsClosure reconResult) -> do + LamRecon (Abs bsClosure reconResult) -> dropSubst do TabPi resultTabTy <- return resultTy liftM (SimpInCore . TabLam resultTabTy) $ PairE ixTypeSimp <$> buildAbs noHint (ixTypeType ixTypeSimp) \i -> buildScoped do i' <- sinkM i - xs <- unpackTelescope bsClosure =<< tabApp (sink ans) (Var i') - applySubst (bIx@>Rename (atomVarName i') <.> bsClosure @@> map SubstVal xs) reconResult + extendSubstBD bIx [Rename (atomVarName i')] do + xs <- unpackTelescope bsClosure =<< tabApp (sink ans) (Var i') + extendSubst (bsClosure @@> map SubstVal xs) $ + substM reconResult While body -> do SimplifiedBlock body' (CoerceRecon _) <- buildSimplifiedBlock $ simplifyBlock body result <- emitHof $ While body' @@ -829,7 +841,8 @@ simplifyHof _hint resultTy = \case let recon' = ignoreHoistFailure $ hoist b recon applyRecon recon' ans RunWriter Nothing (BaseMonoid e combine) lam -> do - LamExpr (BinaryNest h (_:>RefTy _ wTy)) _ <- return lam + LamExpr (BinaryNest h refB) _ <- return lam + RefTy _ wTy <- return $ binderType refB wTy' <- substM $ ignoreHoistFailure $ hoist h wTy e' <- simplifyDataAtom e (combine', CoerceReconAbs) <- simplifyLam combine @@ -894,11 +907,13 @@ fmapMaybe fmapMaybe scrut f = do ~(MaybeTy justTy) <- return $ getType scrut (justAlt, resultJustTy) <- withFreshBinder noHint justTy \b -> do - result <- f (Var $ binderVar b) + result <- f (binderAtom b) resultTy <- return $ ignoreHoistFailure $ hoist b (getType result) result' <- preludeJustVal result - return (Abs b result', resultTy) - nothingAlt <- buildAbs noHint UnitTy \_ -> preludeNothingVal $ sink resultJustTy + return (Abs (PlainBD b) result', resultTy) + nothingAlt <- withFreshBinder noHint UnitTy \b -> do + result <- preludeNothingVal $ sink resultJustTy + return $ Abs (PlainBD b) result resultMaybeTy <- makePreludeMaybeTy resultJustTy return $ SimpInCore $ ACase scrut [nothingAlt, justAlt] resultMaybeTy @@ -961,7 +976,7 @@ tryGetCustomRule f' = do _ -> return Nothing _ -> return Nothing -type Linearized = Abs (Nest SBinder) -- primal args +type Linearized = Abs SBinders -- primal args (Abs (Nest SDecl) -- primal decls (PairE SAtom -- primal result SLam)) -- tangent function @@ -969,84 +984,86 @@ type Linearized = Abs (Nest SBinder) -- primal args simplifyCustomLinearization :: Abstracted CoreIR (ListE CAtom) n -> [Active] -> AtomRules n -> SimplifyM i n (PairE STopLam STopLam n) -simplifyCustomLinearization (Abs runtimeBs staticArgs) actives rule = do - CustomLinearize nImplicit nExplicit zeros fCustom <- return rule - linearized <- withSimplifiedBinders runtimeBs \runtimeBs' runtimeArgs -> do - Abs runtimeBs' <$> buildScoped do - ListE staticArgs' <- instantiate (sink $ Abs runtimeBs staticArgs) (sink <$> runtimeArgs) - fCustom' <- sinkM fCustom - resultTy <- typeOfApp (getType fCustom') staticArgs' - pairResult <- dropSubst $ simplifyApp noHint resultTy fCustom' staticArgs' - (primalResult, fLin) <- fromPair pairResult - primalResult' <- toDataAtomIgnoreRecon primalResult - let explicitPrimalArgs = drop nImplicit staticArgs' - allTangentTys <- forM explicitPrimalArgs \primalArg -> do - tangentType =<< getRepType (getType primalArg) - let actives' = drop (length actives - nExplicit) actives - activeTangentTys <- catMaybes <$> forM (zip allTangentTys actives') - \(t, active) -> return case active of True -> Just t; False -> Nothing - fLin' <- buildUnaryLamExpr "t" (ProdTy activeTangentTys) \activeTangentArg -> do - activeTangentArgs <- getUnpacked $ Var activeTangentArg - ListE allTangentTys' <- sinkM $ ListE allTangentTys - tangentArgs <- buildTangentArgs zeros (zip allTangentTys' actives') activeTangentArgs - -- TODO: we're throwing away core type information here. Once we - -- support core-level tangent types we should make an effort to - -- correctly restore the core types before applying `fLin`. Right now, - -- a custom linearization defined for a function on ADTs will - -- not work. - fLin' <- sinkM fLin - Pi (CorePiType _ _ bs _) <- return $ getType fLin' - let tangentCoreTys = fromNonDepNest bs - tangentArgs' <- zipWithM liftSimpAtom tangentCoreTys tangentArgs - resultTyTangent <- typeOfApp (getType fLin') tangentArgs' - tangentResult <- dropSubst $ simplifyApp noHint resultTyTangent fLin' tangentArgs' - toDataAtomIgnoreRecon tangentResult - return $ PairE primalResult' fLin' - PairE primalFun tangentFun <- defuncLinearized linearized - primalFun' <- asTopLam primalFun - tangentFun' <- asTopLam tangentFun - return $ PairE primalFun' tangentFun' - where - buildTangentArgs :: Emits n => SymbolicZeros -> [(SType n, Active)] -> [SAtom n] -> SimplifyM i n [SAtom n] - buildTangentArgs _ [] [] = return [] - buildTangentArgs zeros ((t, False):tys) activeArgs = do - inactiveArg <- case zeros of - SymbolicZeros -> symbolicTangentZero t - InstantiateZeros -> zeroAt t - rest <- buildTangentArgs zeros tys activeArgs - return $ inactiveArg:rest - buildTangentArgs zeros ((_, True):tys) (activeArg:activeArgs) = do - activeArg' <- case zeros of - SymbolicZeros -> symbolicTangentNonZero activeArg - InstantiateZeros -> return activeArg - rest <- buildTangentArgs zeros tys activeArgs - return $ activeArg':rest - buildTangentArgs _ _ _ = error "zip error" - - fromNonDepNest :: Nest CBinder n l -> [CType n] - fromNonDepNest Empty = [] - fromNonDepNest (Nest b bs) = - case ignoreHoistFailure $ hoist b (Abs bs UnitE) of - Abs bs' UnitE -> binderType b : fromNonDepNest bs' - -defuncLinearized :: EnvReader m => Linearized n -> m n (PairE SLam SLam n) -defuncLinearized ab = liftBuilder $ refreshAbs ab \bs ab' -> do - (declsAndResult, reconAbs, residualsTangentsBs) <- - refreshAbs ab' \decls (PairE primalResult fLin) -> do - (residuals, reconAbs) <- telescopicCapture (toScopeFrag decls) fLin - let rTy = getType residuals - LamExpr tBs _ <- return fLin - residualsTangentsBs <- withFreshBinder "residual" rTy \rB -> do - Abs tBs' UnitE <- sinkM $ Abs tBs UnitE - return $ Abs (Nest rB tBs') UnitE - residualsTangentsBs' <- return $ ignoreHoistFailure $ hoist decls residualsTangentsBs - return (Abs decls (PairVal primalResult residuals), reconAbs, residualsTangentsBs') - let primalFun = LamExpr bs declsAndResult - LamExpr residualAndTangentBs tangentBody <- buildLamExpr residualsTangentsBs \(residuals:tangents) -> do - LamExpr tangentBs' body <- applyReconAbs (sink reconAbs) (Var residuals) - applyRename (tangentBs' @@> (atomVarName <$> tangents)) body >>= emitBlock - let tangentFun = LamExpr (bs >>> residualAndTangentBs) tangentBody - return $ PairE primalFun tangentFun +simplifyCustomLinearization _ = undefined -- (Abs runtimeBs staticArgs) actives rule = undefined +-- simplifyCustomLinearization (Abs runtimeBs staticArgs) actives rule = do +-- CustomLinearize nImplicit nExplicit zeros fCustom <- return rule +-- linearized <- simplifyBinders runtimeBs \runtimeBs' runtimeArgs -> do +-- Abs runtimeBs' <$> buildScoped do +-- ListE staticArgs' <- instantiate (Abs runtimeBs staticArgs) (sink <$> runtimeArgs) +-- fCustom' <- sinkM fCustom +-- resultTy <- typeOfApp (getType fCustom') staticArgs' +-- pairResult <- dropSubst $ simplifyApp noHint resultTy fCustom' staticArgs' +-- (primalResult, fLin) <- fromPair pairResult +-- primalResult' <- toDataAtomIgnoreRecon primalResult +-- let explicitPrimalArgs = drop nImplicit staticArgs' +-- allTangentTys <- forM explicitPrimalArgs \primalArg -> do +-- tangentType =<< getRepType (getType primalArg) +-- let actives' = drop (length actives - nExplicit) actives +-- activeTangentTys <- catMaybes <$> forM (zip allTangentTys actives') +-- \(t, active) -> return case active of True -> Just t; False -> Nothing +-- fLin' <- buildUnaryLamExpr "t" (ProdTy activeTangentTys) \activeTangentArg -> do +-- activeTangentArgs <- getUnpacked $ Var activeTangentArg +-- ListE allTangentTys' <- sinkM $ ListE allTangentTys +-- tangentArgs <- buildTangentArgs zeros (zip allTangentTys' actives') activeTangentArgs +-- -- TODO: we're throwing away core type information here. Once we +-- -- support core-level tangent types we should make an effort to +-- -- correctly restore the core types before applying `fLin`. Right now, +-- -- a custom linearization defined for a function on ADTs will +-- -- not work. +-- fLin' <- sinkM fLin +-- Pi (CorePiType _ _ bs _) <- return $ getType fLin' +-- let tangentCoreTys = fromNonDepNest bs +-- tangentArgs' <- zipWithM liftSimpAtom tangentCoreTys tangentArgs +-- resultTyTangent <- typeOfApp (getType fLin') tangentArgs' +-- tangentResult <- dropSubst $ simplifyApp noHint resultTyTangent fLin' tangentArgs' +-- toDataAtomIgnoreRecon tangentResult +-- return $ PairE primalResult' fLin' +-- PairE primalFun tangentFun <- defuncLinearized linearized +-- primalFun' <- asTopLam primalFun +-- tangentFun' <- asTopLam tangentFun +-- return $ PairE primalFun' tangentFun' +-- where +-- buildTangentArgs :: Emits n => SymbolicZeros -> [(SType n, Active)] -> [SAtom n] -> SimplifyM i n [SAtom n] +-- buildTangentArgs _ [] [] = return [] +-- buildTangentArgs zeros ((t, False):tys) activeArgs = do +-- inactiveArg <- case zeros of +-- SymbolicZeros -> symbolicTangentZero t +-- InstantiateZeros -> zeroAt t +-- rest <- buildTangentArgs zeros tys activeArgs +-- return $ inactiveArg:rest +-- buildTangentArgs zeros ((_, True):tys) (activeArg:activeArgs) = do +-- activeArg' <- case zeros of +-- SymbolicZeros -> symbolicTangentNonZero activeArg +-- InstantiateZeros -> return activeArg +-- rest <- buildTangentArgs zeros tys activeArgs +-- return $ activeArg':rest +-- buildTangentArgs _ _ _ = error "zip error" + +-- fromNonDepNest :: Nest CBinderAndDecls n l -> [CType n] +-- fromNonDepNest Empty = [] +-- fromNonDepNest (Nest b bs) = +-- case ignoreHoistFailure $ hoist b (Abs bs UnitE) of +-- Abs bs' UnitE -> binderType b : fromNonDepNest bs' + +_defuncLinearized :: EnvReader m => Linearized n -> m n (PairE SLam SLam n) +_defuncLinearized _ = undefined +-- defuncLinearized ab = liftBuilder $ refreshAbs ab \bs ab' -> do +-- (declsAndResult, reconAbs, residualsTangentsBs) <- +-- refreshAbs ab' \decls (PairE primalResult fLin) -> do +-- (residuals, reconAbs) <- telescopicCapture (toScopeFrag decls) fLin +-- let rTy = getType residuals +-- LamExpr tBs _ <- return fLin +-- residualsTangentsBs <- withFreshBinder "residual" rTy \rB -> do +-- Abs tBs' UnitE <- sinkM $ Abs tBs UnitE +-- return $ Abs (Nest (BD rB) tBs') UnitE +-- residualsTangentsBs' <- return $ ignoreHoistFailure $ hoist decls residualsTangentsBs +-- return (Abs decls (PairVal primalResult residuals), reconAbs, residualsTangentsBs') +-- let primalFun = LamExpr bs declsAndResult +-- LamExpr residualAndTangentBs tangentBody <- buildLamExpr residualsTangentsBs \(residuals:tangents) -> do +-- lam <- applyReconAbs (sink reconAbs) (Var residuals) +-- instantiate lam (Var <$> tangents) >>= emitBlock +-- let tangentFun = LamExpr (bs >>> residualAndTangentBs) tangentBody +-- return $ PairE primalFun tangentFun -- === exception-handling pass === @@ -1095,7 +1112,7 @@ exceptToMaybeExpr expr = case expr of s' <- substM s BinaryLamExpr h ref body <- return lam result <- emitRunState noHint s' \h' ref' -> - extendSubst (h @> Rename (atomVarName h') <.> ref @> Rename (atomVarName ref')) do + extendSubstBD (BinaryNest h ref) [Rename (atomVarName h'), Rename (atomVarName ref')] do blockResultTy <- blockTy =<< substM body -- TODO: avoid this by caching the type exceptToMaybeBlock blockResultTy body (maybeAns, newState) <- fromPair result @@ -1107,7 +1124,7 @@ exceptToMaybeExpr expr = case expr of monoid' <- substM monoid PairTy _ accumTy <- substM resultTy result <- emitRunWriter noHint accumTy monoid' \h' ref' -> - extendSubst (h @> Rename (atomVarName h') <.> ref @> Rename (atomVarName ref')) do + extendSubstBD (BinaryNest h ref) [Rename (atomVarName h'), Rename (atomVarName ref')] do blockResultTy <- blockTy =<< substM body -- TODO: avoid this by caching the type exceptToMaybeBlock blockResultTy body (maybeAns, accumResult) <- fromPair result diff --git a/src/lib/Subst.hs b/src/lib/Subst.hs index 5b13ef624..5de201e8d 100644 --- a/src/lib/Subst.hs +++ b/src/lib/Subst.hs @@ -14,6 +14,7 @@ import Control.Applicative import Control.Monad.Identity import Control.Monad.Reader import Control.Monad.State.Strict +import Data.Functor ((<&>)) import Name import IRVariants @@ -21,6 +22,8 @@ import Types.Core import Core import qualified RawName as R import Err +import Visitor +import Types.Imp -- === SubstReader class === @@ -245,10 +248,6 @@ data SubstVal (atom::IR->E) (c::C) (n::S) where Rename :: Name c n -> SubstVal atom c n type AtomSubstVal = SubstVal Atom -type family IsAtomName (c::C) where - IsAtomName (AtomNameC r) = True - IsAtomName _ = False - instance (Color c, IsAtomName c ~ False) => SubstE (SubstVal atom) (Name c) where substE (_, env) v = case env ! v of Rename v' -> v' @@ -498,3 +497,144 @@ instance (SubstE v e0, SubstE v e1, SubstE v e2, Case6 e -> Case6 $ substE env e Case7 e -> Case7 $ substE env e {-# INLINE substE #-} + +newtype SubstVisitor i o a = SubstVisitor { runSubstVisitor :: Reader (Env o, Subst AtomSubstVal i o) a } + deriving (Functor, Applicative, Monad, MonadReader (Env o, Subst AtomSubstVal i o)) + +substV :: (Distinct o, SubstE AtomSubstVal e) => e i -> SubstVisitor i o (e o) +substV x = ask <&> \env -> substE env x + +instance Distinct o => NonAtomRenamer (SubstVisitor i o) i o where + renameN = substV + +instance (Distinct o, IRRep r) => Visitor (SubstVisitor i o) r i o where + visitType = substV + visitAtom = substV + visitLam = substV + visitPi = substV + +instance Color c => SubstE AtomSubstVal (AtomSubstVal c) where + substE (_, env) (Rename name) = env ! name + substE env (SubstVal val) = SubstVal $ substE env val + +instance SubstV (SubstVal Atom) (SubstVal Atom) where + +instance IRRep r => SubstE AtomSubstVal (Atom r) where + substE es@(_, subst) = \case + Var (AtomVar v ty) -> case subst!v of + Rename v' -> Var $ AtomVar v' (substE es ty) + SubstVal x -> x + SimpInCore x -> SimpInCore (substE es x) + atom -> runReader (runSubstVisitor $ visitAtomPartial atom) es + +instance IRRep r => SubstE AtomSubstVal (Type r) where + substE es@(_, subst) = \case + TyVar (AtomVar v ty) -> case subst ! v of + Rename v' -> TyVar $ AtomVar v' (substE es ty) + SubstVal (Type t) -> t + SubstVal atom -> error $ "bad substitution: " ++ pprint v ++ " -> " ++ pprint atom + ty -> runReader (runSubstVisitor $ visitTypePartial ty) es + +instance SubstE AtomSubstVal SimpInCore + +instance IRRep r => SubstE AtomSubstVal (EffectRow r) where + substE env (EffectRow effs tailVar) = do + let effs' = eSetFromList $ map (substE env) (eSetToList effs) + let tailEffRow = case tailVar of + NoTail -> EffectRow mempty NoTail + EffectRowTail (AtomVar v _) -> case snd env ! v of + Rename v' -> do + let v'' = runEnvReaderM (fst env) $ toAtomVar v' + EffectRow mempty (EffectRowTail v'') + SubstVal (Var v') -> EffectRow mempty (EffectRowTail v') + SubstVal (Eff r) -> r + _ -> error "Not a valid effect substitution" + extendEffRow effs' tailEffRow + +instance IRRep r => SubstE AtomSubstVal (Effect r) + +instance SubstE AtomSubstVal SpecializationSpec where + substE env (AppSpecialization (AtomVar f _) ab) = do + let f' = case snd env ! f of + Rename v -> runEnvReaderM (fst env) $ toAtomVar v + SubstVal (Var v) -> v + _ -> error "bad substitution" + AppSpecialization f' (substE env ab) + +instance SubstE AtomSubstVal EffectDef +instance SubstE AtomSubstVal EffectOpType +instance SubstE AtomSubstVal IExpr +instance IRRep r => SubstE AtomSubstVal (RepVal r) +instance SubstE AtomSubstVal TyConParams +instance SubstE AtomSubstVal DataConDef +instance IRRep r => SubstE AtomSubstVal (BaseMonoid r) +instance IRRep r => SubstE AtomSubstVal (DAMOp r) +instance IRRep r => SubstE AtomSubstVal (TypedHof r) +instance IRRep r => SubstE AtomSubstVal (Hof r) +instance IRRep r => SubstE AtomSubstVal (TC r) +instance IRRep r => SubstE AtomSubstVal (Con r) +instance IRRep r => SubstE AtomSubstVal (MiscOp r) +instance IRRep r => SubstE AtomSubstVal (VectorOp r) +instance IRRep r => SubstE AtomSubstVal (MemOp r) +instance IRRep r => SubstE AtomSubstVal (PrimOp r) +instance IRRep r => SubstE AtomSubstVal (RefOp r) +instance IRRep r => SubstE AtomSubstVal (EffTy r) +instance IRRep r => SubstE AtomSubstVal (Expr r) +instance IRRep r => SubstE AtomSubstVal (GenericOpRep const r) +instance SubstE AtomSubstVal InstanceBody +instance SubstE AtomSubstVal DictType +instance SubstE AtomSubstVal DictExpr +instance IRRep r => SubstE AtomSubstVal (LamExpr r) +instance SubstE AtomSubstVal CorePiType +instance SubstE AtomSubstVal CoreLamExpr +instance IRRep r => SubstE AtomSubstVal (TabPiType r) +instance IRRep r => SubstE AtomSubstVal (PiType r) +instance IRRep r => SubstE AtomSubstVal (DepPairType r) +instance SubstE AtomSubstVal SolverBinding +instance IRRep r => SubstE AtomSubstVal (DeclBinding r) +instance IRRep r => SubstB AtomSubstVal (Decl r) +instance IRRep r => SubstB AtomSubstVal (BinderAndDecls r) +instance SubstE AtomSubstVal NewtypeTyCon +instance SubstE AtomSubstVal NewtypeCon +instance IRRep r => SubstE AtomSubstVal (IxDict r) +instance IRRep r => SubstE AtomSubstVal (IxType r) +instance SubstE AtomSubstVal DataConDefs + +-- === defaults visitors based on substitution === + +visitAtomDefault + :: (IRRep r, Visitor (m i o) r i o, AtomSubstReader v m, EnvReader2 m) + => Atom r i -> m i o (Atom r o) +visitAtomDefault atom = case atom of + Var _ -> atomSubstM atom + SimpInCore _ -> atomSubstM atom + _ -> visitAtomPartial atom + +visitTypeDefault + :: (IRRep r, Visitor (m i o) r i o, AtomSubstReader v m, EnvReader2 m) + => Type r i -> m i o (Type r o) +visitTypeDefault = \case + TyVar v -> atomSubstM $ TyVar v + x -> visitTypePartial x + +visitPiDefault + :: (Visitor2 m r, IRRep r, FromName v, AtomSubstReader v m, EnvExtender2 m) + => PiType r i -> m i o (PiType r o) +visitPiDefault (PiType bs effty) = do + visitBinders bs \bs' -> do + effty' <- visitGeneric effty + return $ PiType bs' effty' + +visitBinders + :: (Visitor2 m r, IRRep r, FromName v, AtomSubstReader v m, EnvExtender2 m) + => Binders r i i' + -> (forall o'. DExt o o' => Binders r o o' -> m i' o' a) + -> m i o a +visitBinders Empty cont = getDistinct >>= \Distinct -> cont Empty +visitBinders _ _ = undefined +-- visitBinders (Nest (BD (b:>ty)) bs) cont = do +-- ty' <- visitType ty +-- withFreshBinder (getNameHint b) ty' \b' -> do +-- extendRenamer (b@>binderName b') do +-- visitBinders bs \bs' -> +-- cont $ Nest (BD b') bs' diff --git a/src/lib/TopLevel.hs b/src/lib/TopLevel.hs index caf3d591c..e6eb208cb 100644 --- a/src/lib/TopLevel.hs +++ b/src/lib/TopLevel.hs @@ -49,7 +49,6 @@ import CheckType (checkTypes) #endif import Core import ConcreteSyntax -import CheapReduction import Err import IRVariants import Imp @@ -277,10 +276,10 @@ evalSourceBlock' mname block = case sbContents block of -- "Can't export functions with captured pointers (not implemented)." -- _ -> return $ Con $ Lit val -- logTop $ ExportedFun name f - GetType -> do -- TODO: don't actually evaluate it - val <- evalUExpr expr - ty <- cheapNormalize $ getType val - logTop $ TextOut $ pprintCanonicalized ty + -- GetType -> do -- TODO: don't actually evaluate it + -- val <- evalUExpr expr + -- ty <- cheapNormalize $ getType val + -- logTop $ TextOut $ pprintCanonicalized ty DeclareForeign fname dexName cTy -> do let b = fromString dexName :: UBinder (AtomNameC CoreIR) VoidS VoidS ty <- evalUType =<< parseExpr cTy @@ -328,9 +327,14 @@ evalSourceBlock' mname block = case sbContents block of $ "Custom linearization can only be defined for functions" UnParseable _ s -> throw ParseErr s Misc m -> case m of - GetNameType v -> do - ty <- cheapNormalize =<< sourceNameType v - logTop $ TextOut $ pprintCanonicalized ty + -- GetNameType v -> do + -- ty <- cheapNormalize =<< sourceNameType v + -- logTop $ TextOut $ pprintCanonicalized ty + -- sourceNameType :: (EnvReader m, Fallible1 m) => SourceName -> m n (Type CoreIR n) + -- sourceNameType v = do + -- lookupSourceMap v >>= \case + -- Nothing -> throw UnboundVarErr $ pprint v + -- Just uvar -> getUVarType uvar ImportModule moduleName -> importModule moduleName QueryEnv query -> void $ runEnvQuery query $> UnitE ProseBlock _ -> return () diff --git a/src/lib/Transpose.hs b/src/lib/Transpose.hs index 904e608d1..474e82a07 100644 --- a/src/lib/Transpose.hs +++ b/src/lib/Transpose.hs @@ -15,7 +15,6 @@ import GHC.Stack import Builder import Core -import CheapReduction import Err import Imp import IRVariants @@ -43,27 +42,28 @@ runTransposeM cont = runReaderT1 (ListE []) $ runSubstReaderT idSubst $ cont transposeTopFun :: (MonadFail1 m, EnvReader m) => STopLam n -> m n (STopLam n) -transposeTopFun (TopLam False _ lam) = liftBuilder $ runTransposeM do - (Abs bsNonlin (Abs bLin body), Abs bsNonlin'' outTy) <- unpackLinearLamExpr lam - refreshBinders bsNonlin \bsNonlin' substFrag -> extendRenamer substFrag do - outTy' <- applyRename (bsNonlin''@@> nestToNames bsNonlin') outTy - withFreshBinder "ct" outTy' \bCT -> do - let ct = Var $ binderVar bCT - body' <- buildBlock do - inTy <- substNonlin $ binderType bLin - withAccumulator inTy \refSubstVal -> - extendSubst (bLin @> refSubstVal) $ - transposeBlock body (sink ct) - EffTy _ bodyTy <- blockEffTy body' - let piTy = PiType (bsNonlin' >>> UnaryNest bCT) (EffTy Pure bodyTy) - let lamT = LamExpr (bsNonlin' >>> UnaryNest bCT) body' - return $ TopLam False piTy lamT -transposeTopFun (TopLam True _ _) = error "shouldn't be transposing in destination passing style" +transposeTopFun (TopLam False _ lam) = undefined +-- transposeTopFun (TopLam False _ lam) = liftBuilder $ runTransposeM do +-- (Abs bsNonlin (Abs bLin body), outTyAbs) <- unpackLinearLamExpr lam +-- refreshBinders bsNonlin \bsNonlin' substFrag -> extendRenamer substFrag do +-- outTy <- instantiate outTyAbs (Var <$> bindersVars bsNonlin') +-- withFreshBinder "ct" outTy \bCT -> do +-- let ct = Var $ binderVar bCT +-- body' <- buildBlock do +-- inTy <- substNonlin $ binderType bLin +-- withAccumulator inTy \refSubstVal -> +-- extendSubstBD bLin [refSubstVal] $ +-- transposeBlock body (sink ct) +-- EffTy _ bodyTy <- blockEffTy body' +-- let piTy = PiType (bsNonlin' >>> UnaryNest (PlainBD bCT)) (EffTy Pure bodyTy) +-- let lamT = LamExpr (bsNonlin' >>> UnaryNest (PlainBD bCT)) body' +-- return $ TopLam False piTy lamT +-- transposeTopFun (TopLam True _ _) = error "shouldn't be transposing in destination passing style" unpackLinearLamExpr :: (MonadFail1 m, EnvReader m) => LamExpr SimpIR n - -> m n ( Abs (Nest SBinder) (Abs SBinder SBlock) n - , Abs (Nest SBinder) SType n) + -> m n ( Abs SBinders (Abs SBinderAndDecls SBlock) n + , Abs SBinders SType n) unpackLinearLamExpr lam@(LamExpr bs body) = do let numNonlin = nestLength bs - 1 PairB bsNonlin (UnaryNest bLin) <- return $ splitNestAt numNonlin bs @@ -216,15 +216,6 @@ transposeExpr expr ct = case expr of refProj <- naryIndexRef ref (toList is') emitCTToRef refProj ct LinTrivial -> return () - ProjectElt _ i' x' -> do - let (idxs, v) = asNaryProj i' x' - lookupSubstM (atomVarName v) >>= \case - RenameNonlin _ -> error "an error, probably" - LinRef ref -> do - ref' <- getNaryProjRef (toList idxs) ref - refProj <- naryIndexRef ref' (toList is') - emitCTToRef refProj ct - LinTrivial -> return () _ -> error $ "shouldn't occur: " ++ pprint x PrimOp op -> transposeOp op ct Case e alts _ -> do @@ -245,6 +236,15 @@ transposeExpr expr ct = case expr of forM_ (enumerate es) \(ordinalIdx, e) -> do i <- unsafeFromOrdinal idxTy (IdxRepVal $ fromIntegral ordinalIdx) tabApp ct i >>= transposeAtom e + ProjectElt _ i' x' -> undefined + -- ProjectElt _ i' x' -> do + -- let (idxs, v) = asNaryProj i' x' + -- lookupSubstM (atomVarName v) >>= \case + -- RenameNonlin _ -> error "an error, probably" + -- LinRef ref -> do + -- ref' <- getNaryProjRef (toList idxs) ref + -- emitCTToRef ref' ct + -- LinTrivial -> return () transposeOp :: Emits o => PrimOp SimpIR i -> SAtom o -> TransposeM i o () transposeOp op ct = case op of @@ -315,14 +315,6 @@ transposeAtom atom ct = case atom of Con con -> transposeCon con ct DepPair _ _ _ -> notImplemented PtrVar _ _ -> notTangent - ProjectElt _ i' x' -> do - let (idxs, v) = asNaryProj i' x' - lookupSubstM (atomVarName v) >>= \case - RenameNonlin _ -> error "an error, probably" - LinRef ref -> do - ref' <- getNaryProjRef (toList idxs) ref - emitCTToRef ref' ct - LinTrivial -> return () RepValAtom _ -> error "not implemented" where notTangent = error $ "Not a tangent atom: " ++ pprint atom @@ -338,7 +330,7 @@ transposeHof hof ct = case hof of RunState Nothing s (BinaryLamExpr hB refB body) -> do (ctBody, ctState) <- fromPair ct (_, cts) <- (fromPair =<<) $ emitRunState noHint ctState \h ref -> do - extendSubst (hB@>RenameNonlin (atomVarName h)) $ extendSubst (refB@>RenameNonlin (atomVarName ref)) $ + extendSubstBD hB [RenameNonlin (atomVarName h)] $ extendSubstBD refB [RenameNonlin (atomVarName ref)] $ extendLinRegions h $ transposeBlock body (sink ctBody) return UnitVal @@ -347,7 +339,7 @@ transposeHof hof ct = case hof of accumTy <- substNonlin $ getType r baseMonoid <- tangentBaseMonoidFor accumTy (_, ct') <- (fromPair =<<) $ emitRunWriter noHint accumTy baseMonoid \h ref -> do - extendSubst (hB@>RenameNonlin (atomVarName h)) $ extendSubst (refB@>RenameNonlin (atomVarName ref)) $ + extendSubstBD hB [RenameNonlin (atomVarName h)] $ extendSubstBD refB [RenameNonlin (atomVarName ref)] $ extendLinRegions h $ transposeBlock body (sink ct) return UnitVal @@ -356,7 +348,7 @@ transposeHof hof ct = case hof of -- TODO: check we have the 0/+ monoid (ctBody, ctEff) <- fromPair ct void $ emitRunReader noHint ctEff \h ref -> do - extendSubst (hB@>RenameNonlin (atomVarName h)) $ extendSubst (refB@>RenameNonlin (atomVarName ref)) $ + extendSubstBD hB [RenameNonlin (atomVarName h)] $ extendSubstBD refB [RenameNonlin (atomVarName ref)] $ extendLinRegions h $ transposeBlock body (sink ctBody) return UnitVal diff --git a/src/lib/Types/Core.hs b/src/lib/Types/Core.hs index 067af737e..a60ad149f 100644 --- a/src/lib/Types/Core.hs +++ b/src/lib/Types/Core.hs @@ -23,6 +23,7 @@ module Types.Core (module Types.Core, SymbolicZeros (..)) where +import Control.Category ((>>>)) import Data.Word import Data.Maybe (fromJust) import Data.Functor @@ -51,15 +52,12 @@ data Atom (r::IR) (n::S) where Var :: AtomVar r n -> Atom r n Con :: Con r n -> Atom r n PtrVar :: PtrType -> PtrName n -> Atom r n - ProjectElt :: Type r n -> Projection -> Atom r n -> Atom r n DepPair :: Atom r n -> Atom r n -> DepPairType r n -> Atom r n -- === CoreIR only === Lam :: CoreLamExpr n -> Atom CoreIR n Eff :: EffectRow CoreIR n -> Atom CoreIR n DictCon :: Type CoreIR n -> DictExpr n -> Atom CoreIR n NewtypeCon :: NewtypeCon n -> Atom CoreIR n -> Atom CoreIR n - DictHole :: AlwaysEqual SrcPosCtx -> Type CoreIR n -> RequiredMethodAccess - -> Atom CoreIR n TypeAsAtom :: Type CoreIR n -> Atom CoreIR n -- === Shims between IRs === SimpInCore :: SimpInCore n -> Atom CoreIR n @@ -73,10 +71,6 @@ data Type (r::IR) (n::S) where DictTy :: DictType n -> Type CoreIR n Pi :: CorePiType n -> Type CoreIR n NewtypeTyCon :: NewtypeTyCon n -> Type CoreIR n - -- It was bad enough having this in `Atom`, but it's even worse now that it's - -- replicated in `Type` too. We should be able to remove both once - -- we represent types as normalized blocks. - ProjectEltTy :: CType n -> Projection -> CAtom n -> Type CoreIR n data AtomVar (r::IR) (n::S) = AtomVar { atomVarName :: AtomName r n @@ -88,7 +82,7 @@ data SimpInCore (n::S) = LiftSimp (CType n) (SAtom n) | LiftSimpFun (CorePiType n) (LamExpr SimpIR n) | TabLam (TabPiType CoreIR n) (TabLamExpr n) - | ACase (SAtom n) [Abs SBinder CAtom n] (CType n) + | ACase (SAtom n) [Abs SBinderAndDecls CAtom n] (CType n) deriving (Show, Generic) deriving instance IRRep r => Show (Atom r n) @@ -105,6 +99,8 @@ data Expr r n where PrimOp :: PrimOp r n -> Expr r n App :: EffTy CoreIR n -> CAtom n -> [CAtom n] -> Expr CoreIR n ApplyMethod :: EffTy CoreIR n -> CAtom n -> Int -> [CAtom n] -> Expr CoreIR n + ProjectElt :: Type r n -> Projection -> Atom r n -> Expr r n + DictHole :: AlwaysEqual SrcPosCtx -> Type CoreIR n -> RequiredMethodAccess -> Expr CoreIR n deriving instance IRRep r => Show (Expr r n) deriving via WrapE (Expr r) n instance IRRep r => Generic (Expr r n) @@ -143,6 +139,11 @@ type AtomBinderP (r::IR) = BinderP (AtomNameC r) type Binder r = AtomBinderP r (Type r) :: B type Alt r = Abs (Binder r) (Block r) :: E +data BinderAndDecls (r::IR) (n::S) (l::S) where + BD :: Binder r n l -> Nest (Decl r) l l' -> BinderAndDecls r n l' + +type Binders r = Nest (BinderAndDecls r) + newtype DotMethods n = DotMethods (M.Map SourceName (CAtomName n)) deriving (Show, Generic, Monoid, Semigroup) @@ -152,7 +153,7 @@ data TyConDef n where TyConDef :: SourceName -> [RoleExpl] - -> Nest CBinder n l + -> CBinders n l -> DataConDefs l -> TyConDef n @@ -164,7 +165,7 @@ data DataConDefs n = data DataConDef n = -- Name for pretty printing, constructor elements, representation type, -- list of projection indices that recovers elements from the representation. - DataConDef SourceName (EmptyAbs (Nest CBinder) n) (CType n) [[Projection]] + DataConDef SourceName (EmptyAbs CBinders n) (CType n) [[Projection]] deriving (Show, Generic) data ParamRole = TypeParam | DictParam | DataParam deriving (Show, Generic, Eq) @@ -183,7 +184,7 @@ data TopLam (r::IR) (n::S) = TopLam IsDestLam (PiType r n) (LamExpr r n) deriving (Show, Generic) data LamExpr (r::IR) (n::S) where - LamExpr :: Nest (Binder r) n l -> Block r l -> LamExpr r n + LamExpr :: Binders r n l -> Block r l -> LamExpr r n data CoreLamExpr (n::S) = CoreLamExpr (CorePiType n) (LamExpr CoreIR n) @@ -209,16 +210,16 @@ data IxType (r::IR) (n::S) = deriving (Show, Generic) data TabPiType (r::IR) (n::S) where - TabPiType :: IxDict r n -> Binder r n l -> Type r l -> TabPiType r n + TabPiType :: IxDict r n -> BinderAndDecls r n l -> Type r l -> TabPiType r n data PiType (r::IR) (n::S) where - PiType :: Nest (Binder r) n l -> EffTy r l -> PiType r n + PiType :: Binders r n l -> EffTy r l -> PiType r n data CorePiType (n::S) where - CorePiType :: AppExplicitness -> [Explicitness] -> Nest CBinder n l -> EffTy CoreIR l -> CorePiType n + CorePiType :: AppExplicitness -> [Explicitness] -> CBinders n l -> EffTy CoreIR l -> CorePiType n data DepPairType (r::IR) (n::S) where - DepPairType :: DepPairExplicitness -> Binder r n l -> Type r l -> DepPairType r n + DepPairType :: DepPairExplicitness -> BinderAndDecls r n l -> Type r l -> DepPairType r n type Val = Atom type Kind = Type @@ -233,8 +234,17 @@ data NonDepNest r ann n l = NonDepNest (Nest (AtomNameBinder r) n l) [ann n] -- === ToAtomAbs class === +class ToBinders (b::B) (r::IR) | b -> r where + toBinders :: b n l -> Binders r n l + +instance ToBinders (BinderAndDecls r) r where + toBinders b = UnaryNest b + +instance ToBinders (Binders r) r where + toBinders b = b + class ToBindersAbs (e::E) (body::E) (r::IR) | e -> body, e -> r where - toAbs :: e n -> Abs (Nest (Binder r)) body n + toAbs :: e n -> Abs (Binders r) body n instance ToBindersAbs CorePiType (EffTy CoreIR) CoreIR where toAbs (CorePiType _ _ bs effTy) = Abs bs effTy @@ -242,8 +252,8 @@ instance ToBindersAbs CorePiType (EffTy CoreIR) CoreIR where instance ToBindersAbs CoreLamExpr (Block CoreIR) CoreIR where toAbs (CoreLamExpr _ lam) = toAbs lam -instance ToBindersAbs (Abs (Nest (Binder r)) body) body r where - toAbs = id +instance ToBinders b r => ToBindersAbs (Abs b body) body r where + toAbs (Abs b e) = Abs (toBinders b) e instance ToBindersAbs (PiType r) (EffTy r) r where toAbs (PiType bs effTy) = Abs bs effTy @@ -263,7 +273,7 @@ instance ToBindersAbs InstanceDef (ListE CAtom `PairE` InstanceBody) CoreIR wher instance ToBindersAbs TyConDef DataConDefs CoreIR where toAbs (TyConDef _ _ bs body) = Abs bs body -instance ToBindersAbs ClassDef (Abs (Nest CBinder) (ListE CorePiType)) CoreIR where +instance ToBindersAbs ClassDef (Abs CBinders (ListE CorePiType)) CoreIR where toAbs (ClassDef _ _ _ _ bs scBs tys) = Abs bs (Abs scBs (ListE tys)) instance ToBindersAbs (TopLam r) (Block r) r where @@ -432,6 +442,8 @@ data RefOp r n = type CAtom = Atom CoreIR type CType = Type CoreIR type CBinder = Binder CoreIR +type CBinderAndDecls = BinderAndDecls CoreIR +type CBinders = Binders CoreIR type CExpr = Expr CoreIR type CBlock = Block CoreIR type CDecl = Decl CoreIR @@ -450,6 +462,8 @@ type SDecls = Decls SimpIR type SAtomName = AtomName SimpIR type SAtomVar = AtomVar SimpIR type SBinder = Binder SimpIR +type SBinderAndDecls = BinderAndDecls SimpIR +type SBinders = Binders SimpIR type SRepVal = RepVal SimpIR type SLam = LamExpr SimpIR type STopLam = TopLam SimpIR @@ -488,8 +502,8 @@ data ClassDef (n::S) where -> [SourceName] -- method source names -> [Maybe SourceName] -- parameter source names -> [RoleExpl] -- parameter info - -> Nest CBinder n1 n2 -- parameters - -> Nest CBinder n2 n3 -- superclasses + -> CBinders n1 n2 -- parameters + -> CBinders n2 n3 -- superclasses -> [CorePiType n3] -- method types -> ClassDef n1 @@ -497,7 +511,7 @@ data InstanceDef (n::S) where InstanceDef :: ClassName n1 -> [RoleExpl] -- parameter info - -> Nest CBinder n1 n2 -- parameters (types and dictionaries) + -> CBinders n1 n2 -- parameters (types and dictionaries) -> [CAtom n2] -- class parameters -> InstanceBody n2 -> InstanceDef n1 @@ -511,6 +525,7 @@ data InstanceBody (n::S) = data DictType (n::S) = DictType SourceName (ClassName n) [CAtom n] deriving (Show, Generic) +-- TODO: remove this and just do these operations in decls data DictExpr (n::S) = InstantiatedGiven (CAtom n) [CAtom n] | SuperclassProj (CAtom n) Int -- (could instantiate here too, but we don't need it for now) @@ -913,7 +928,7 @@ instance IRRep r => Store (Effect r n) -- === Specialization and generalization === type Generalized (r::IR) (e::E) (n::S) = (Abstracted r e n, [Atom r n]) -type Abstracted (r::IR) (e::E) = Abs (Nest (Binder r)) e +type Abstracted (r::IR) (e::E) = Abs (Binders r) e type AbsDict = Abstracted CoreIR Dict data SpecializedDictDef n = @@ -937,19 +952,30 @@ data LinearizationSpec (n::S) = -- === Binder utils === -binderType :: Binder r n l -> Type r n -binderType (_:>ty) = ty +class BindsNames b => ToBinderVar (b::B) (r::IR) | b -> r where + binderType :: b n l -> Type r n + binderVar :: (IRRep r, DExt n l) => b n l -> AtomVar r l -binderVar :: (IRRep r, DExt n l) => Binder r n l -> AtomVar r l -binderVar (b:>ty) = AtomVar (binderName b) (sink ty) +instance IRRep r => ToBinderVar (BinderAndDecls r) r where + binderType (BD (_:>ty) _) = ty + binderVar (BD (b:>ty) ds) = + AtomVar (withExtEvidence ds $ sink $ binderName b) (sink ty) -bindersVars :: (Distinct l, Ext n l, IRRep r) - => Nest (Binder r) n l -> [AtomVar r l] +instance IRRep r => ToBinderVar (Binder r) r where + binderType (_:>ty) = ty + binderVar (b:>ty) = AtomVar (sink $ binderName b) (sink ty) + +bindersVars + :: (Distinct l, Ext n l, IRRep r, ToBinderVar b r) + => Nest b n l -> [AtomVar r l] bindersVars = \case Empty -> [] Nest b bs -> withExtEvidence b $ withSubscopeDistinct bs $ sink (binderVar b) : bindersVars bs +binderAtom :: (IRRep r, DExt n l, ToBinderVar b r) => b n l -> Atom r l +binderAtom b = Var $ binderVar b + -- === ToBinding === atomBindingToBinding :: AtomBinding r n -> Binding (AtomNameC r) n @@ -989,11 +1015,9 @@ instance (ToBinding e1 c, ToBinding e2 c) => ToBinding (EitherE e1 e2) c where -- a Var, it doesn't check whether it's a type. pattern Type :: CType n -> CAtom n pattern Type t <- ((\case Var v -> Just (TyVar v) - ProjectElt t i x -> Just $ ProjectEltTy t i x TypeAsAtom t -> Just t _ -> Nothing) -> Just t) where Type (TyVar v) = Var v - Type (ProjectEltTy t i x) = ProjectElt t i x Type t = TypeAsAtom t pattern IdxRepScalarBaseTy :: ScalarBaseType @@ -1064,7 +1088,7 @@ pattern RefTy r a = TC (RefType r a) pattern RawRefTy :: Type r n -> Type r n pattern RawRefTy a = TC (RefType (Con HeapVal) a) -pattern TabTy :: IxDict r n -> Binder r n l -> Type r l -> Type r n +pattern TabTy :: IxDict r n -> BinderAndDecls r n l -> Type r l -> Type r n pattern TabTy d b body = TabPi (TabPiType d b body) pattern FinTy :: Atom CoreIR n -> Type CoreIR n @@ -1085,13 +1109,22 @@ pattern EffKind = NewtypeTyCon EffectRowKind pattern FinConst :: Word32 -> Type CoreIR n pattern FinConst n = NewtypeTyCon (Fin (NatVal n)) +pattern PlainBD :: Binder r n l -> BinderAndDecls r n l +pattern PlainBD b = BD b Empty + pattern NullaryLamExpr :: Block r n -> LamExpr r n pattern NullaryLamExpr body = LamExpr Empty body +asUnaryLamExpr :: LamExpr r n -> Maybe (Abs (Binder r) (Block r) n) +asUnaryLamExpr (LamExpr (UnaryNest (BD b decls)) (Abs decls' result)) = + Just $ Abs b $ Abs (decls >>> decls') result +asUnaryLamExpr _ = Nothing + pattern UnaryLamExpr :: Binder r n l -> Block r l -> LamExpr r n -pattern UnaryLamExpr b body = LamExpr (UnaryNest b) body +pattern UnaryLamExpr b body <- (asUnaryLamExpr -> Just (Abs b body)) + where UnaryLamExpr b body = LamExpr (UnaryNest (PlainBD b)) body -pattern BinaryLamExpr :: Binder r n l1 -> Binder r l1 l2 -> Block r l2 -> LamExpr r n +pattern BinaryLamExpr :: BinderAndDecls r n l1 -> BinderAndDecls r l1 l2 -> Block r l2 -> LamExpr r n pattern BinaryLamExpr b1 b2 body = LamExpr (BinaryNest b1 b2) body pattern WithoutDecls :: e n -> WithDecls r e n @@ -1196,7 +1229,7 @@ instance AlphaEqE DataConDefs instance AlphaHashableE DataConDefs instance GenericE TyConDef where - type RepE TyConDef = PairE (LiftE (SourceName, [RoleExpl])) (Abs (Nest CBinder) DataConDefs) + type RepE TyConDef = PairE (LiftE (SourceName, [RoleExpl])) (Abs CBinders DataConDefs) fromE (TyConDef sourceName expls bs cons) = PairE (LiftE (sourceName, expls)) (Abs bs cons) {-# INLINE fromE #-} toE (PairE (LiftE (sourceName, expls)) (Abs bs cons)) = TyConDef sourceName expls bs cons @@ -1218,7 +1251,7 @@ instance HasSourceName (TyConDef n) where instance GenericE DataConDef where type RepE DataConDef = (LiftE (SourceName, [[Projection]])) - `PairE` EmptyAbs (Nest CBinder) `PairE` Type CoreIR + `PairE` EmptyAbs CBinders `PairE` Type CoreIR fromE (DataConDef name bs repTy idxs) = (LiftE (name, idxs)) `PairE` bs `PairE` repTy {-# INLINE fromE #-} toE ((LiftE (name, idxs)) `PairE` bs `PairE` repTy) = DataConDef name bs repTy idxs @@ -1425,7 +1458,7 @@ instance GenericE SimpInCore where {- LiftSimp -} (CType `PairE` SAtom) {- LiftSimpFun -} (CorePiType `PairE` LamExpr SimpIR) {- TabLam -} (TabPiType CoreIR `PairE` TabLamExpr) - {- ACase -} (SAtom `PairE` ListE (Abs SBinder CAtom) `PairE` CType) + {- ACase -} (SAtom `PairE` ListE (Abs SBinderAndDecls CAtom) `PairE` CType) fromE = \case LiftSimp ty x -> Case0 $ ty `PairE` x LiftSimpFun ty x -> Case1 $ ty `PairE` x @@ -1453,17 +1486,13 @@ instance IRRep r => GenericE (Atom r) where -- toE/fromE entirely. If you wish to modify the order, please consult the -- GHC Core dump to make sure you haven't regressed this optimization. type RepE (Atom r) = EitherE3 - (EitherE4 + (EitherE3 {- Var -} (AtomVar r) - {- ProjectElt -} (Type r `PairE` LiftE Projection `PairE` Atom r) {- Lam -} (WhenCore r CoreLamExpr) {- DepPair -} (Atom r `PairE` Atom r `PairE` DepPairType r) - ) (EitherE4 + ) (EitherE3 {- DictCon -} (WhenCore r (CType `PairE` DictExpr)) {- NewtypeCon -} (WhenCore r (NewtypeCon `PairE` Atom r)) - {- DictHole -} (WhenCore r (LiftE (AlwaysEqual SrcPosCtx) `PairE` - (Type CoreIR) `PairE` - (LiftE RequiredMethodAccess))) {- Con -} (Con r) ) (EitherE5 {- Eff -} ( WhenCore r (EffectRow r)) @@ -1475,13 +1504,11 @@ instance IRRep r => GenericE (Atom r) where fromE atom = case atom of Var v -> Case0 (Case0 v) - ProjectElt t idxs x -> Case0 (Case1 (t `PairE` LiftE idxs `PairE` x)) - Lam lamExpr -> Case0 (Case2 (WhenIRE lamExpr)) - DepPair l r ty -> Case0 (Case3 $ l `PairE` r `PairE` ty) + Lam lamExpr -> Case0 (Case1 (WhenIRE lamExpr)) + DepPair l r ty -> Case0 (Case2 $ l `PairE` r `PairE` ty) DictCon t d -> Case1 $ Case0 $ WhenIRE $ t `PairE` d NewtypeCon c x -> Case1 $ Case1 $ WhenIRE (c `PairE` x) - DictHole s t access -> Case1 $ Case2 $ WhenIRE (LiftE s `PairE` t `PairE` LiftE access) - Con con -> Case1 $ Case3 con + Con con -> Case1 $ Case2 con Eff effs -> Case2 $ Case0 $ WhenIRE effs PtrVar t v -> Case2 $ Case1 $ LiftE t `PairE` v RepValAtom rv -> Case2 $ Case2 $ WhenIRE $ rv @@ -1492,15 +1519,13 @@ instance IRRep r => GenericE (Atom r) where toE atom = case atom of Case0 val -> case val of Case0 v -> Var v - Case1 (t `PairE` LiftE idxs `PairE` x) -> ProjectElt t idxs x - Case2 (WhenIRE (lamExpr)) -> Lam lamExpr - Case3 (l `PairE` r `PairE` ty) -> DepPair l r ty + Case1 (WhenIRE (lamExpr)) -> Lam lamExpr + Case2 (l `PairE` r `PairE` ty) -> DepPair l r ty _ -> error "impossible" Case1 val -> case val of Case0 (WhenIRE (t `PairE` d)) -> DictCon t d Case1 (WhenIRE (c `PairE` x)) -> NewtypeCon c x - Case2 (WhenIRE (LiftE s `PairE` t `PairE` LiftE access)) -> DictHole s t access - Case3 con -> Con con + Case2 con -> Con con _ -> error "impossible" Case2 val -> case val of Case0 (WhenIRE effs) -> Eff effs @@ -1546,7 +1571,7 @@ instance IRRep r => AlphaHashableE (AtomVar r) where instance IRRep r => RenameE (AtomVar r) instance IRRep r => GenericE (Type r) where - type RepE (Type r) = EitherE8 + type RepE (Type r) = EitherE7 {- TyVar -} (WhenCore r CAtomVar) {- Pi -} (WhenCore r CorePiType) {- TabPi -} (TabPiType r) @@ -1554,7 +1579,6 @@ instance IRRep r => GenericE (Type r) where {- DictTy -} (WhenCore r DictType) {- NewtypeTyCon -} (WhenCore r NewtypeTyCon) {- TC -} (TC r) - {- ProjectEltTy -} (WhenCore r (Type r `PairE` LiftE Projection `PairE` Atom r)) fromE = \case TyVar v -> Case0 $ WhenIRE v @@ -1564,7 +1588,6 @@ instance IRRep r => GenericE (Type r) where DictTy d -> Case4 $ WhenIRE d NewtypeTyCon t -> Case5 $ WhenIRE t TC con -> Case6 $ con - ProjectEltTy t idxs x -> Case7 (WhenIRE (t `PairE` LiftE idxs `PairE` x)) {-# INLINE fromE #-} toE = \case @@ -1575,7 +1598,7 @@ instance IRRep r => GenericE (Type r) where Case4 (WhenIRE d) -> DictTy d Case5 (WhenIRE t) -> NewtypeTyCon t Case6 con -> TC con - Case7 (WhenIRE (t `PairE` LiftE idxs `PairE` x)) -> ProjectEltTy t idxs x + _ -> error "impossible" {-# INLINE toE #-} instance IRRep r => SinkableE (Type r) @@ -1593,10 +1616,14 @@ instance IRRep r => GenericE (Expr r) where {- Atom -} (Atom r) {- TopApp -} (WhenSimp r (EffTy r `PairE` TopFunName `PairE` ListE (Atom r))) ) - ( EitherE3 + ( EitherE5 {- TabCon -} (MaybeE (WhenCore r Dict) `PairE` Type r `PairE` ListE (Atom r)) {- PrimOp -} (PrimOp r) - {- ApplyMethod -} (WhenCore r (EffTy r `PairE` Atom r `PairE` LiftE Int `PairE` ListE (Atom r)))) + {- ApplyMethod -} (WhenCore r (EffTy r `PairE` Atom r `PairE` LiftE Int `PairE` ListE (Atom r))) + {- ProjectElt -} (Type r `PairE` LiftE Projection `PairE` Atom r) + {- DictHole -} (WhenCore r (LiftE (AlwaysEqual SrcPosCtx) `PairE` + (Type CoreIR) `PairE` + (LiftE RequiredMethodAccess)))) fromE = \case App et f xs -> Case0 $ Case0 (WhenIRE (et `PairE` f `PairE` ListE xs)) @@ -1607,6 +1634,8 @@ instance IRRep r => GenericE (Expr r) where TabCon d ty xs -> Case1 $ Case0 (toMaybeE d `PairE` ty `PairE` ListE xs) PrimOp op -> Case1 $ Case1 op ApplyMethod et d i xs -> Case1 $ Case2 (WhenIRE (et `PairE` d `PairE` LiftE i `PairE` ListE xs)) + ProjectElt t idxs x -> Case1 $ Case3 (t `PairE` LiftE idxs `PairE` x) + DictHole s t access -> Case1 $ Case4 $ WhenIRE (LiftE s `PairE` t `PairE` LiftE access) {-# INLINE fromE #-} toE = \case Case0 case0 -> case case0 of @@ -1620,6 +1649,8 @@ instance IRRep r => GenericE (Expr r) where Case0 (d `PairE` ty `PairE` ListE xs) -> TabCon (fromMaybeE d) ty xs Case1 op -> PrimOp op Case2 (WhenIRE (et `PairE` d `PairE` LiftE i `PairE` ListE xs)) -> ApplyMethod et d i xs + Case3 (t `PairE` LiftE idxs `PairE` x) -> ProjectElt t idxs x + Case4 (WhenIRE (LiftE s `PairE` t `PairE` LiftE access)) -> DictHole s t access _ -> error "impossible" _ -> error "impossible" {-# INLINE toE #-} @@ -1853,7 +1884,7 @@ deriving instance (Show (ann n)) => IRRep r => Show (NonDepNest r ann n l) instance GenericE ClassDef where type RepE ClassDef = LiftE (SourceName, [SourceName], [Maybe SourceName], [RoleExpl]) - `PairE` Abs (Nest CBinder) (Abs (Nest CBinder) (ListE CorePiType)) + `PairE` Abs CBinders (Abs CBinders (ListE CorePiType)) fromE (ClassDef name names paramNames roleExpls b scs tys) = LiftE (name, names, paramNames, roleExpls) `PairE` Abs b (Abs scs (ListE tys)) {-# INLINE fromE #-} @@ -1873,7 +1904,7 @@ instance HasSourceName (ClassDef n) where instance GenericE InstanceDef where type RepE InstanceDef = - ClassName `PairE` LiftE [RoleExpl] `PairE` Abs (Nest CBinder) (ListE CAtom `PairE` InstanceBody) + ClassName `PairE` LiftE [RoleExpl] `PairE` Abs CBinders (ListE CAtom `PairE` InstanceBody) fromE (InstanceDef name expls bs params body) = name `PairE` LiftE expls `PairE` Abs bs (ListE params `PairE` body) toE (name `PairE` LiftE expls `PairE` Abs bs (ListE params `PairE` body)) = @@ -1979,7 +2010,7 @@ instance Semigroup (Cache n) where Cache (y1<>x1) (y2<>x2) (y3<>x3) (y4<>x4) (x5<>y5) (x6<>y6) instance GenericE (LamExpr r) where - type RepE (LamExpr r) = Abs (Nest (Binder r)) (Block r) + type RepE (LamExpr r) = Abs (Binders r) (Block r) fromE (LamExpr b block) = Abs b block {-# INLINE fromE #-} toE (Abs b block) = LamExpr b block @@ -2009,7 +2040,7 @@ deriving instance Show (CoreLamExpr n) deriving via WrapE CoreLamExpr n instance Generic (CoreLamExpr n) instance GenericE CorePiType where - type RepE CorePiType = LiftE (AppExplicitness, [Explicitness]) `PairE` Abs (Nest CBinder) (EffTy CoreIR) + type RepE CorePiType = LiftE (AppExplicitness, [Explicitness]) `PairE` Abs CBinders (EffTy CoreIR) fromE (CorePiType ex exs b effTy) = LiftE (ex, exs) `PairE` Abs b effTy {-# INLINE fromE #-} toE (LiftE (ex, exs) `PairE` Abs b effTy) = CorePiType ex exs b effTy @@ -2065,7 +2096,7 @@ instance IRRep r => AlphaHashableE (IxType r) where hashWithSaltE env salt (IxType t _) = hashWithSaltE env salt t instance IRRep r => GenericE (TabPiType r) where - type RepE (TabPiType r) = PairE (IxDict r) (Abs (Binder r) (Type r)) + type RepE (TabPiType r) = PairE (IxDict r) (Abs (BinderAndDecls r) (Type r)) fromE (TabPiType d b resultTy) = PairE d (Abs b resultTy) {-# INLINE fromE #-} toE (PairE d (Abs b resultTy)) = TabPiType d b resultTy @@ -2088,7 +2119,7 @@ deriving instance IRRep r => Show (TabPiType r n) deriving via WrapE (TabPiType r) n instance IRRep r => Generic (TabPiType r n) instance GenericE (PiType r) where - type RepE (PiType r) = Abs (Nest (Binder r)) (EffTy r) + type RepE (PiType r) = Abs (Binders r) (EffTy r) fromE (PiType bs effTy) = Abs bs effTy {-# INLINE fromE #-} toE (Abs bs effTy) = PiType bs effTy @@ -2104,7 +2135,7 @@ deriving via WrapE (PiType r) n instance IRRep r => Generic (PiType r n) instance IRRep r => Store (PiType r n) instance GenericE (DepPairType r) where - type RepE (DepPairType r) = PairE (LiftE DepPairExplicitness) (Abs (Binder r) (Type r)) + type RepE (DepPairType r) = PairE (LiftE DepPairExplicitness) (Abs (BinderAndDecls r) (Type r)) fromE (DepPairType expl b resultTy) = LiftE expl `PairE` Abs b resultTy {-# INLINE fromE #-} toE (LiftE expl `PairE` Abs b resultTy) = DepPairType expl b resultTy @@ -2230,7 +2261,7 @@ instance AlphaHashableE TopFun instance GenericE SpecializationSpec where type RepE SpecializationSpec = - PairE (AtomVar CoreIR) (Abs (Nest (Binder CoreIR)) (ListE CAtom)) + PairE (AtomVar CoreIR) (Abs (Binders CoreIR) (ListE CAtom)) fromE (AppSpecialization fname (Abs bs args)) = PairE fname (Abs bs args) {-# INLINE fromE #-} toE (PairE fname (Abs bs args)) = AppSpecialization fname (Abs bs args) @@ -2378,6 +2409,27 @@ instance IRRep r => AlphaHashableB (Decl r) instance IRRep r => ProvesExt (Decl r) instance IRRep r => BindsNames (Decl r) +instance GenericB (BinderAndDecls r) where + type RepB (BinderAndDecls r) = PairB (Binder r) (Nest (Decl r)) + fromB (BD b ds) = PairB b ds + {-# INLINE fromB #-} + toB (PairB b ds) = BD b ds + {-# INLINE toB #-} + +instance HasNameHint (BinderAndDecls r n l) where + getNameHint (BD b _) = getNameHint b + +deriving instance IRRep r => Show (BinderAndDecls r n l) +deriving via WrapB (BinderAndDecls r) n l instance IRRep r => Generic (BinderAndDecls r n l) + +instance IRRep r => SinkableB (BinderAndDecls r) +instance IRRep r => HoistableB (BinderAndDecls r) +instance IRRep r => RenameB (BinderAndDecls r) +instance IRRep r => AlphaEqB (BinderAndDecls r) +instance IRRep r => AlphaHashableB (BinderAndDecls r) +instance IRRep r => ProvesExt (BinderAndDecls r) +instance IRRep r => BindsNames (BinderAndDecls r) + instance IRRep r => GenericE (Effect r) where type RepE (Effect r) = EitherE3 (PairE (LiftE RWS) (Atom r)) @@ -2744,6 +2796,7 @@ instance Store (SpecializationSpec n) instance Store (LinearizationSpec n) instance IRRep r => Store (DeclBinding r n) instance IRRep r => Store (Decl r n l) +instance IRRep r => Store (BinderAndDecls r n l) instance Store (TyConParams n) instance Store (DataConDefs n) instance Store (TyConDef n) diff --git a/src/lib/Vectorize.hs b/src/lib/Vectorize.hs index d9a62728a..c1315c87b 100644 --- a/src/lib/Vectorize.hs +++ b/src/lib/Vectorize.hs @@ -17,7 +17,6 @@ import Control.Monad.State.Strict import Builder import Core import Err -import CheapReduction import IRVariants import Lower (DestBlock) import MTL1 @@ -26,9 +25,9 @@ import Subst import PPrint import QueryType import Types.Core -import Types.OpNames qualified as P import Types.Primitives import Util (allM, zipWithZ) +import Visitor -- === Vectorization === @@ -92,13 +91,14 @@ newtype TopVectorizeM (i::S) (o::S) (a:: *) = TopVectorizeM , SubstReader Name) vectorizeLoops :: EnvReader m => Word32 -> STopLam n -> m n (STopLam n, Errs) -vectorizeLoops width (TopLam d ty (LamExpr bsDestB body)) = liftEnvReaderM do - case popNest bsDestB of - Just (PairB bs b) -> - refreshAbs (Abs bs (Abs b body)) \bs' body' -> do - (Abs b'' body'', errs) <- liftTopVectorizeM width $ vectorizeLoopsDestBlock body' - return $ (TopLam d ty (LamExpr (bs' >>> UnaryNest b'') body''), errs) - Nothing -> error "expected a trailing dest binder" +vectorizeLoops width (TopLam d ty (LamExpr bsDestB body)) = undefined +-- vectorizeLoops width (TopLam d ty (LamExpr bsDestB body)) = liftEnvReaderM do +-- case popNest bsDestB of +-- Just (PairB bs (BD b)) -> +-- refreshAbs (Abs bs (Abs b body)) \bs' body' -> do +-- (Abs b'' body'', errs) <- liftTopVectorizeM width $ vectorizeLoopsDestBlock body' +-- return $ (TopLam d ty (LamExpr (bs' >>> UnaryNest (PlainBD b'')) body''), errs) +-- Nothing -> error "expected a trailing dest binder" liftTopVectorizeM :: (EnvReader m) => Word32 -> TopVectorizeM i i a -> m i (a, Errs) @@ -157,14 +157,15 @@ vectorizeLoopsDecls nest cont = vectorizeLoopsDecls rest cont vectorizeLoopsLamExpr :: LamExpr SimpIR i -> TopVectorizeM i o (LamExpr SimpIR o) -vectorizeLoopsLamExpr (LamExpr bs body) = case bs of - Empty -> LamExpr Empty <$> buildBlock (vectorizeLoopsBlock body) - Nest (b:>ty) rest -> do - ty' <- renameM ty - withFreshBinder (getNameHint b) ty' \b' -> do - extendRenamer (b @> binderName b') do - LamExpr bs' body' <- vectorizeLoopsLamExpr $ LamExpr rest body - return $ LamExpr (Nest b' bs') body' +vectorizeLoopsLamExpr (LamExpr bs body) = undefined +-- vectorizeLoopsLamExpr (LamExpr bs body) = case bs of +-- Empty -> LamExpr Empty <$> buildBlock (vectorizeLoopsBlock body) +-- Nest b rest -> do +-- ty <- renameM $ binderType b +-- withFreshBinder (getNameHint b) ty \b' -> do +-- extendSubstBD b [binderName b'] do +-- LamExpr bs' body' <- vectorizeLoopsLamExpr $ LamExpr rest body +-- return $ LamExpr (Nest (BD b') bs') body' vectorizeLoopsExpr :: (Emits o) => SExpr i -> TopVectorizeM i o (SExpr o) vectorizeLoopsExpr expr = do @@ -197,8 +198,8 @@ vectorizeLoopsExpr expr = do item' <- renameM item itemTy <- return $ getType item' lam <- buildEffLam noHint itemTy \hb refb -> - extendRenamer (hb' @> atomVarName hb) do - extendRenamer (refb' @> atomVarName refb) do + extendSubstBD hb' [atomVarName hb] do + extendSubstBD refb' [atomVarName refb] do vectorizeLoopsBlock body PrimOp . Hof <$> mkTypedHof (RunReader item' lam) PrimOp (Hof (TypedHof (EffTy _ ty) @@ -208,8 +209,8 @@ vectorizeLoopsExpr expr = do commutativity <- monoidCommutativity monoid' PairTy _ accTy <- renameM ty lam <- buildEffLam noHint accTy \hb refb -> - extendRenamer (hb' @> atomVarName hb) do - extendRenamer (refb' @> atomVarName refb) do + extendSubstBD hb'[atomVarName hb] do + extendSubstBD refb' [atomVarName refb] do extendCommuteMap (atomVarName hb) commutativity do vectorizeLoopsBlock body PrimOp . Hof <$> mkTypedHof (RunWriter (Just dest') monoid' lam) @@ -226,12 +227,13 @@ vectorizeLoopsExpr expr = do simplifyIxSize :: (EnvReader m, ScopableBuilder SimpIR m) => IxType SimpIR n -> m n (Maybe Word32) -simplifyIxSize ixty = do - sizeMethod <- buildBlock $ applyIxMethod (sink $ ixTypeDict ixty) Size [] - cheapReduce sizeMethod >>= \case - Just (IdxRepVal n) -> return $ Just n - _ -> return Nothing -{-# INLINE simplifyIxSize #-} +simplifyIxSize ixty = undefined +-- simplifyIxSize ixty = do +-- sizeMethod <- buildBlock $ applyIxMethod (sink $ ixTypeDict ixty) Size [] +-- cheapReduce sizeMethod >>= \case +-- Just (IdxRepVal n) -> return $ Just n +-- _ -> return Nothing +-- {-# INLINE simplifyIxSize #-} -- Really we should check this by seeing whether there is an instance for a -- `Commutative` class, or something like that, but for now just pattern-match @@ -257,22 +259,12 @@ monoidCommutativity monoid = case isAdditionMonoid monoid of Nothing -> return DoesNotCommute {-# INLINE monoidCommutativity #-} +-- XXX: this is wrong. We need to add a mechanism for specifying commutativity isAdditionMonoid :: BaseMonoid SimpIR n -> Maybe () isAdditionMonoid monoid = do BaseMonoid { baseEmpty = (Con (Lit l)) - , baseCombine = BinaryLamExpr (b1:>_) (b2:>_) body } <- Just monoid + , baseCombine = BinaryLamExpr _ _ _ } <- Just monoid unless (_isZeroLit l) Nothing - PrimOp (BinOp op (Var b1') (Var b2')) <- exprBlock body - unless (op `elem` [P.IAdd, P.FAdd]) Nothing - case (binderName b1, atomVarName b1', binderName b2, atomVarName b2') of - -- Checking the raw names here because (i) I don't know how to convince the - -- name system to let me check the well-typed names (which is because b2 - -- might shadow b1), and (ii) there are so few patterns that I can just - -- enumerate them. - (UnsafeMakeName n1, UnsafeMakeName n1', UnsafeMakeName n2, UnsafeMakeName n2') -> do - when (n1 == n2) Nothing - unless ((n1 == n1' && n2 == n2') || (n1 == n2' && n2 == n1')) Nothing - Just () _isZeroLit :: LitVal -> Bool _isZeroLit = \case @@ -369,14 +361,14 @@ vectorizeLamExpr (LamExpr bs body) argStabilities = case (bs, argStabilities) of vectorizeBlock body >>= \case (VVal _ ans) -> return ans (VRename v) -> Var <$> toAtomVar v) - (Nest (b:>ty) rest, (stab:stabs)) -> do - ty' <- vectorizeType ty + (Nest b rest, (stab:stabs)) -> do + ty' <- vectorizeType $ binderType b ty'' <- promoteTypeByStability ty' stab withFreshBinder (getNameHint b) ty'' \b' -> do var <- toAtomVar $ binderName b' - extendSubst (b @> VVal stab (Var var)) do + extendSubstBD b [VVal stab (Var var)] do LamExpr rest' body' <- vectorizeLamExpr (LamExpr rest body) stabs - return $ LamExpr (Nest b' rest') body' + return $ LamExpr (Nest (PlainBD b') rest') body' _ -> error "Zip error" vectorizeBlock :: Emits o => SBlock i -> VectorizeM i o (VAtom o) @@ -407,6 +399,16 @@ vectorizeExpr expr = addVectErrCtx "vectorizeExpr" ("Expr:\n" ++ pprint expr) do throwVectErr $ "bad type: " ++ pprint tblTy ++ "\ntbl' : " ++ pprint tbl' Atom atom -> vectorizeAtom atom PrimOp op -> vectorizePrimOp op + -- Vectors of base newtypes are already newtype-stripped. + ProjectElt _ (ProjectProduct i) x -> undefined + -- ProjectElt _ (ProjectProduct i) x -> do + -- VVal vv x' <- vectorizeAtom x + -- ov <- case vv of + -- ProdStability sbs -> return $ sbs !! i + -- _ -> throwVectErr "Invalid projection" + -- x'' <- normalizeProj (ProjectProduct i) x' + -- return $ VVal ov x'' + ProjectElt _ UnwrapNewtype _ -> error "Shouldn't have newtypes left" -- TODO: check statically _ -> throwVectErr $ "Cannot vectorize expr: " ++ pprint expr vectorizeDAMOp :: Emits o => DAMOp SimpIR i -> VectorizeM i o (VAtom o) @@ -538,15 +540,6 @@ vectorizeAtom atom = addVectErrCtx "vectorizeAtom" ("Atom:\n" ++ pprint atom) do Var v -> lookupSubstM (atomVarName v) >>= \case VRename v' -> VVal Uniform . Var <$> toAtomVar v' v' -> return v' - -- Vectors of base newtypes are already newtype-stripped. - ProjectElt _ (ProjectProduct i) x -> do - VVal vv x' <- vectorizeAtom x - ov <- case vv of - ProdStability sbs -> return $ sbs !! i - _ -> throwVectErr "Invalid projection" - x'' <- normalizeProj (ProjectProduct i) x' - return $ VVal ov x'' - ProjectElt _ UnwrapNewtype _ -> error "Shouldn't have newtypes left" -- TODO: check statically Con (Lit l) -> return $ VVal Uniform $ Con $ Lit l _ -> do subst <- getSubst diff --git a/src/lib/Visitor.hs b/src/lib/Visitor.hs new file mode 100644 index 000000000..1fdd85a09 --- /dev/null +++ b/src/lib/Visitor.hs @@ -0,0 +1,269 @@ +-- Copyright 2023 Google LLC +-- +-- Use of this source code is governed by a BSD-style +-- license that can be found in the LICENSE file or at +-- https://developers.google.com/open-source/licenses/bsd + +module Visitor where + +import Control.Applicative +import Control.Monad.Trans +import Control.Monad.Writer.Strict hiding (Alt) +import Control.Monad.State.Strict +import Control.Monad.Reader +import Data.Foldable (toList) +import Data.Functor.Identity +import Data.Functor ((<&>)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as M + +import Core +import Err +import IRVariants +import MTL1 +import Name +import PPrint () +import QueryType +import Types.Core +import Types.Imp +import Types.Primitives + +type family IsAtomName (c::C) where + IsAtomName (AtomNameC r) = True + IsAtomName _ = False + +class Monad m => NonAtomRenamer m i o | m -> i, m -> o where + renameN :: (IsAtomName c ~ False, Color c) => Name c i -> m (Name c o) + +class NonAtomRenamer m i o => Visitor m r i o | m -> i, m -> o where + visitType :: Type r i -> m (Type r o) + visitAtom :: Atom r i -> m (Atom r o) + visitLam :: LamExpr r i -> m (LamExpr r o) + visitPi :: PiType r i -> m (PiType r o) + +class VisitGeneric (e:: E) (r::IR) | e -> r where + visitGeneric :: Visitor m r i o => e i -> m (e o) + +type Visitor2 (m::MonadKind2) r = forall i o . Visitor (m i o) r i o + +instance VisitGeneric (Atom r) r where visitGeneric = visitAtom +instance VisitGeneric (Type r) r where visitGeneric = visitType +instance VisitGeneric (LamExpr r) r where visitGeneric = visitLam +instance VisitGeneric (PiType r) r where visitGeneric = visitPi + +visitBlock :: Visitor m r i o => Block r i -> m (Block r o) +visitBlock b = visitGeneric (LamExpr Empty b) >>= \case + LamExpr Empty b' -> return b' + _ -> error "not a block" + +visitAlt :: Visitor m r i o => Alt r i -> m (Alt r o) +visitAlt (Abs b body) = do + visitGeneric (UnaryLamExpr b body) >>= \case + UnaryLamExpr b' body' -> return $ Abs b' body' + _ -> error "not an alt" + +traverseOpTerm + :: (GenericOp e, Visitor m r i o, OpConst e r ~ OpConst e r) + => e r i -> m (e r o) +traverseOpTerm e = traverseOp e visitGeneric visitGeneric visitGeneric + +-- XXX: This doesn't handle the `Var`, `ProjectElt`, `SimpInCore` cases. These +-- should be handled explicitly beforehand. TODO: split out these cases under a +-- separate constructor, perhaps even a `hole` paremeter to `Atom` or part of +-- `IR`. +visitAtomPartial :: (IRRep r, Visitor m r i o) => Atom r i -> m (Atom r o) +visitAtomPartial = \case + Var _ -> error "Not handled generically" + SimpInCore _ -> error "Not handled generically" + Con con -> Con <$> visitGeneric con + PtrVar t v -> PtrVar t <$> renameN v + DepPair x y t -> do + x' <- visitGeneric x + y' <- visitGeneric y + ~(DepPairTy t') <- visitGeneric $ DepPairTy t + return $ DepPair x' y' t' + Lam lam -> Lam <$> visitGeneric lam + Eff eff -> Eff <$> visitGeneric eff + DictCon t d -> DictCon <$> visitType t <*> visitGeneric d + NewtypeCon con x -> NewtypeCon <$> visitGeneric con <*> visitGeneric x + TypeAsAtom t -> TypeAsAtom <$> visitGeneric t + RepValAtom repVal -> RepValAtom <$> visitGeneric repVal + +-- XXX: This doesn't handle the `TyVar` or `ProjectEltTy` cases. These should be +-- handled explicitly beforehand. +visitTypePartial :: (IRRep r, Visitor m r i o) => Type r i -> m (Type r o) +visitTypePartial = \case + TyVar _ -> error "Not handled generically" + NewtypeTyCon t -> NewtypeTyCon <$> visitGeneric t + Pi t -> Pi <$> visitGeneric t + TabPi t -> TabPi <$> visitGeneric t + TC t -> TC <$> visitGeneric t + DepPairTy t -> DepPairTy <$> visitGeneric t + DictTy t -> DictTy <$> visitGeneric t + +instance IRRep r => VisitGeneric (Expr r) r where + visitGeneric = \case + TopApp et v xs -> TopApp <$> visitGeneric et <*> renameN v <*> mapM visitGeneric xs + TabApp t tab xs -> TabApp <$> visitType t <*> visitGeneric tab <*> mapM visitGeneric xs + -- TODO: should we reuse the original effects? Whether it's valid depends on + -- the type-preservation requirements for a visitor. We should clarify what + -- those are. + Case x alts effTy -> do + x' <- visitGeneric x + alts' <- mapM visitAlt alts + effTy' <- visitGeneric effTy + return $ Case x' alts' effTy' + Atom x -> Atom <$> visitGeneric x + TabCon Nothing t xs -> TabCon Nothing <$> visitGeneric t <*> mapM visitGeneric xs + TabCon (Just (WhenIRE d)) t xs -> TabCon <$> (Just . WhenIRE <$> visitGeneric d) <*> visitGeneric t <*> mapM visitGeneric xs + PrimOp op -> PrimOp <$> visitGeneric op + App et fAtom xs -> App <$> visitGeneric et <*> visitGeneric fAtom <*> mapM visitGeneric xs + ApplyMethod et m i xs -> ApplyMethod <$> visitGeneric et <*> visitGeneric m <*> pure i <*> mapM visitGeneric xs + DictHole ctx ty access -> DictHole ctx <$> visitGeneric ty <*> pure access + +instance IRRep r => VisitGeneric (PrimOp r) r where + visitGeneric = \case + UnOp op x -> UnOp op <$> visitGeneric x + BinOp op x y -> BinOp op <$> visitGeneric x <*> visitGeneric y + MemOp op -> MemOp <$> visitGeneric op + VectorOp op -> VectorOp <$> visitGeneric op + MiscOp op -> MiscOp <$> visitGeneric op + Hof op -> Hof <$> visitGeneric op + DAMOp op -> DAMOp <$> visitGeneric op + RefOp r op -> RefOp <$> visitGeneric r <*> traverseOp op visitGeneric visitGeneric visitGeneric + +instance IRRep r => VisitGeneric (TypedHof r) r where + visitGeneric (TypedHof eff hof) = TypedHof <$> visitGeneric eff <*> visitGeneric hof + +instance IRRep r => VisitGeneric (Hof r) r where + visitGeneric = \case + For ann d lam -> For ann <$> visitGeneric d <*> visitGeneric lam + RunReader x body -> RunReader <$> visitGeneric x <*> visitGeneric body + RunWriter dest bm body -> RunWriter <$> mapM visitGeneric dest <*> visitGeneric bm <*> visitGeneric body + RunState dest s body -> RunState <$> mapM visitGeneric dest <*> visitGeneric s <*> visitGeneric body + While b -> While <$> visitBlock b + RunIO b -> RunIO <$> visitBlock b + RunInit b -> RunInit <$> visitBlock b + CatchException t b -> CatchException <$> visitType t <*> visitBlock b + Linearize lam x -> Linearize <$> visitGeneric lam <*> visitGeneric x + Transpose lam x -> Transpose <$> visitGeneric lam <*> visitGeneric x + +instance IRRep r => VisitGeneric (BaseMonoid r) r where + visitGeneric (BaseMonoid x lam) = BaseMonoid <$> visitGeneric x <*> visitGeneric lam + +instance IRRep r => VisitGeneric (DAMOp r) r where + visitGeneric = \case + Seq eff dir d x lam -> Seq <$> visitGeneric eff <*> pure dir <*> visitGeneric d <*> visitGeneric x <*> visitGeneric lam + RememberDest eff x lam -> RememberDest <$> visitGeneric eff <*> visitGeneric x <*> visitGeneric lam + AllocDest t -> AllocDest <$> visitGeneric t + Place x y -> Place <$> visitGeneric x <*> visitGeneric y + Freeze x -> Freeze <$> visitGeneric x + +instance IRRep r => VisitGeneric (Effect r) r where + visitGeneric = \case + RWSEffect rws h -> RWSEffect rws <$> visitGeneric h + ExceptionEffect -> pure ExceptionEffect + IOEffect -> pure IOEffect + InitEffect -> pure InitEffect + +instance IRRep r => VisitGeneric (EffectRow r) r where + visitGeneric (EffectRow effs tailVar) = do + effs' <- eSetFromList <$> mapM visitGeneric (eSetToList effs) + tailEffRow <- case tailVar of + NoTail -> return $ EffectRow mempty NoTail + EffectRowTail v -> visitGeneric (Var v) <&> \case + Var v' -> EffectRow mempty (EffectRowTail v') + Eff r -> r + _ -> error "Not a valid effect substitution" + return $ extendEffRow effs' tailEffRow + +instance VisitGeneric DictExpr CoreIR where + visitGeneric = \case + InstantiatedGiven x xs -> InstantiatedGiven <$> visitGeneric x <*> mapM visitGeneric xs + SuperclassProj x i -> SuperclassProj <$> visitGeneric x <*> pure i + InstanceDict v xs -> InstanceDict <$> renameN v <*> mapM visitGeneric xs + IxFin x -> IxFin <$> visitGeneric x + DataData t -> DataData <$> visitGeneric t + +instance VisitGeneric NewtypeCon CoreIR where + visitGeneric = \case + UserADTData sn t params -> UserADTData sn <$> renameN t <*> visitGeneric params + NatCon -> return NatCon + FinCon x -> FinCon <$> visitGeneric x + +instance VisitGeneric NewtypeTyCon CoreIR where + visitGeneric = \case + Nat -> return Nat + Fin x -> Fin <$> visitGeneric x + EffectRowKind -> return EffectRowKind + UserADTType n v params -> UserADTType n <$> renameN v <*> visitGeneric params + +instance VisitGeneric TyConParams CoreIR where + visitGeneric (TyConParams expls xs) = TyConParams expls <$> mapM visitGeneric xs + +instance IRRep r => VisitGeneric (IxDict r) r where + visitGeneric = \case + IxDictAtom x -> IxDictAtom <$> visitGeneric x + IxDictRawFin x -> IxDictRawFin <$> visitGeneric x + IxDictSpecialized t v xs -> IxDictSpecialized <$> visitGeneric t <*> renameN v <*> mapM visitGeneric xs + +instance IRRep r => VisitGeneric (IxType r) r where + visitGeneric (IxType t d) = IxType <$> visitType t <*> visitGeneric d + +instance VisitGeneric DictType CoreIR where + visitGeneric (DictType n v xs) = DictType n <$> renameN v <*> mapM visitGeneric xs + +instance VisitGeneric CoreLamExpr CoreIR where + visitGeneric (CoreLamExpr t lam) = CoreLamExpr <$> visitGeneric t <*> visitGeneric lam + +instance VisitGeneric CorePiType CoreIR where + visitGeneric (CorePiType app expl bs effty) = do + PiType bs' effty' <- visitGeneric $ PiType bs effty + return $ CorePiType app expl bs' effty' + +instance IRRep r => VisitGeneric (TabPiType r) r where + visitGeneric (TabPiType d b eltTy) = do + d' <- visitGeneric d + visitGeneric (PiType (UnaryNest b) (EffTy Pure eltTy)) <&> \case + PiType (UnaryNest b') (EffTy Pure eltTy') -> TabPiType d' b' eltTy' + _ -> error "not a table pi type" + +instance IRRep r => VisitGeneric (DepPairType r) r where + visitGeneric (DepPairType expl b ty) = do + visitGeneric (PiType (UnaryNest b) (EffTy Pure ty)) <&> \case + PiType (UnaryNest b') (EffTy Pure ty') -> DepPairType expl b' ty' + _ -> error "not a dependent pair type" + +instance VisitGeneric (RepVal SimpIR) SimpIR where + visitGeneric (RepVal ty tree) = RepVal <$> visitGeneric ty <*> mapM renameIExpr tree + where renameIExpr = \case + ILit l -> return $ ILit l + IVar v t -> IVar <$> renameN v <*> pure t + IPtrVar v t -> IPtrVar <$> renameN v <*> pure t + +instance IRRep r => VisitGeneric (DeclBinding r) r where + visitGeneric (DeclBinding ann expr) = DeclBinding ann <$> visitGeneric expr + +instance IRRep r => VisitGeneric (EffTy r) r where + visitGeneric (EffTy eff ty) = + EffTy <$> visitGeneric eff <*> visitGeneric ty + +instance VisitGeneric DataConDefs CoreIR where + visitGeneric = \case + ADTCons cons -> ADTCons <$> mapM visitGeneric cons + StructFields defs -> do + let (names, tys) = unzip defs + tys' <- mapM visitGeneric tys + return $ StructFields $ zip names tys' + +instance VisitGeneric DataConDef CoreIR where + visitGeneric (DataConDef sn (Abs bs UnitE) repTy ps) = do + PiType bs' _ <- visitGeneric $ PiType bs $ EffTy Pure UnitTy + repTy' <- visitGeneric repTy + return $ DataConDef sn (Abs bs' UnitE) repTy' ps + +instance VisitGeneric (Con r) r where visitGeneric = traverseOpTerm +instance VisitGeneric (TC r) r where visitGeneric = traverseOpTerm +instance VisitGeneric (MiscOp r) r where visitGeneric = traverseOpTerm +instance VisitGeneric (VectorOp r) r where visitGeneric = traverseOpTerm +instance VisitGeneric (MemOp r) r where visitGeneric = traverseOpTerm diff --git a/tests/unit/ConstantCastingSpec.hs b/tests/unit/ConstantCastingSpec.hs index fe9abab12..e7ff079f1 100644 --- a/tests/unit/ConstantCastingSpec.hs +++ b/tests/unit/ConstantCastingSpec.hs @@ -31,9 +31,9 @@ castOp ty x = MiscOp $ CastOp (BaseTy (Scalar ty)) x castLam :: EnvExtender m => ScalarBaseType -> ScalarBaseType -> m n (SLam n) castLam fromTy toTy = do - withFreshBinder noHint (BaseTy (Scalar fromTy)) \x -> do - body <- exprToBlock $ PrimOp $ castOp toTy $ Var $ binderVar x - return $ LamExpr (Nest x Empty) body + withFreshBinder noHint (BaseTy (Scalar fromTy)) \b -> do + body <- exprToBlock $ PrimOp $ castOp toTy $ Var $ binderVar b + return $ LamExpr (Nest (PlainBD b) Empty) body exprToBlock :: EnvReader m => SExpr n -> m n (SBlock n) exprToBlock expr = do