diff --git a/dex.cabal b/dex.cabal index 493a1e772..44b719a9d 100644 --- a/dex.cabal +++ b/dex.cabal @@ -49,7 +49,6 @@ library , ConcreteSyntax , Core , Err - , Export , Generalize , Imp , ImpToLLVM diff --git a/src/lib/AbstractSyntax.hs b/src/lib/AbstractSyntax.hs index ccdb17108..69a812897 100644 --- a/src/lib/AbstractSyntax.hs +++ b/src/lib/AbstractSyntax.hs @@ -139,7 +139,6 @@ decl ann (WithSrcs sid _ d) = WithSrcB sid <$> case d of CLet binder rhs -> do (p, ty) <- patOptAnn binder ULet ann p ty <$> asExpr <$> block rhs - CBind _ _ -> throw sid TopLevelArrowBinder CDefDecl def -> do (name, lam) <- aDef def return $ ULet ann (fromSourceNameW name) Nothing (WithSrcE sid (ULam lam)) @@ -382,12 +381,6 @@ blockDecls [] = error "shouldn't have empty list of decls" blockDecls [WithSrcs sid _ d] = case d of CExpr g -> (Empty,) <$> expr g _ -> throw sid BlockWithoutFinalExpr -blockDecls (WithSrcs sid _ (CBind b rhs):ds) = do - b' <- binderOptTy Explicit b - rhs' <- asExpr <$> block rhs - body <- block $ IndentedBlock sid ds -- Not really the right SrcId - let lam = ULam $ ULamExpr (UnaryNest b') ExplicitApp Nothing body - return (Empty, WithSrcE sid $ extendAppRight rhs' (WithSrcE sid lam)) blockDecls (d:ds) = do d' <- decl PlainLet d (ds', e) <- blockDecls ds diff --git a/src/lib/Builder.hs b/src/lib/Builder.hs index 6ba71730e..5d9e811dd 100644 --- a/src/lib/Builder.hs +++ b/src/lib/Builder.hs @@ -806,13 +806,6 @@ maybeTangentType' ty = case ty of _ -> empty where rec = maybeTangentType' -tangentBaseMonoidFor :: (Emits n, SBuilder m) => SType n -> m n (BaseMonoid SimpIR n) -tangentBaseMonoidFor ty = do - zero <- zeroAt ty - adder <- liftBuilder $ buildBinaryLamExpr (noHint, ty) (noHint, ty) \x y -> - addTangent (toAtom x) (toAtom y) - return $ BaseMonoid zero adder - addTangent :: (Emits n, SBuilder m) => SAtom n -> SAtom n -> m n (SAtom n) addTangent x y = do case getTyCon x of @@ -934,7 +927,7 @@ projectStruct i x = do projectStructRef :: (Builder CoreIR m, Emits n) => Int -> CAtom n -> m n (CAtom n) projectStructRef i x = do - RefTy _ valTy <- return $ getType x + RefTy valTy <- return $ getType x projs <- getStructProjections i valTy applyProjectionsRef projs x {-# INLINE projectStructRef #-} @@ -973,16 +966,15 @@ mkBlock (Abs decls body) = do return $ Block effTy block blockEffTy :: (EnvReader m, IRRep r) => Block r n -> m n (EffTy r n) -blockEffTy _ = undefined --- 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' +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 -> Effects r l -> EnvReaderM l (Effects 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' mkApp :: EnvReader m => CAtom n -> [CAtom n] -> m n (CExpr n) mkApp f xs = do diff --git a/src/lib/CheapReduction.hs b/src/lib/CheapReduction.hs index 111063099..9647489f8 100644 --- a/src/lib/CheapReduction.hs +++ b/src/lib/CheapReduction.hs @@ -442,9 +442,6 @@ instance IRRep r => VisitGeneric (Hof r) r where 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 (Effects r) r where visitGeneric = \case Pure -> return Pure @@ -550,7 +547,7 @@ instance IRRep r => VisitGeneric (TyCon r) r where BaseType bt -> return $ BaseType bt ProdType tys -> ProdType <$> mapM visitGeneric tys SumType tys -> SumType <$> mapM visitGeneric tys - RefType h t -> RefType h <$> visitGeneric t + RefType t -> RefType <$> visitGeneric t TabPi t -> TabPi <$> visitGeneric t DepPairTy t -> DepPairTy <$> visitGeneric t TypeKind -> return TypeKind @@ -686,7 +683,6 @@ instance SubstE AtomSubstVal IExpr instance SubstE AtomSubstVal RepVal instance SubstE AtomSubstVal TyConParams instance SubstE AtomSubstVal DataConDef -instance IRRep r => SubstE AtomSubstVal (BaseMonoid r) instance IRRep r => SubstE AtomSubstVal (TypedHof r) instance IRRep r => SubstE AtomSubstVal (Hof r) instance IRRep r => SubstE AtomSubstVal (TyCon r) diff --git a/src/lib/CheckType.hs b/src/lib/CheckType.hs index 131bb46fc..2522d7e81 100644 --- a/src/lib/CheckType.hs +++ b/src/lib/CheckType.hs @@ -273,7 +273,7 @@ instance IRRep r => CheckableE r (Stuck r) where Var name -> do name' <- checkE name case getType name' of - RawRefTy _ -> affineUsed $ atomVarName name' + RefTy _ -> affineUsed $ atomVarName name' _ -> return () return $ Var name' StuckUnwrap x -> do @@ -372,7 +372,7 @@ instance IRRep r => CheckableE r (TyCon r) where BaseType b -> return $ BaseType b ProdType tys -> ProdType <$> mapM checkE tys SumType cs -> SumType <$> mapM checkE cs - RefType r a -> RefType r <$> checkE a + RefType a -> RefType <$> checkE a TypeKind -> return TypeKind Pi t -> Pi <$> checkE t TabPi t -> TabPi <$> checkE t @@ -463,23 +463,18 @@ instance IRRep r => CheckableE r (PrimOp r) where MiscOp op -> MiscOp <$> checkE op MemOp op -> MemOp <$> checkE op RefOp ref m -> do - (ref', TyCon (RefType h s)) <- checkAndGetType ref + (ref', TyCon (RefType s)) <- checkAndGetType ref m' <- case m of MGet -> return MGet MPut x -> do x' <- x|:s return $ MPut x' - MAsk -> return MAsk - MExtend b x -> do - b' <- checkE b - x' <- x|:s - return $ MExtend b' x' IndexRef givenTy i -> do givenTy' <- checkE givenTy TyCon (TabPi tabTy) <- return s i' <- checkE i eltTy' <- checkInstantiation tabTy [i'] - checkTypesEq givenTy' (TyCon $ RefType h eltTy') + checkTypesEq givenTy' (TyCon $ RefType eltTy') return $ IndexRef givenTy' i' ProjRef givenTy p -> do givenTy' <- checkE givenTy @@ -490,16 +485,13 @@ instance IRRep r => CheckableE r (PrimOp r) where UnwrapNewtype -> do TyCon (NewtypeTyCon tc) <- return s snd <$> unwrapNewtypeType tc - checkTypesEq givenTy' (TyCon $ RefType h resultEltTy) + checkTypesEq givenTy' (TyCon $ RefType resultEltTy) return $ ProjRef givenTy' p return $ RefOp ref' m' instance IRRep r => CheckableE r (EffTy r) where checkE (EffTy effs ty) = EffTy <$> checkE effs <*> checkE ty -instance IRRep r => CheckableE r (BaseMonoid r) where - checkE = renameM -- TODO: check - instance IRRep r => CheckableE r (MemOp r) where checkE = \case IOAlloc n -> do @@ -592,7 +584,7 @@ instance IRRep r => CheckableE r (VectorOp r) where return $ VectorIdx tbl' i' ty' VectorSubref ref i ty -> do ref' <- checkE ref - RefTy _ (TabTy _ b (BaseTy (Scalar sbt))) <- return $ getType ref' + RefTy (TabTy _ b (BaseTy (Scalar sbt))) <- return $ getType ref' i' <- i |: binderType b ty'@(BaseTy (Vector _ sbt')) <- checkE ty unless (sbt == sbt') $ throwInternal "Scalar type mismatch" diff --git a/src/lib/ConcreteSyntax.hs b/src/lib/ConcreteSyntax.hs index 5d60cc1fe..4f4ad3b25 100644 --- a/src/lib/ConcreteSyntax.hs +++ b/src/lib/ConcreteSyntax.hs @@ -301,7 +301,6 @@ simpleLet = do next <- nextChar case next of '=' -> sym "=" >> CLet lhs <$> cBlock - '<' -> sym "<-" >> CBind lhs <$> cBlock _ -> return $ CExpr lhs instanceDef :: Bool -> Parser CInstanceDef diff --git a/src/lib/Generalize.hs b/src/lib/Generalize.hs index ba8cfbca2..58cae3302 100644 --- a/src/lib/Generalize.hs +++ b/src/lib/Generalize.hs @@ -140,7 +140,7 @@ traverseTyParams (TyCon ty) f = liftM TyCon $ getDistinct >>= \Distinct -> case return $ TabPi $ TabPiType d' (b':>iTy') resultTy' BaseType b -> return $ BaseType b ProdType tys -> ProdType <$> forM tys \t -> f' TypeParam TyKind t - RefType _ _ -> error "not implemented" -- how should we handle the ParamRole for the heap parameter? + RefType _ -> error "not implemented" SumType tys -> SumType <$> forM tys \t -> f' TypeParam TyKind t TypeKind -> return TypeKind NewtypeTyCon con -> NewtypeTyCon <$> case con of diff --git a/src/lib/Imp.hs b/src/lib/Imp.hs index 3b2d134c7..488328ca7 100644 --- a/src/lib/Imp.hs +++ b/src/lib/Imp.hs @@ -60,7 +60,7 @@ toImpFunction cc (TopLam True destTy lam) = do argAtoms <- interpretImpArgs (sink $ EmptyAbs bs) vs extendSubst (bs @@> (SubstVal <$> argAtoms)) do dest <- case binderType destB of - RefTy _ ansTy -> allocDestUnmanaged =<< substM ansTy + RefTy ansTy -> allocDestUnmanaged =<< substM ansTy _ -> error "Expected a reference type for body destination" extendSubst (destB @> SubstVal (destToAtom dest)) do void $ translateExpr body @@ -327,12 +327,6 @@ toImpRefOp :: Emits o toImpRefOp refDest' m = do refDest <- atomToDest =<< substM refDest' substM m >>= \case - MAsk -> loadAtom refDest - MExtend (BaseMonoid _ combine) x -> do - xTy <- return $ getType x - refVal <- loadAtom refDest - liftMonoidCombine refDest xTy combine refVal x - return UnitVal MPut x -> storeAtom refDest x >> return UnitVal MGet -> do Dest resultTy _ <- return refDest @@ -343,32 +337,6 @@ toImpRefOp refDest' m = do loadAtom dest IndexRef _ i -> destToAtom <$> indexDest refDest i ProjRef _ ~(ProjectProduct i) -> return $ destToAtom $ projectDest i refDest - where - liftMonoidCombine :: Emits o - => (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 - 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 $ emit (sink body') - storeAtom accDest ans - False -> case accTy of - TyCon (TabPi t) -> do - let ixTy = tabIxType t - n <- indexSetSizeImp ixTy - emitLoop noHint Fwd n \i -> 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] - ithDest <- indexDest (sink accDest) idx - liftMonoidCombine ithDest eltTy (sink bc) xElt yElt - _ -> error $ "Base monoid type mismatch: can't lift " ++ - pprint baseTy ++ " to " ++ pprint accTy toImpOp :: forall i o . Emits o => PrimOp SimpIR i -> SubstImpM i o (SAtom o) toImpOp op = case op of @@ -399,7 +367,7 @@ toImpVectorOp = \case refi <- destToAtom <$> indexDest refDest i refi' <- fromScalarAtom refi resultVal <- castPtrToVectorType refi' (toIVectorType vty) - repValAtom $ RepVal (RefTy State vty) (Leaf resultVal) + repValAtom $ RepVal (RefTy vty) (Leaf resultVal) where returnIExprVal x = return $ toScalarAtom x @@ -605,7 +573,7 @@ typeToTree tyTop = return $ go REmpty tyTop go ctx (TyCon con) = case con of BaseType b -> Leaf $ LeafType (unRNest ctx) b TabPi (TabPiType d b bodyTy) -> go (RNest ctx (TabCtx (PairB (LiftB d) b))) bodyTy - RefType _ t -> go (RNest ctx RefCtx) t + RefType t -> go (RNest ctx RefCtx) t DepPairTy (DepPairType _ (b:>t1) (t2)) -> do let tree1 = rec t1 let tree2 = go (RNest ctx (DepPairCtx (JustB (b:>t1)))) t2 @@ -639,7 +607,7 @@ valueToTree (RepVal tyTop valTop) = do go ctx (TyCon ty) val = case ty of BaseType b -> return $ Leaf $ LeafType (unRNest ctx) b TabPi (TabPiType d b bodyTy) -> go (RNest ctx (TabCtx (PairB (LiftB d) b))) bodyTy val - RefType _ t -> go (RNest ctx RefCtx) t val + RefType t -> go (RNest ctx RefCtx) t val DepPairTy (DepPairType _ (b:>t1) (t2)) -> case val of Branch [v1, v2] -> do case allDepPairCtxs (unRNest ctx) of @@ -795,11 +763,11 @@ atomToRepVal x = RepVal (getType x) <$> go x where -- from the dest. This version is not that. It just lifts a dest into an atom of -- type `Ref _`. destToAtom :: Dest n -> SAtom n -destToAtom (Dest valTy tree) = toAtom $ RepVal (RefTy State valTy) tree +destToAtom (Dest valTy tree) = toAtom $ RepVal (RefTy valTy) tree atomToDest :: EnvReader m => SAtom n -> m n (Dest n) atomToDest (Stuck _ (RepValAtom val)) = do - (RepVal ~(RefTy _ valTy) valTree) <- return val + (RepVal ~(RefTy valTy) valTree) <- return val return $ Dest valTy valTree atomToDest atom = error $ "Expected a non-var atom of type `RawRef _`, got: " ++ pprint atom {-# INLINE atomToDest #-} @@ -1276,21 +1244,6 @@ ordinalImp (IxType _ (DictCon dict)) i = fromScalarAtom =<< case dict of IxSpecialized d params -> do appSpecializedIxMethod d Ordinal (params ++ [i]) -unsafeFromOrdinalImp :: Emits n => IxType SimpIR n -> IExpr n -> SubstImpM i n (SAtom n) -unsafeFromOrdinalImp (IxType _ (DictCon dict)) i = do - let i' = toScalarAtom i - case dict of - IxRawFin _ -> return i' - IxSpecialized d params -> - appSpecializedIxMethod d UnsafeFromOrdinal (params ++ [i']) - -indexSetSizeImp :: Emits n => IxType SimpIR n -> SubstImpM i n (IExpr n) -indexSetSizeImp (IxType _ (DictCon dict)) = do - fromScalarAtom =<< case dict of - IxRawFin n -> return n - IxSpecialized d params -> - appSpecializedIxMethod d Size (params ++ []) - appSpecializedIxMethod :: Emits n => SpecDictName n -> IxMethod -> [SAtom n] -> SubstImpM i n (SAtom n) appSpecializedIxMethod d method args = do SpecializedDict _ (Just fs) <- lookupSpecDict d diff --git a/src/lib/Inference.hs b/src/lib/Inference.hs index 9457bed85..403c09098 100644 --- a/src/lib/Inference.hs +++ b/src/lib/Inference.hs @@ -701,8 +701,8 @@ getFieldDefs sid ty = case ty of (FieldName field, FieldDotMethod f params) return $ M.fromList $ concat projFields ++ methodFields ADTCons _ -> noFields - RefType _ valTy -> case valTy of - RefTy _ _ -> noFields + RefType valTy -> case valTy of + RefTy _ -> noFields _ -> do valFields <- getFieldDefs sid valTy return $ M.filter isProj valFields @@ -720,7 +720,7 @@ projectField i x = case getType x of TyCon con -> case con of ProdType _ -> proj i x NewtypeTyCon _ -> projectStruct i x - RefType _ valTy -> case valTy of + RefType valTy -> case valTy of TyCon (ProdType _) -> getProjRef (ProjectProduct i) x TyCon (NewtypeTyCon _) -> projectStructRef i x _ -> bad @@ -1029,14 +1029,12 @@ matchPrimApp = \case UMemOp op -> \x -> emit =<< MemOp <$> matchGenericOp op x UBinOp op -> \case ~[x, y] -> emit $ BinOp op x y UUnOp op -> \case ~[x] -> emit $ UnOp op x - UMAsk -> \case ~[r] -> emit $ RefOp r MAsk UMGet -> \case ~[r] -> emit $ RefOp r MGet UMPut -> \case ~[r, x] -> emit $ RefOp r $ MPut x UIndexRef -> \case ~[r, i] -> indexRef r i UApplyMethod i -> \case ~(d:args) -> emit =<< mkApplyMethod (fromJust $ toMaybeDict d) i args ULinearize -> \case ~[f, x] -> do f' <- lam1 f; emitHof $ Linearize f' x UTranspose -> \case ~[f, x] -> do f' <- lam1 f; emitHof $ Transpose f' x - UMExtend -> \case ~[r, z, f, x] -> do f' <- lam2 f; emit $ RefOp r $ MExtend (BaseMonoid z f') x p -> \case xs -> throwInternal $ "Bad primitive application: " ++ show (p, xs) where lam2 :: Fallible m => CAtom n -> m (LamExpr CoreIR n) @@ -1704,8 +1702,8 @@ instance Unifiable (TyCon CoreIR) where { SumType ts' <- matchit; unifyLists ts ts'} ( ProdType ts ) -> do { ProdType ts' <- matchit; unifyLists ts ts'} - ( RefType h t ) -> do - { RefType h' t' <- matchit; guard (h == h'); unify t t'} + ( RefType t ) -> do + { RefType t' <- matchit; unify t t'} ( DepPairTy t ) -> do { DepPairTy t' <- matchit; unify t t'} where matchit = return t2 diff --git a/src/lib/Lexing.hs b/src/lib/Lexing.hs index 3d7656e27..9d936851d 100644 --- a/src/lib/Lexing.hs +++ b/src/lib/Lexing.hs @@ -91,7 +91,6 @@ data KeyWord = DefKW | ForKW | For_KW | RofKW | Rof_KW | CaseKW | OfKW | InstanceKW | GivenKW | WithKW | SatisfyingKW | IfKW | ThenKW | ElseKW | DoKW | ImportKW | ForeignKW | NamedInstanceKW - | EffectKW | HandlerKW | JmpKW | CtlKW | ReturnKW | ResumeKW | CustomLinearizationKW | CustomLinearizationSymbolicKW | PassKW deriving (Enum) @@ -118,12 +117,6 @@ keyWordToken = \case DoKW -> "do" ImportKW -> "import" ForeignKW -> "foreign" - EffectKW -> "effect" - HandlerKW -> "handler" - JmpKW -> "jmp" - CtlKW -> "ctl" - ReturnKW -> "return" - ResumeKW -> "resume" CustomLinearizationKW -> "custom-linearization" CustomLinearizationSymbolicKW -> "custom-linearization-symbolic" PassKW -> "pass" diff --git a/src/lib/Linearize.hs b/src/lib/Linearize.hs index fc06b7fda..e750b8adb 100644 --- a/src/lib/Linearize.hs +++ b/src/lib/Linearize.hs @@ -169,10 +169,9 @@ getTangentArgTys topVs = go topVs where go :: (Fallible1 m, EnvExtender m) => [SAtomVar n] -> m n (EmptyAbs (Nest SBinder) n) go [] = return $ EmptyAbs Empty go (v:vs) = case getType v of - RefTy rws referentTy -> do + RefTy referentTy -> do tt <- tangentType referentTy - let refTy = RefTy rws tt - withFreshBinder (getNameHint v) refTy \refb -> do + withFreshBinder (getNameHint v) (RefTy tt) \refb -> do Abs bs UnitE <- go $ sinkList vs return $ EmptyAbs $ Nest refb bs ty -> do @@ -412,13 +411,6 @@ linearizeOp op = case op of RefOp ref m -> do ref' <- linearizeAtom ref case m of - MAsk -> emitBoth ref' \ref'' -> return $ RefOp ref'' MAsk - MExtend monoid x -> do - -- TODO: check that we're dealing with a +/0 monoid - monoid' <- renameM monoid - x' <- linearizeAtom x - emitBoth (zipLin ref' x') \(PairE ref'' x'') -> - return $ RefOp ref'' $ MExtend (sink monoid') x'' MGet -> emitBoth ref' \ref'' -> return $ RefOp ref'' MGet MPut x -> do x' <- linearizeAtom x diff --git a/src/lib/Name.hs b/src/lib/Name.hs index 79b24e78c..9c144eb37 100644 --- a/src/lib/Name.hs +++ b/src/lib/Name.hs @@ -1710,9 +1710,6 @@ instance Color TopFunNameC where getColorRep = TopFunNameC instance Color FunObjCodeNameC where getColorRep = FunObjCodeNameC instance Color ModuleNameC where getColorRep = ModuleNameC instance Color PtrNameC where getColorRep = PtrNameC -instance Color EffectNameC where getColorRep = EffectNameC -instance Color EffectOpNameC where getColorRep = EffectOpNameC -instance Color HandlerNameC where getColorRep = HandlerNameC instance Color SpecializedDictNameC where getColorRep = SpecializedDictNameC instance Color ImpNameC where getColorRep = ImpNameC -- The instance for Color UnsafeC is purposefully missing! UnsafeC is @@ -1732,9 +1729,6 @@ interpretColor c cont = case c of FunObjCodeNameC -> cont $ ColorProxy @FunObjCodeNameC ModuleNameC -> cont $ ColorProxy @ModuleNameC PtrNameC -> cont $ ColorProxy @PtrNameC - EffectNameC -> cont $ ColorProxy @EffectNameC - EffectOpNameC -> cont $ ColorProxy @EffectOpNameC - HandlerNameC -> cont $ ColorProxy @HandlerNameC SpecializedDictNameC -> cont $ ColorProxy @SpecializedDictNameC ImpNameC -> cont $ ColorProxy @ImpNameC UnsafeC -> error "shouldn't reflect over Unsafe colors!" @@ -2401,9 +2395,6 @@ data C = | FunObjCodeNameC | ModuleNameC | PtrNameC - | EffectNameC - | EffectOpNameC - | HandlerNameC | SpecializedDictNameC | UnsafeC | ImpNameC diff --git a/src/lib/OccAnalysis.hs b/src/lib/OccAnalysis.hs index f09a07db2..7d5f8079f 100644 --- a/src/lib/OccAnalysis.hs +++ b/src/lib/OccAnalysis.hs @@ -424,15 +424,15 @@ instance HasOCC (Hof SimpIR) where For _ _ _ -> error "For body should be a unary lambda expression" While body -> While <$> censored useManyTimes (occ accessOnce body) -oneShot :: Access n -> [IxExpr n] -> LamExpr SimpIR n -> OCCM n (LamExpr SimpIR n) -oneShot acc [] (LamExpr Empty body) = +_oneShot :: Access n -> [IxExpr n] -> LamExpr SimpIR n -> OCCM n (LamExpr SimpIR n) +_oneShot acc [] (LamExpr Empty body) = LamExpr Empty <$> occ acc body -oneShot acc (ix:ixs) (LamExpr (Nest b bs) body) = do +_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 + LamExpr bs' body' <- _oneShot (sink acc) (map sink ixs) restLam return $ LamExpr (Nest b' bs') body' -oneShot _ _ _ = error "zip error" +_oneShot _ _ _ = error "zip error" -- Going under a lambda binder. occWithBinder @@ -449,23 +449,10 @@ occWithBinder (Abs (b:>ty) body) cont = do instance HasOCC (RefOp SimpIR) where occ _ = \case - MExtend (BaseMonoid empty combine) val -> do - valIx <- summary val - -- Treat the combining function as inlined here and called once - combine' <- oneShot accessOnce [Deterministic [], valIx] combine - val' <- occ accessOnce val - -- TODO(precision) The empty value of the monoid is presumably dead here, - -- but we pretend like it's not to make sure that occurrence analysis - -- results mention every free variable in the traversed expression. This - -- may lead to missing an opportunity to inline something into the empty - -- value of the given monoid, since references thereto will be overcounted. - empty' <- occ accessOnce empty - return $ MExtend (BaseMonoid empty' combine') val' -- I'm pretty sure the others are all strict, and not usefully analyzable -- for what they do to the incoming access pattern. MPut x -> MPut <$> occ accessOnce x MGet -> return MGet - MAsk -> return MAsk IndexRef t i -> IndexRef <$> occTy t <*> occ accessOnce i ProjRef t i -> ProjRef <$> occTy t <*> pure i {-# INLINE occ #-} diff --git a/src/lib/QueryType.hs b/src/lib/QueryType.hs index c99d7bbd9..afd5b2955 100644 --- a/src/lib/QueryType.hs +++ b/src/lib/QueryType.hs @@ -45,7 +45,7 @@ caseAltsBinderTys ty = case ty of piTypeWithoutDest :: PiType SimpIR n -> PiType SimpIR n piTypeWithoutDest (PiType bsRefB _) = case popNest bsRefB of - Just (PairB bs (_:>RawRefTy ansTy)) -> PiType bs ansTy + Just (PairB bs (_:>RefTy ansTy)) -> PiType bs ansTy _ -> error "expected trailing dest binder" typeOfTabApp :: (IRRep r, EnvReader m) => Type r n -> Atom r n -> m n (Type r n) @@ -64,15 +64,15 @@ typeOfTopApp f xs = do return $ EffTy undefined ty -- TODO typeOfIndexRef :: (EnvReader m, Fallible1 m, IRRep r) => Type r n -> Atom r n -> m n (Type r n) -typeOfIndexRef (TyCon (RefType h s)) i = do +typeOfIndexRef (TyCon (RefType s)) i = do TyCon (TabPi tabPi) <- return s eltTy <- instantiate tabPi [i] - return $ toType $ RefType h eltTy + return $ toType $ RefType eltTy typeOfIndexRef _ _ = error "expected a ref type" typeOfProjRef :: EnvReader m => Type r n -> Projection -> m n (Type r n) -typeOfProjRef (TyCon (RefType h s)) p = do - toType . RefType h <$> case p of +typeOfProjRef (TyCon (RefType s)) p = do + toType . RefType <$> case p of ProjectProduct i -> do ~(TyCon (ProdType tys)) <- return s return $ tys !! i @@ -307,7 +307,7 @@ isData ty = do BaseType _ -> return () ProdType as -> mapM_ go as SumType cs -> mapM_ go cs - RefType _ _ -> return () + RefType _ -> return () TypeKind -> notData DictTy _ -> notData Pi _ -> notData diff --git a/src/lib/QueryTypePure.hs b/src/lib/QueryTypePure.hs index e34435cd2..a521e3b4b 100644 --- a/src/lib/QueryTypePure.hs +++ b/src/lib/QueryTypePure.hs @@ -145,11 +145,9 @@ instance IRRep r => HasType r (PrimOp r) where MiscOp op -> getType op VectorOp op -> getType op RefOp ref m -> case getType ref of - TyCon (RefType _ s) -> case m of + TyCon (RefType s) -> case m of MGet -> s MPut _ -> UnitTy - MAsk -> s - MExtend _ _ -> UnitTy IndexRef t _ -> t ProjRef t _ -> t _ -> error "not a reference type" @@ -175,7 +173,7 @@ instance IRRep r => HasType r (VectorOp r) where VectorIota vty -> vty VectorIdx _ _ vty -> vty VectorSubref ref _ vty -> case getType ref of - TyCon (RefType h _) -> TyCon $ RefType h vty + TyCon (RefType _) -> TyCon $ RefType vty ty -> error $ "Not a reference type: " ++ show ty instance IRRep r => HasType r (MiscOp r) where @@ -280,15 +278,10 @@ instance IRRep r => HasEffects (PrimOp r) r where OutputStream -> Pure ShowAny _ -> Pure ShowScalar _ -> Pure - RefOp ref m -> case getType ref of - TyCon (RefType _ _) -> case m of - MGet -> Effectful - MPut _ -> Effectful - MAsk -> Effectful - -- XXX: We don't verify the base monoid. See note about RunWriter. - MExtend _ _ -> Effectful - IndexRef _ _ -> Pure - ProjRef _ _ -> Pure - _ -> error "not a ref" + RefOp _ m -> case m of + MGet -> Effectful + MPut _ -> Effectful + IndexRef _ _ -> Pure + ProjRef _ _ -> Pure Hof (TypedHof (EffTy eff _) _) -> eff {-# INLINE getEffects #-} diff --git a/src/lib/RuntimePrint.hs b/src/lib/RuntimePrint.hs index 1cba35575..635a3559a 100644 --- a/src/lib/RuntimePrint.hs +++ b/src/lib/RuntimePrint.hs @@ -75,7 +75,7 @@ showAnyTyCon tyCon atom = case tyCon of -- TODO: we could do better than this but it's not urgent because raw sum types -- aren't user-facing. SumType _ -> printAsConstant - RefType _ _ -> printTypeOnly "reference" + RefType _ -> printTypeOnly "reference" ProdType _ -> do xs <- getUnpacked atom parens $ sepBy ", " $ map rec xs @@ -177,7 +177,7 @@ withBuffer cont = do bufferTy :: EnvReader m => m n (CType n) bufferTy = do t <- strType - return $ RefTy State (PairTy NatTy t) + return $ RefTy (PairTy NatTy t) -- argument has type `Fin n => Word8` extendBuffer :: (Emits n, CBuilder m) => CAtom n -> CAtom n -> m n () diff --git a/src/lib/Simplify.hs b/src/lib/Simplify.hs index f8cfe7738..304d63921 100644 --- a/src/lib/Simplify.hs +++ b/src/lib/Simplify.hs @@ -195,7 +195,7 @@ getRepType (TyCon con) = case con of BaseType b -> return $ toType $ BaseType b ProdType ts -> toType . ProdType <$> mapM getRepType ts SumType ts -> toType . SumType <$> mapM getRepType ts - RefType h a -> toType <$> (RefType h <$> getRepType a) + RefType a -> toType <$> (RefType <$> getRepType a) DepPairTy (DepPairType expl b r) -> do withSimplifiedBinder b \b' -> do r' <- getRepType r @@ -418,16 +418,10 @@ requireReduced expr = reduceExpr expr >>= \case simplifyRefOp :: Emits o => RefOp CoreIR i -> SAtom o -> SimplifyM i o (SAtom o) simplifyRefOp op ref = case op of - MExtend (BaseMonoid em cb) x -> do - em' <- toDataAtom em - x' <- toDataAtom x - (cb', CoerceReconAbs) <- simplifyLam cb - emitRefOp $ MExtend (BaseMonoid em' cb') x' MGet -> emit $ RefOp ref MGet MPut x -> do x' <- toDataAtom x emitRefOp $ MPut x' - MAsk -> emitRefOp MAsk IndexRef _ x -> do x' <- toDataAtom x emit =<< mkIndexRef ref x' diff --git a/src/lib/SourceIdTraversal.hs b/src/lib/SourceIdTraversal.hs index 2c5e74914..d030ab664 100644 --- a/src/lib/SourceIdTraversal.hs +++ b/src/lib/SourceIdTraversal.hs @@ -91,7 +91,6 @@ instance IsTree CSDecl where CLet v rhs -> visit v >> visit rhs CDefDecl def -> visit def CExpr g -> visit g - CBind v body -> visit v >> visit body CPass -> return () instance IsTree CTopDecl where diff --git a/src/lib/Transpose.hs b/src/lib/Transpose.hs index d5d5a32a0..18b68c881 100644 --- a/src/lib/Transpose.hs +++ b/src/lib/Transpose.hs @@ -105,9 +105,9 @@ withAccumulator ty cont = undefined -- cont LinTrivial >> return val emitCTToRef :: (Emits n, Builder SimpIR m) => SAtom n -> SAtom n -> m n () -emitCTToRef ref ct = do - baseMonoid <- tangentBaseMonoidFor (getType ct) - void $ emitLin $ RefOp ref $ MExtend baseMonoid ct +emitCTToRef ref ct = undefined + -- baseMonoid <- tangentBaseMonoidFor (getType ct) + -- void $ emitLin $ RefOp ref $ MExtend baseMonoid ct -- === actual pass === @@ -185,12 +185,6 @@ transposeOp op ct = case op of refArg' <- substNonlin refArg let emitEff = emitLin . RefOp refArg' case m of - MAsk -> do - baseMonoid <- tangentBaseMonoidFor (getType ct) - void $ emitEff $ MExtend baseMonoid ct - -- XXX: This assumes that the update function uses a tangent (0, +) monoid - -- rule for RunWriter. - MExtend _ x -> transposeAtom x =<< emitEff MAsk MGet -> void $ emitEff . MPut =<< addTangent ct =<< emitEff MGet MPut x -> do ct' <- emitEff MGet diff --git a/src/lib/Types/Core.hs b/src/lib/Types/Core.hs index 9726c8807..5f672f1e6 100644 --- a/src/lib/Types/Core.hs +++ b/src/lib/Types/Core.hs @@ -78,7 +78,7 @@ data TyCon (r::IR) (n::S) where BaseType :: BaseType -> TyCon r n ProdType :: [Type r n] -> TyCon r n SumType :: [Type r n] -> TyCon r n - RefType :: RWS -> Type r n -> TyCon r n + RefType :: Type r n -> TyCon r n TabPi :: TabPiType r n -> TyCon r n DepPairTy :: DepPairType r n -> TyCon r n TypeKind :: TyCon CoreIR n @@ -121,11 +121,6 @@ data Expr r n where deriving instance IRRep r => Show (Expr r n) deriving via WrapE (Expr r) n instance IRRep r => Generic (Expr r n) -data BaseMonoid r n = - BaseMonoid { baseEmpty :: Atom r n - , baseCombine :: LamExpr r n } - deriving (Show, Generic) - data RepVal (n::S) = RepVal (SType n) (Tree (IExpr n)) deriving (Show, Generic) @@ -374,9 +369,7 @@ deriving instance IRRep r => Show (Hof r n) deriving via WrapE (Hof r) n instance IRRep r => Generic (Hof r n) data RefOp r n = - MAsk - | MExtend (BaseMonoid r n) (Atom r n) - | MGet + MGet | MPut (Atom r n) | IndexRef (Type r n) (Atom r n) | ProjRef (Type r n) Projection @@ -638,11 +631,8 @@ pattern BaseTy b = TyCon (BaseType b) pattern PtrTy :: PtrType -> Type r n pattern PtrTy ty = TyCon (BaseType (PtrType ty)) -pattern RefTy :: RWS -> Type r n -> Type r n -pattern RefTy r a = TyCon (RefType r a) - -pattern RawRefTy :: Type r n -> Type r n -pattern RawRefTy a = TyCon (RefType State a) +pattern RefTy :: Type r n -> Type r n +pattern RefTy a = TyCon (RefType a) pattern TabTy :: IxDict r n -> Binder r n l -> Type r l -> Type r n pattern TabTy d b body = TyCon (TabPi (TabPiType d b body)) @@ -829,19 +819,6 @@ instance AlphaEqE NewtypeTyCon instance AlphaHashableE NewtypeTyCon instance RenameE NewtypeTyCon -instance IRRep r => GenericE (BaseMonoid r) where - type RepE (BaseMonoid r) = PairE (Atom r) (LamExpr r) - fromE (BaseMonoid x f) = PairE x f - {-# INLINE fromE #-} - toE (PairE x f) = BaseMonoid x f - {-# INLINE toE #-} - -instance IRRep r => SinkableE (BaseMonoid r) -instance IRRep r => HoistableE (BaseMonoid r) -instance IRRep r => RenameE (BaseMonoid r) -instance IRRep r => AlphaEqE (BaseMonoid r) -instance IRRep r => AlphaHashableE (BaseMonoid r) - instance IRRep r => GenericE (TypedHof r) where type RepE (TypedHof r) = EffTy r `PairE` Hof r fromE (TypedHof effTy hof) = effTy `PairE` hof @@ -885,16 +862,12 @@ instance IRRep r => AlphaHashableE (Hof r) instance GenericOp RefOp where type OpConst RefOp r = P.RefOp fromOp = \case - MAsk -> GenericOpRep P.MAsk [] [] [] - MExtend (BaseMonoid z f) x -> GenericOpRep P.MExtend [] [z, x] [f] MGet -> GenericOpRep P.MGet [] [] [] MPut x -> GenericOpRep P.MPut [] [x] [] IndexRef t x -> GenericOpRep P.IndexRef [t] [x] [] ProjRef t p -> GenericOpRep (P.ProjRef p) [t] [] [] {-# INLINE fromOp #-} toOp = \case - GenericOpRep P.MAsk [] [] [] -> Just $ MAsk - GenericOpRep P.MExtend [] [z, x] [f] -> Just $ MExtend (BaseMonoid z f) x GenericOpRep P.MGet [] [] [] -> Just $ MGet GenericOpRep P.MPut [] [x] [] -> Just $ MPut x GenericOpRep P.IndexRef [t] [x] [] -> Just $ IndexRef t x @@ -1274,7 +1247,7 @@ instance IRRep r => GenericE (TyCon r) where {- BaseType -} (LiftE BaseType) {- ProdType -} (ListE (Type r)) {- SumType -} (ListE (Type r)) - {- RefType -} (LiftE RWS `PairE` Type r)) + {- RefType -} (Type r)) (EitherE3 {- TabPi -} (TabPiType r) {- DepPairTy -} (DepPairType r) @@ -1287,7 +1260,7 @@ instance IRRep r => GenericE (TyCon r) where BaseType b -> Case0 (Case0 (LiftE b)) ProdType ts -> Case0 (Case1 (ListE ts)) SumType ts -> Case0 (Case2 (ListE ts)) - RefType h t -> Case0 (Case3 (LiftE h `PairE` t)) + RefType t -> Case0 (Case3 t) TabPi t -> Case1 (Case0 t) DepPairTy t -> Case1 (Case1 t) TypeKind -> Case1 (Case2 (WhenIRE UnitE)) @@ -1300,7 +1273,7 @@ instance IRRep r => GenericE (TyCon r) where Case0 (LiftE b ) -> BaseType b Case1 (ListE ts) -> ProdType ts Case2 (ListE ts) -> SumType ts - Case3 (LiftE h `PairE` t) -> RefType h t + Case3 t -> RefType t _ -> error "impossible" Case1 c -> case c of Case0 t -> TabPi t @@ -1679,7 +1652,6 @@ instance IRRep r => Store (Dict r n) instance IRRep r => Store (TypedHof r n) instance IRRep r => Store (Hof r n) instance IRRep r => Store (RefOp r n) -instance IRRep r => Store (BaseMonoid r n) instance Store (NewtypeCon n) instance Store (NewtypeTyCon n) instance Store (DotMethods n) @@ -1703,7 +1675,7 @@ instance IRRep r => PrettyPrec (TyCon r n) where encloseSep "(" ")" ", " $ fmap pApp as SumType cs -> atPrec ArgPrec $ align $ group $ encloseSep "(|" "|)" " | " $ fmap pApp cs - RefType _ a -> atPrec AppPrec $ "Ref" <+> p a + RefType a -> atPrec AppPrec $ "Ref" <+> p a TypeKind -> atPrec ArgPrec "Type" Pi piType -> atPrec LowestPrec $ align $ p piType TabPi piType -> atPrec LowestPrec $ align $ p piType @@ -1764,8 +1736,6 @@ instance IRRep r => PrettyPrec (PrimOp r n) where VectorOp op -> prettyPrec op Hof (TypedHof _ hof) -> prettyPrec hof RefOp ref eff -> atPrec LowestPrec case eff of - MAsk -> "ask" <+> pApp ref - MExtend _ x -> "extend" <+> pApp ref <+> pApp x MGet -> "get" <+> pApp ref MPut x -> pApp ref <+> ":=" <+> pApp x IndexRef _ i -> pApp ref <+> "!" <+> pApp i @@ -1989,8 +1959,3 @@ prettyBlock :: (IRRep r, PrettyPrec (e l)) => Nest (Decl r) n l -> e l -> Doc an prettyBlock Empty expr = group $ line <> pLowest expr prettyBlock decls expr = prettyLines decls' <> hardline <> pLowest expr where decls' = unsafeFromNest decls - -instance IRRep r => Pretty (BaseMonoid r n) where pretty = prettyFromPrettyPrec -instance IRRep r => PrettyPrec (BaseMonoid r n) where - prettyPrec (BaseMonoid x f) = - atPrec LowestPrec $ "baseMonoid" <+> pArg x <> nest 2 (line <> pArg f) diff --git a/src/lib/Types/Primitives.hs b/src/lib/Types/Primitives.hs index f449acba6..bc48cc988 100644 --- a/src/lib/Types/Primitives.hs +++ b/src/lib/Types/Primitives.hs @@ -50,8 +50,6 @@ instance Eq (AlwaysEqual a) where data Direction = Fwd | Rev deriving (Show, Eq, Generic) type ForAnn = Direction -data RWS = Reader | Writer | State deriving (Show, Eq, Ord, Generic) - -- TODO: add optional argument data InferenceMechanism = Unify | Synth RequiredMethodAccess deriving (Show, Eq, Ord, Generic) data Explicitness = @@ -198,7 +196,6 @@ instance IsString SourceName where instance Store SourceName instance Store RequiredMethodAccess instance Store LetAnn -instance Store RWS instance Store Direction instance Store BaseType instance Store LitVal @@ -210,7 +207,6 @@ instance Store DepPairExplicitness instance Store InferenceMechanism instance Hashable SourceName -instance Hashable RWS instance Hashable Direction instance Hashable BaseType instance Hashable PtrLitVal @@ -231,12 +227,6 @@ instance Pretty AppExplicitness where pretty ExplicitApp = "->" pretty ImplicitApp = "->>" -instance Pretty RWS where - pretty eff = case eff of - Reader -> "Read" - Writer -> "Accum" - State -> "State" - instance Pretty LetAnn where pretty ann = case ann of PlainLet -> "" diff --git a/src/lib/Types/Source.hs b/src/lib/Types/Source.hs index 139c3be4d..234db0c60 100644 --- a/src/lib/Types/Source.hs +++ b/src/lib/Types/Source.hs @@ -194,7 +194,6 @@ data CSDecl = CLet GroupW CSBlock | CDefDecl CDef | CExpr GroupW - | CBind GroupW CSBlock -- Arrow binder <- | CPass deriving (Show, Generic) @@ -408,15 +407,6 @@ data UTopDecl (n::S) (l::S) where type UType = UExpr type UConstraint = UExpr -data UResumePolicy = - UNoResume - | ULinearResume - | UAnyResume - deriving (Show, Eq, Generic) - -instance Hashable UResumePolicy -instance Store UResumePolicy - data UForExpr (n::S) where UForExpr :: UAnnBinder n l -> UBlock l -> UForExpr n @@ -650,7 +640,7 @@ data PrimName = | UMiscOp P.MiscOp | UUnOp UnOp | UBinOp BinOp - | UMAsk | UMExtend | UMGet | UMPut + | UMGet | UMPut | UWhile | ULinearize | UTranspose | UProjNewtype | UExplicitApply | UMonoLiteral | UIndexRef | UApplyMethod Int @@ -674,8 +664,7 @@ showPrimName prim = primNameToStr prim primNames :: M.Map String PrimName primNames = M.fromList - [ ("ask" , UMAsk), ("mextend", UMExtend) - , ("get" , UMGet), ("put" , UMPut) + [ ("get" , UMGet), ("put" , UMPut) , ("while" , UWhile) , ("linearize", ULinearize), ("linearTranspose", UTranspose) , ("iadd" , binary IAdd), ("isub" , binary ISub) @@ -1011,7 +1000,6 @@ instance Pretty CTopDecl where instance Pretty CSDecl where pretty = undefined -- pretty (CLet pat blk) = pArg pat <+> "=" <+> p blk - -- pretty (CBind pat blk) = pArg pat <+> "<-" <+> p blk -- pretty (CDefDecl (CDef name args maybeAnn blk)) = -- "def " <> fromString name <> " " <> prettyParamGroups args <+> annDoc -- <> nest 2 (hardline <> p blk) diff --git a/src/lib/Vectorize.hs b/src/lib/Vectorize.hs index fc7cc59a1..fa7d04e55 100644 --- a/src/lib/Vectorize.hs +++ b/src/lib/Vectorize.hs @@ -163,58 +163,6 @@ simplifyIxSize ixty = do _ -> 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 --- to detect scalar addition as the only monoid we recognize as commutative. --- Potentially relevant ideas: --- - Store commutativity or lack of it as a bit on the BaseMonoid object (but --- get the bit from where?) --- - Paramterize runWriter by a user-specified flag saying whether the monoid is --- to be commutative; record that on the RunWriter Hof, and enforce it by --- type-checking. --- - Is there a way to automate checking for commutativity via the typeclass --- system so the user doesn't have to keep writing "commutative" all the time? --- - Or maybe make commutativity the default, and require an explicit annotation --- to opt out? (Which mention in the type error) --- - Alternately, is there a way to parameterize the BaseMonoid class by a --- Commutativity bit, such that commutative instances implement the class --- parametrically in that bit, while not-known-to-be-commutative ones only --- implement the non-commutative version? --- - Will that bit be visible enough to the compiler to be picked up here? -monoidCommutativity :: (EnvReader m) => BaseMonoid SimpIR n -> m n MonoidCommutes -monoidCommutativity monoid = case isAdditionMonoid monoid of - Just () -> return Commutes - Nothing -> return DoesNotCommute -{-# INLINE monoidCommutativity #-} - -isAdditionMonoid :: BaseMonoid SimpIR n -> Maybe () -isAdditionMonoid monoid = do - BaseMonoid { baseEmpty = (Con (Lit l)) - , baseCombine = BinaryLamExpr (b1:>_) (b2:>_) body } <- Just monoid - unless (_isZeroLit l) Nothing - PrimOp (BinOp op (Stuck _ (Var b1')) (Stuck _ (Var b2'))) <- return 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 - Int64Lit 0 -> True - Int32Lit 0 -> True - Word8Lit 0 -> True - Word32Lit 0 -> True - Word64Lit 0 -> True - Float32Lit 0.0 -> True - Float64Lit 0.0 -> True - _ -> False - newtype VectorizeM i o a = VectorizeM { runVectorizeM :: SubstReaderT VSubstValC (BuilderT SimpIR (ReaderT Word32 Except)) i o a } @@ -284,33 +232,11 @@ vectorizeBlock (Abs (Nest (Let b (DeclBinding _ rhs)) rest) body) = do vectorizeRefOp :: Emits o => SAtom i -> RefOp SimpIR i -> VectorizeM i o (VAtom o) vectorizeRefOp ref' op = case op of - MAsk -> do - -- TODO A contiguous reference becomes a vector load producing a varying - -- result. - VVal Uniform ref <- vectorizeAtom ref' - VVal Uniform <$> emit (RefOp ref MAsk) - MExtend basemonoid' x' -> do - VVal refStab ref <- vectorizeAtom ref' - VVal xStab x <- vectorizeAtom x' - basemonoid <- case refStab of - Uniform -> case xStab of - Uniform -> do - vectorizeBaseMonoid basemonoid' Uniform Uniform - -- This case represents accumulating something loop-varying into a - -- loop-invariant accumulator, as e.g. sum. We can implement that for - -- commutative monoids, but we would want to have started with private - -- accumulators (one per lane), and then reduce them with an - -- appropriate sequence of vector reduction intrinsics at the end. - _ -> throwVectErr $ "Vectorizing non-sliced accumulation not implemented" - Contiguous -> do - vectorizeBaseMonoid basemonoid' Varying xStab - s -> throwVectErr $ "Cannot vectorize reference with loop-varying stability " ++ show s - VVal Uniform <$> emit (RefOp ref $ MExtend basemonoid x) IndexRef _ i' -> do VVal Uniform ref <- vectorizeAtom ref' VVal Contiguous i <- vectorizeAtom i' case getType ref of - TyCon (RefType _ (TabTy _ tb a)) -> do + TyCon (RefType (TabTy _ tb a)) -> do vty <- getVectorType =<< case hoist tb a of HoistSuccess a' -> return a' HoistFailure _ -> throwVectErr "Can't vectorize dependent table application" @@ -320,20 +246,6 @@ vectorizeRefOp ref' op = "bad type: " ++ pprint refTy ++ "\nref' : " ++ pprint ref' _ -> throwVectErr $ "Can't vectorize op: " ++ pprint (RefOp ref' op) -vectorizeBaseMonoid :: Emits o => BaseMonoid SimpIR i -> Stability -> Stability - -> VectorizeM i o (BaseMonoid SimpIR o) -vectorizeBaseMonoid (BaseMonoid empty combine) accStab xStab = do - -- TODO: This will probably create lots of vector broadcast of 0 instructions, - -- which will often be dead code because only the combine operation is - -- actually needed in that place. We can (i) rely on LLVM to get rid of them, - -- (ii) get rid of them ourselves by running DCE on Imp (which is problematic - -- because we don't have the effect system at that point), or (iii) change the - -- IR to not require the empty element for MExtend operations, since they - -- don't use it. - empty' <- ensureVarying =<< vectorizeAtom empty - combine' <- vectorizeLamExpr combine [accStab, xStab] - return $ BaseMonoid empty' combine' - vectorizePrimOp :: Emits o => PrimOp SimpIR i -> VectorizeM i o (VAtom o) vectorizePrimOp op = case op of UnOp opk arg -> do diff --git a/src/lib/Export.hs b/src/old/Export.hs similarity index 100% rename from src/lib/Export.hs rename to src/old/Export.hs