Commit 1ea8c451 authored by Sebastian Graf's avatar Sebastian Graf Committed by Marge Bot

PredType for type constraints in the pattern match checker instead of EvVar

Using EvVars for capturing type constraints implied side-effects in DsM
when we just wanted to *construct* type constraints.

But giving names to type constraints is only necessary when passing
Givens to the type checker, of which the majority of the pattern match
checker should be unaware.

Thus, we simply generate `newtype TyCt = TyCt PredType`, which are
nicely stateless. But at the same time this means we have to allocate
EvVars when we want to query the type oracle! So we keep the type oracle
state as `newtype TyState = TySt (Bag EvVar)`, which nicely makes a
distinction between new, unchecked `TyCt`s and the inert set in
`TyState`.
parent 0dad81ca
Pipeline #10413 passed with stages
in 398 minutes and 6 seconds
...@@ -51,9 +51,11 @@ import PatSyn ...@@ -51,9 +51,11 @@ import PatSyn
import HscTypes (CompleteMatch(..)) import HscTypes (CompleteMatch(..))
import BasicTypes (Boxity(..)) import BasicTypes (Boxity(..))
import Var (EvVar) import Var (EvVar)
import Coercion
import TcEvidence
import {-# SOURCE #-} DsExpr (dsExpr, dsLExpr) import {-# SOURCE #-} DsExpr (dsExpr, dsLExpr)
import MatchLit (dsLit, dsOverLit) import MatchLit (dsLit, dsOverLit)
import IOEnv
import DsMonad import DsMonad
import Bag import Bag
import TyCoRep import TyCoRep
...@@ -66,9 +68,6 @@ import Data.List (find) ...@@ -66,9 +68,6 @@ import Data.List (find)
import Control.Monad (forM, when, forM_) import Control.Monad (forM, when, forM_)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Coercion
import TcEvidence
import IOEnv
import qualified Data.Semigroup as Semi import qualified Data.Semigroup as Semi
{- {-
......
This diff is collapsed.
...@@ -29,7 +29,7 @@ module PmTypes ( ...@@ -29,7 +29,7 @@ module PmTypes (
setIndirectSDIE, setEntrySDIE, traverseSDIE, setIndirectSDIE, setEntrySDIE, traverseSDIE,
-- * The pattern match oracle -- * The pattern match oracle
VarInfo(..), TmState(..), Delta(..), initDelta, VarInfo(..), TmState(..), TyState(..), Delta(..), initDelta
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -57,7 +57,7 @@ import CoreUtils (exprType) ...@@ -57,7 +57,7 @@ import CoreUtils (exprType)
import PrelNames import PrelNames
import TysWiredIn import TysWiredIn
import TysPrim import TysPrim
import TcRnTypes (pprEvVarWithType) import TcType (evVarPred)
import Numeric (fromRat) import Numeric (fromRat)
import Data.Foldable (find) import Data.Foldable (find)
...@@ -441,7 +441,7 @@ instance Outputable a => Outputable (SharedDIdEnv a) where ...@@ -441,7 +441,7 @@ instance Outputable a => Outputable (SharedDIdEnv a) where
-- equal, thus represent the same set of values. -- equal, thus represent the same set of values.
-- --
-- See Note [TmState invariants]. -- See Note [TmState invariants].
newtype TmState = TS (SharedDIdEnv VarInfo) newtype TmState = TmSt (SharedDIdEnv VarInfo)
-- Deterministic so that we generate deterministic error messages -- Deterministic so that we generate deterministic error messages
-- | Information about an 'Id'. Stores positive ('vi_pos') facts, like @x ~ Just 42@, -- | Information about an 'Id'. Stores positive ('vi_pos') facts, like @x ~ Just 42@,
...@@ -498,7 +498,7 @@ data VarInfo ...@@ -498,7 +498,7 @@ data VarInfo
-- | Not user-facing. -- | Not user-facing.
instance Outputable TmState where instance Outputable TmState where
ppr (TS state) = ppr state ppr (TmSt state) = ppr state
-- | Not user-facing. -- | Not user-facing.
instance Outputable VarInfo where instance Outputable VarInfo where
...@@ -507,23 +507,34 @@ instance Outputable VarInfo where ...@@ -507,23 +507,34 @@ instance Outputable VarInfo where
-- | Initial state of the oracle. -- | Initial state of the oracle.
initTmState :: TmState initTmState :: TmState
initTmState = TS emptySDIE initTmState = TmSt emptySDIE
-- | The type oracle state. A poor man's inert set: The invariant is that all
-- constraints in there are mutually compatible.
newtype TyState = TySt (Bag EvVar)
-- | Not user-facing.
instance Outputable TyState where
ppr (TySt evs)
= braces $ hcat $ punctuate comma $ map (ppr . evVarPred) $ bagToList evs
initTyState :: TyState
initTyState = TySt emptyBag
-- | Term and type constraints to accompany each value vector abstraction. -- | Term and type constraints to accompany each value vector abstraction.
-- For efficiency, we store the term oracle state instead of the term -- For efficiency, we store the term oracle state instead of the term
-- constraints. -- constraints.
data Delta = MkDelta { delta_ty_cs :: Bag EvVar -- Type oracle; things like a~Int data Delta = MkDelta { delta_ty_st :: TyState -- Type oracle; things like a~Int
, delta_tm_cs :: TmState } -- Term oracle; things like x~Nothing , delta_tm_st :: TmState } -- Term oracle; things like x~Nothing
-- | An initial delta that is always satisfiable -- | An initial delta that is always satisfiable
initDelta :: Delta initDelta :: Delta
initDelta = MkDelta emptyBag initTmState initDelta = MkDelta initTyState initTmState
instance Outputable Delta where instance Outputable Delta where
ppr delta = vcat [ ppr delta = vcat [
-- intentionally formatted this way enable the dev to comment in only -- intentionally formatted this way enable the dev to comment in only
-- the info she needs -- the info she needs
ppr (delta_tm_cs delta), ppr (delta_tm_st delta),
ppr (pprEvVarWithType <$> delta_ty_cs delta) ppr (delta_ty_st delta)
--ppr (delta_ty_cs delta)
] ]
...@@ -860,12 +860,12 @@ see Note [Required quantifiers in the type of a term] in TcExpr. ...@@ -860,12 +860,12 @@ see Note [Required quantifiers in the type of a term] in TcExpr.
********************************************************************** -} ********************************************************************** -}
-- | A type of the form @p@ of kind @Constraint@ represents a value whose type is -- | A type of the form @p@ of constraint kind represents a value whose type is
-- the Haskell predicate @p@, where a predicate is what occurs before -- the Haskell predicate @p@, where a predicate is what occurs before
-- the @=>@ in a Haskell type. -- the @=>@ in a Haskell type.
-- --
-- We use 'PredType' as documentation to mark those types that we guarantee to have -- We use 'PredType' as documentation to mark those types that we guarantee to
-- this kind. -- have this kind.
-- --
-- It can be expanded into its representation, but: -- It can be expanded into its representation, but:
-- --
......
...@@ -327,3 +327,9 @@ instance Foldable.Foldable Bag where ...@@ -327,3 +327,9 @@ instance Foldable.Foldable Bag where
foldl' k z (UnitBag x) = k z x foldl' k z (UnitBag x) = k z x
foldl' k z (TwoBags b1 b2) = let r1 = foldl' k z b1 in seq r1 $ foldl' k r1 b2 foldl' k z (TwoBags b1 b2) = let r1 = foldl' k z b1 in seq r1 $ foldl' k r1 b2
foldl' k z (ListBag xs) = foldl' k z xs foldl' k z (ListBag xs) = foldl' k z xs
instance Traversable Bag where
traverse _ EmptyBag = pure EmptyBag
traverse f (UnitBag x) = UnitBag <$> f x
traverse f (TwoBags b1 b2) = TwoBags <$> traverse f b1 <*> traverse f b2
traverse f (ListBag xs) = ListBag <$> traverse f xs
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment