Simplify Simplify pass given new kind distinctions.

(especially that we no longer need to handle mixed data and non-data)

src/lib/CheapReduction.hs

@@ -15,8 +15,7 @@ module CheapReduction
   , visitBinders, visitPiDefault, visitAlt, toAtomVar, instantiate, withInstantiated
   , bindersToVars, bindersToAtoms, instantiateNames, withInstantiatedNames, assumeConst
   , repValAtom, reduceUnwrap, reduceProj, reduceSuperclassProj, typeOfApp
-  , reduceInstantiateGiven, queryStuckType, substMStuck, reduceTabApp, substStuck
-  , liftSimpAtom)
+  , reduceInstantiateGiven, queryStuckType, substMStuck, reduceTabApp, substStuck)
   where
 
 import Control.Applicative
@@ -185,8 +184,6 @@ queryStuckType = \case
     fTy <- queryStuckType f
     typeOfApp fTy xs
   SuperclassProj i s -> superclassProjType i =<< queryStuckType s
-  LiftSimp t _ -> return t
-  LiftSimpFun t _ -> return $ toType t
 
 projType :: (IRRep r, EnvReader m) => Int -> Atom r n -> m n (Type r n)
 projType i x = case getType x of
@@ -219,7 +216,7 @@ typeOfApp (TyCon (Pi piTy)) xs = withSubstReaderT $
   withInstantiated piTy xs \ty -> substM ty
 typeOfApp _ _ = error "expected a pi type"
 
-repValAtom :: EnvReader m => RepVal n -> m n (SAtom n)
+repValAtom :: EnvReader m => RepVal r n -> m n (Atom r n)
 repValAtom (RepVal ty tree) = case ty of
   TyCon (ProdType ts) -> case tree of
     Branch trees -> toAtom <$> ProdCon <$> mapM repValAtom (zipWith RepVal ts trees)
@@ -280,8 +277,8 @@ instantiate e xs = case toAbs e of
 
 -- "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]
+  :: (SubstReader (SubstVal val) m, IRRep r, SinkableE body, ToBindersAbs e body r)
+  => e i -> [val r o]
   -> (forall i'. body i' -> m i' o a)
   -> m i o a
 withInstantiated e xs cont = case toAbs e of
@@ -498,7 +495,7 @@ instance IRRep r => VisitGeneric (DepPairType r) r where
       PiType (UnaryNest b') ty' -> DepPairType expl b' ty'
       _ -> error "not a dependent pair type"
 
-instance VisitGeneric RepVal SimpIR where
+instance VisitGeneric (RepVal r) r where
   visitGeneric (RepVal ty tree) = RepVal <$> visitGeneric ty <*> mapM renameIExpr tree
     where renameIExpr = \case
             ILit l -> return $ ILit l
@@ -616,33 +613,6 @@ reduceStuck = \case
     reduceSuperclassProjM superclassIx child'
   PtrVar ptrTy ptr -> mkStuck =<< PtrVar ptrTy <$> substM ptr
   RepValAtom repVal -> mkStuck =<< RepValAtom <$> substM repVal
-  LiftSimp t s -> do
-    t' <- substM t
-    s' <- reduceStuck s
-    liftSimpAtom t' s'
-  LiftSimpFun t f -> mkStuck =<< (LiftSimpFun <$> substM t <*> substM f)
-
-liftSimpAtom :: EnvReader m => Type CoreIR n -> SAtom n -> m n (CAtom n)
-liftSimpAtom (StuckTy _ _) _ = error "Can't lift stuck type"
-liftSimpAtom ty@(TyCon tyCon) simpAtom = case simpAtom of
-  Stuck _ stuck -> return $ Stuck ty $ LiftSimp ty stuck
-  Con con -> Con <$> case (tyCon, con) of
-    (NewtypeTyCon newtypeCon, _) -> do
-      (dataCon, repTy) <- unwrapNewtypeType newtypeCon
-      cAtom <- rec repTy (Con con)
-      return $ NewtypeCon dataCon cAtom
-    (BaseType _  , Lit v)      -> return $ Lit v
-    (ProdType tys, ProdCon xs)   -> ProdCon <$> zipWithM rec tys xs
-    (SumType  tys, SumCon _ i x) -> 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
-  where
-    rec = liftSimpAtom
-{-# INLINE liftSimpAtom #-}
 
 instance SubstE AtomSubstVal SpecializationSpec where
   substE env (AppSpecialization (AtomVar f _) ab) = do
@@ -658,7 +628,7 @@ instance SubstE AtomSubstVal (Effects r) where
     Effectful -> Effectful
 
 instance SubstE AtomSubstVal IExpr
-instance SubstE AtomSubstVal RepVal
+instance IRRep r => SubstE AtomSubstVal (RepVal r)
 instance SubstE AtomSubstVal TyConParams
 instance SubstE AtomSubstVal DataConDef
 instance IRRep r => SubstE AtomSubstVal (TypedHof r)

src/lib/CheckType.hs

@@ -299,8 +299,6 @@ instance IRRep r => CheckableE r (Stuck r) where
     SuperclassProj i d -> SuperclassProj <$> pure i <*> checkE d -- TODO: check index in range
     PtrVar t v -> PtrVar t <$> renameM v
     RepValAtom repVal -> RepValAtom <$> renameM repVal -- TODO: check
-    LiftSimp t x -> LiftSimp <$> checkE t <*> renameM x -- TODO: check
-    LiftSimpFun t x -> LiftSimpFun <$> checkE t <*> renameM x -- TODO: check
 
 depPairLeftTy :: DepPairType r n -> Type r n
 depPairLeftTy (DepPairType _ (_:>ty) _) = ty

src/lib/Imp.hs

@@ -579,7 +579,7 @@ traverseScalarRepTys :: EnvReader m => SType n -> (LeafType n -> m n a) -> m n (
 traverseScalarRepTys ty f = traverse f =<< typeToTree ty
 {-# INLINE traverseScalarRepTys #-}
 
-storeRepVal :: Emits n => Dest n -> RepVal n -> SubstImpM i n ()
+storeRepVal :: Emits n => Dest n -> RepVal SimpIR n -> SubstImpM i n ()
 storeRepVal (Dest _ destTree) repVal@(RepVal _ valTree) = do
   leafTys <- valueToTree repVal
   forM_ (zipTrees (zipTrees leafTys destTree) valTree) \((leafTy, ptr), val) -> do
@@ -588,7 +588,7 @@ 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 => RepVal n -> m n (Tree (LeafType n))
+valueToTree :: EnvReader m => RepVal SimpIR n -> m n (Tree (LeafType n))
 valueToTree (RepVal tyTop valTop) = do
   go REmpty tyTop valTop
  where
@@ -705,7 +705,7 @@ isNull p = do
 nullPtrIExpr :: BaseType -> IExpr n
 nullPtrIExpr baseTy = ILit $ PtrLit (CPU, baseTy) NullPtr
 
-loadRepVal :: (ImpBuilder m, Emits n) => Dest n -> m n (RepVal n)
+loadRepVal :: (ImpBuilder m, Emits n) => Dest n -> m n (RepVal SimpIR n)
 loadRepVal (Dest valTy destTree) = do
   leafTys <- typeToTree valTy
   RepVal valTy <$> forM (zipTrees leafTys destTree) \(leafTy, ptr) -> do
@@ -715,7 +715,7 @@ loadRepVal (Dest valTy destTree) = do
       _         -> return ptr
 {-# INLINE loadRepVal #-}
 
-atomToRepVal :: Emits n => SAtom n -> SubstImpM i n (RepVal n)
+atomToRepVal :: Emits n => SAtom n -> SubstImpM i n (RepVal SimpIR n)
 atomToRepVal x = RepVal (getType x) <$> go x where
   go :: Emits n => SAtom n -> SubstImpM i n (Tree (IExpr n))
   go (Con con) = case con of
@@ -732,9 +732,7 @@ atomToRepVal x = RepVal (getType x) <$> go x where
         else buildGarbageVal t <&> \(Stuck _ (RepValAtom (RepVal _ tree))) -> tree
       return $ Branch $ tag':xs
   go (Stuck _ stuck) = case stuck of
-    Var v -> lookupAtomName (atomVarName v) >>= \case
-      TopDataBound (RepVal _ tree) -> return tree
-      _ -> error "should only have pointer and data atom names left"
+    Var _ -> error "should only have pointer and data atom names left"
     PtrVar ty p -> return $ Leaf $ IPtrVar p ty
     RepValAtom dRepVal -> do
       (RepVal _ tree) <- return dRepVal
@@ -759,7 +757,7 @@ atomToDest (Stuck _ (RepValAtom val)) = do
 atomToDest atom = error $ "Expected a non-var atom of type `RawRef _`, got: " ++ pprint atom
 {-# INLINE atomToDest #-}
 
-repValToList :: RepVal n -> [IExpr n]
+repValToList :: RepVal r n -> [IExpr n]
 repValToList (RepVal _ tree) = toList tree
 
 -- TODO: augment with device, backend information as needed
@@ -832,7 +830,7 @@ storeAtom dest x = storeRepVal dest =<< atomToRepVal x
 loadAtom :: Emits n => Dest n -> SubstImpM i n (SAtom n)
 loadAtom d = repValAtom =<< loadRepVal d
 
-repValFromFlatList :: (TopBuilder m, Mut n) => SType n -> [LitVal] -> m n (RepVal n)
+repValFromFlatList :: (TopBuilder m, Mut n) => SType n -> [LitVal] -> m n (RepVal SimpIR n)
 repValFromFlatList ty xs = do
   (litValTree, []) <- runStreamReaderT1 xs $ traverseScalarRepTys ty \_ ->
     fromJust <$> readStream

src/lib/QueryType.hs

@@ -85,7 +85,7 @@ typeOfProjRef _ _ = error "expected a reference"
 appEffTy  :: (IRRep r, EnvReader m) => Type r n -> [Atom r n] -> m n (EffTy r n)
 appEffTy (TyCon (Pi piTy)) xs = do
   ty <- instantiate piTy xs
-  return $ EffTy undefined ty  -- TODO
+  return $ EffTy Effectful ty  -- TODO: don't assume Effectful
 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)

src/lib/QueryTypePure.hs

@@ -36,7 +36,6 @@ instance IRRep r => HasType r (AtomBinding r) where
     SolverBound (SkolemBound ty)   -> ty
     SolverBound (DictBound   ty)   -> ty
     NoinlineFun ty _               -> ty
-    TopDataBound e                 -> getType e
     FFIFunBound piTy _ -> TyCon $ Pi piTy
 
 litType :: LitVal -> BaseType
@@ -133,7 +132,7 @@ instance IRRep r => HasType r (Expr r) where
     Project t _ _ -> t
     Unwrap t _ -> t
 
-instance HasType SimpIR RepVal where
+instance IRRep r => HasType r (RepVal r) where
   getType (RepVal ty _) = ty
 
 instance IRRep r => HasType r (PrimOp r) where

src/lib/RuntimePrint.hs

@@ -28,8 +28,8 @@ newtype Printer (n::S) (a :: *) = Printer { runPrinter' :: ReaderT1 (Atom CoreIR
                  , Fallible, ScopeReader, MonadFail, EnvExtender, CBuilder, ScopableBuilder CoreIR)
 type Print n = Printer n ()
 
-showAny :: EnvReader m => Atom CoreIR n -> m n (CExpr n)
-showAny x = liftPrinter $ showAnyRec (sink x)
+showAny :: EnvReader m => Atom SimpIR n -> m n (CExpr n)
+showAny x = undefined -- liftPrinter $ showAnyRec (sink x)
 
 liftPrinter
   :: EnvReader m