Commit 2763f56d authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Improve pruning of case alternatives to account for GADTs

Consider

  data T a where
    T1 :: T Int
    T2 :: T Bool
    T3 :: T Char

  f :: T Bool -> Int
  f x = case x of
	  DEFAULT -> ...
	  T2 -> 3

Here the DEFAULT case covers multiple constructors (T1,T3), but none 
of them can match a scrutinee of type (T Bool).  So we can prune away
the default case altogether.

In implementing this, I re-factored this bit of the simplifier, elminiating
prepareAlts from SimplUtils, and putting all the work into simplAlts in
Simplify

The proximate cause was a program written by Manuel using PArrays
parent 91a9aeeb
......@@ -11,7 +11,7 @@ module CoreUtils (
mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
-- Taking expressions apart
findDefault, findAlt, isDefaultAlt,
findDefault, findAlt, isDefaultAlt, mergeAlts,
-- Properties of expressions
exprType, coreAltType,
......@@ -306,6 +306,18 @@ findAlt con alts
isDefaultAlt :: CoreAlt -> Bool
isDefaultAlt (DEFAULT, _, _) = True
isDefaultAlt other = False
---------------------------------
mergeAlts :: [CoreAlt] -> [CoreAlt] -> [CoreAlt]
-- Merge preserving order; alternatives in the first arg
-- shadow ones in the second
mergeAlts [] as2 = as2
mergeAlts as1 [] = as1
mergeAlts (a1:as1) (a2:as2)
= case a1 `cmpAlt` a2 of
LT -> a1 : mergeAlts as1 (a2:as2)
EQ -> a1 : mergeAlts as1 as2 -- Discard a2
GT -> a2 : mergeAlts (a1:as1) as2
\end{code}
......
......@@ -279,8 +279,13 @@ pprCoreBinder LetBind binder
-- Lambda bound type variables are preceded by "@"
pprCoreBinder LambdaBind bndr = parens (pprTypedBinder bndr)
-- Case bound things don't get a signature or a herald
pprCoreBinder CaseBind bndr = pprUntypedBinder bndr
-- Case bound things don't get a signature or a herald, unless we have debug on
pprCoreBinder CaseBind bndr
= getPprStyle $ \ sty ->
if debugStyle sty then
parens (pprTypedBinder bndr)
else
pprUntypedBinder bndr
pprUntypedBinder binder
| isTyVar binder = ptext SLIT("@") <+> ppr binder -- NB: don't print kind
......
......@@ -5,7 +5,7 @@
\begin{code}
module SimplUtils (
mkLam, prepareAlts, mkCase,
mkLam, mkCase,
-- Inlining,
preInlineUnconditionally, postInlineUnconditionally, activeInline, activeRule,
......@@ -31,24 +31,22 @@ import CoreSyn
import CoreFVs ( exprFreeVars )
import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial, exprIsCheap,
etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce2,
findDefault, exprOkForSpeculation, exprIsHNF
findDefault, exprOkForSpeculation, exprIsHNF, mergeAlts
)
import Literal ( mkStringLit )
import CoreUnfold ( smallEnoughToInline )
import MkId ( eRROR_ID )
import Id ( idType, isDataConWorkId, idOccInfo, isDictId,
mkSysLocal, isDeadBinder, idNewDemandInfo, isExportedId,
isDeadBinder, idNewDemandInfo, isExportedId,
idUnfolding, idNewStrictness, idInlinePragma,
)
import NewDemand ( isStrictDmd, isBotRes, splitStrictSig )
import SimplMonad
import Type ( Type, splitFunTys, dropForAlls, isStrictType,
splitTyConApp_maybe, tyConAppArgs, mkTyVarTys
splitTyConApp_maybe, tyConAppArgs
)
import Name ( mkSysTvName )
import TyCon ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon )
import DataCon ( dataConRepArity, dataConTyVars, dataConInstArgTys, isVanillaDataCon )
import Var ( tyVarKind, mkTyVar )
import TyCon ( tyConDataCons_maybe )
import DataCon ( dataConRepArity )
import VarSet
import BasicTypes ( TopLevelFlag(..), isNotTopLevel, OccInfo(..), isLoopBreaker, isOneOcc,
Activation, isAlwaysActive, isActive )
......@@ -1071,144 +1069,6 @@ tryRhsTyLam env tyvars body -- Only does something if there's a let
-}
\end{code}
%************************************************************************
%* *
\subsection{Case alternative filtering
%* *
%************************************************************************
prepareAlts does two things:
1. Eliminate alternatives that cannot match, including the
DEFAULT alternative.
2. If the DEFAULT alternative can match only one possible constructor,
then make that constructor explicit.
e.g.
case e of x { DEFAULT -> rhs }
===>
case e of x { (a,b) -> rhs }
where the type is a single constructor type. This gives better code
when rhs also scrutinises x or e.
It's a good idea do do this stuff before simplifying the alternatives, to
avoid simplifying alternatives we know can't happen, and to come up with
the list of constructors that are handled, to put into the IdInfo of the
case binder, for use when simplifying the alternatives.
Eliminating the default alternative in (1) isn't so obvious, but it can
happen:
data Colour = Red | Green | Blue
f x = case x of
Red -> ..
Green -> ..
DEFAULT -> h x
h y = case y of
Blue -> ..
DEFAULT -> [ case y of ... ]
If we inline h into f, the default case of the inlined h can't happen.
If we don't notice this, we may end up filtering out *all* the cases
of the inner case y, which give us nowhere to go!
\begin{code}
prepareAlts :: OutExpr -- Scrutinee
-> InId -- Case binder (passed only to use in statistics)
-> [InAlt] -- Increasing order
-> SimplM ([InAlt], -- Better alternatives, still incresaing order
[AltCon]) -- These cases are handled
prepareAlts scrut case_bndr alts
= let
(alts_wo_default, maybe_deflt) = findDefault alts
impossible_cons = case scrut of
Var v -> otherCons (idUnfolding v)
other -> []
-- Filter out alternatives that can't possibly match
better_alts | null impossible_cons = alts_wo_default
| otherwise = [alt | alt@(con,_,_) <- alts_wo_default,
not (con `elem` impossible_cons)]
-- "handled_cons" are handled either by the context,
-- or by a branch in this case expression
-- (Don't add DEFAULT to the handled_cons!!)
handled_cons = impossible_cons ++ [con | (con,_,_) <- better_alts]
in
-- Filter out the default, if it can't happen,
-- or replace it with "proper" alternative if there
-- is only one constructor left
prepareDefault scrut case_bndr handled_cons maybe_deflt `thenSmpl` \ deflt_alt ->
returnSmpl (mergeAlts better_alts deflt_alt, handled_cons)
-- We need the mergeAlts in case the new default_alt
-- has turned into a constructor alternative.
prepareDefault scrut case_bndr handled_cons (Just rhs)
| Just (tycon, inst_tys) <- splitTyConApp_maybe (exprType scrut),
-- Use exprType scrut here, rather than idType case_bndr, because
-- case_bndr is an InId, so exprType scrut may have more information
-- Test simpl013 is an example
isAlgTyCon tycon, -- It's a data type, tuple, or unboxed tuples.
not (isNewTyCon tycon), -- We can have a newtype, if we are just doing an eval:
-- case x of { DEFAULT -> e }
-- and we don't want to fill in a default for them!
Just all_cons <- tyConDataCons_maybe tycon,
not (null all_cons), -- This is a tricky corner case. If the data type has no constructors,
-- which GHC allows, then the case expression will have at most a default
-- alternative. We don't want to eliminate that alternative, because the
-- invariant is that there's always one alternative. It's more convenient
-- to leave
-- case x of { DEFAULT -> e }
-- as it is, rather than transform it to
-- error "case cant match"
-- which would be quite legitmate. But it's a really obscure corner, and
-- not worth wasting code on.
let handled_data_cons = [data_con | DataAlt data_con <- handled_cons],
let missing_cons = [con | con <- all_cons,
not (con `elem` handled_data_cons)]
= case missing_cons of
[] -> returnSmpl [] -- Eliminate the default alternative
-- if it can't match
[con] -> -- It matches exactly one constructor, so fill it in
tick (FillInCaseDefault case_bndr) `thenSmpl_`
mk_args con inst_tys `thenSmpl` \ args ->
returnSmpl [(DataAlt con, args, rhs)]
two_or_more -> returnSmpl [(DEFAULT, [], rhs)]
| otherwise
= returnSmpl [(DEFAULT, [], rhs)]
prepareDefault scrut case_bndr handled_cons Nothing
= returnSmpl []
mk_args missing_con inst_tys
= mk_tv_bndrs missing_con inst_tys `thenSmpl` \ (tv_bndrs, inst_tys') ->
getUniquesSmpl `thenSmpl` \ id_uniqs ->
let arg_tys = dataConInstArgTys missing_con inst_tys'
arg_ids = zipWith (mkSysLocal FSLIT("a")) id_uniqs arg_tys
in
returnSmpl (tv_bndrs ++ arg_ids)
mk_tv_bndrs missing_con inst_tys
| isVanillaDataCon missing_con
= returnSmpl ([], inst_tys)
| otherwise
= getUniquesSmpl `thenSmpl` \ tv_uniqs ->
let new_tvs = zipWith mk tv_uniqs (dataConTyVars missing_con)
mk uniq tv = mkTyVar (mkSysTvName uniq FSLIT("t")) (tyVarKind tv)
in
returnSmpl (new_tvs, mkTyVarTys new_tvs)
\end{code}
%************************************************************************
%* *
\subsection{Case absorption and identity-case elimination}
......@@ -1339,19 +1199,6 @@ mkAlts dflags scrut outer_bndr outer_alts
------------------------------------------------
mkAlts dflags scrut case_bndr other_alts = returnSmpl other_alts
---------------------------------
mergeAlts :: [OutAlt] -> [OutAlt] -> [OutAlt]
-- Merge preserving order; alternatives in the first arg
-- shadow ones in the second
mergeAlts [] as2 = as2
mergeAlts as1 [] = as1
mergeAlts (a1:as1) (a2:as2)
= case a1 `cmpAlt` a2 of
LT -> a1 : mergeAlts as1 (a2:as2)
EQ -> a1 : mergeAlts as1 as2 -- Discard a2
GT -> a2 : mergeAlts (a1:as1) as2
\end{code}
......
......@@ -13,7 +13,7 @@ import DynFlags ( dopt, DynFlag(Opt_D_dump_inlinings),
)
import SimplMonad
import SimplEnv
import SimplUtils ( mkCase, mkLam, prepareAlts,
import SimplUtils ( mkCase, mkLam,
SimplCont(..), DupFlag(..), LetRhsFlag(..),
mkRhsStop, mkBoringStop, pushContArgs,
contResultType, countArgs, contIsDupable, contIsRhsOrArg,
......@@ -22,7 +22,7 @@ import SimplUtils ( mkCase, mkLam, prepareAlts,
inlineMode, activeInline, activeRule
)
import Id ( Id, idType, idInfo, idArity, isDataConWorkId,
setIdUnfolding, isDeadBinder,
idUnfolding, setIdUnfolding, isDeadBinder,
idNewDemandInfo, setIdInfo,
setIdOccInfo, zapLamIdInfo, setOneShotLambda
)
......@@ -34,15 +34,16 @@ import IdInfo ( OccInfo(..), isLoopBreaker,
occInfo
)
import NewDemand ( isStrictDmd )
import Unify ( coreRefineTys )
import DataCon ( dataConTyCon, dataConRepStrictness, isVanillaDataCon )
import TyCon ( tyConArity )
import Unify ( coreRefineTys, dataConCanMatch )
import DataCon ( DataCon, dataConTyCon, dataConRepStrictness, isVanillaDataCon,
dataConInstArgTys, dataConTyVars )
import TyCon ( tyConArity, isAlgTyCon, isNewTyCon, tyConDataCons_maybe )
import CoreSyn
import PprCore ( pprParendExpr, pprCoreExpr )
import CoreUnfold ( mkUnfolding, callSiteInline )
import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding,
exprIsConApp_maybe, mkPiTypes, findAlt,
exprType, exprIsHNF,
exprType, exprIsHNF, findDefault, mergeAlts,
exprOkForSpeculation, exprArity,
mkCoerce, mkCoerce2, mkSCC, mkInlineMe, applyTypeToArg
)
......@@ -50,19 +51,23 @@ import Rules ( lookupRule )
import BasicTypes ( isMarkedStrict )
import CostCentre ( currentCCS )
import Type ( TvSubstEnv, isUnLiftedType, seqType, tyConAppArgs, funArgTy,
splitFunTy_maybe, splitFunTy, coreEqType
splitFunTy_maybe, splitFunTy, coreEqType, splitTyConApp_maybe,
isTyVarTy, mkTyVarTys
)
import Var ( tyVarKind, mkTyVar )
import VarEnv ( elemVarEnv, emptyVarEnv )
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
import BasicTypes ( TopLevelFlag(..), isTopLevel,
RecFlag(..), isNonRec
)
import Name ( mkSysTvName )
import StaticFlags ( opt_PprStyle_Debug )
import OrdList
import List ( nub )
import Maybes ( orElse )
import Outputable
import Util ( notNull )
import Util ( notNull, filterOut )
\end{code}
......@@ -1292,13 +1297,10 @@ rebuildCase env scrut case_bndr alts cont
= knownCon env (LitAlt lit) [] case_bndr alts cont
| otherwise
= -- Prepare the alternatives.
prepareAlts scrut case_bndr alts `thenSmpl` \ (better_alts, handled_cons) ->
-- Prepare the continuation;
= -- Prepare the continuation;
-- The new subst_env is in place
prepareCaseCont env better_alts cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) ->
addFloats env floats $ \ env ->
prepareCaseCont env alts cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) ->
addFloats env floats $ \ env ->
let
-- The case expression is annotated with the result type of the continuation
......@@ -1316,8 +1318,7 @@ rebuildCase env scrut case_bndr alts cont
simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr') ->
-- Deal with the case alternatives
simplAlts alt_env handled_cons
case_bndr' better_alts dup_cont `thenSmpl` \ alts' ->
simplAlts alt_env scrut case_bndr' alts dup_cont `thenSmpl` \ alts' ->
-- Put the case back together
mkCase scrut case_bndr' res_ty' alts' `thenSmpl` \ case_expr ->
......@@ -1429,29 +1430,174 @@ simplCaseBinder env other_scrut case_bndr
\end{code}
simplAlts does two things:
1. Eliminate alternatives that cannot match, including the
DEFAULT alternative.
2. If the DEFAULT alternative can match only one possible constructor,
then make that constructor explicit.
e.g.
case e of x { DEFAULT -> rhs }
===>
case e of x { (a,b) -> rhs }
where the type is a single constructor type. This gives better code
when rhs also scrutinises x or e.
Here "cannot match" includes knowledge from GADTs
It's a good idea do do this stuff before simplifying the alternatives, to
avoid simplifying alternatives we know can't happen, and to come up with
the list of constructors that are handled, to put into the IdInfo of the
case binder, for use when simplifying the alternatives.
Eliminating the default alternative in (1) isn't so obvious, but it can
happen:
data Colour = Red | Green | Blue
f x = case x of
Red -> ..
Green -> ..
DEFAULT -> h x
h y = case y of
Blue -> ..
DEFAULT -> [ case y of ... ]
If we inline h into f, the default case of the inlined h can't happen.
If we don't notice this, we may end up filtering out *all* the cases
of the inner case y, which give us nowhere to go!
\begin{code}
simplAlts :: SimplEnv
-> [AltCon] -- Alternatives the scrutinee can't be
-- in the default case
-> OutExpr
-> OutId -- Case binder
-> [InAlt] -> SimplCont
-> SimplM [OutAlt] -- Includes the continuation
simplAlts env handled_cons case_bndr' alts cont'
= do { mb_alts <- mapSmpl simpl_alt alts
; return [alt' | Just (_, alt') <- mb_alts] }
-- Filter out the alternatives that are inaccessible
simplAlts env scrut case_bndr' alts cont'
= do { mb_alts <- mapSmpl (simplAlt env imposs_cons case_bndr' cont') alts_wo_default
; default_alts <- simplDefault env case_bndr' imposs_deflt_cons cont' maybe_deflt
; return (mergeAlts default_alts [alt' | Just (_, alt') <- mb_alts]) }
-- We need the mergeAlts in case the new default_alt
-- has turned into a constructor alternative.
where
simpl_alt alt = simplAlt env handled_cons case_bndr' alt cont'
(alts_wo_default, maybe_deflt) = findDefault alts
imposs_cons = case scrut of
Var v -> otherCons (idUnfolding v)
other -> []
-- "imposs_deflt_cons" are handled either by the context,
-- OR by a branch in this case expression. (Don't include DEFAULT!!)
imposs_deflt_cons = nub (imposs_cons ++ [con | (con,_,_) <- alts_wo_default])
simplDefault :: SimplEnv
-> OutId -- Case binder; need just for its type. Note that as an
-- OutId, it has maximum information; this is important.
-- Test simpl013 is an example
-> [AltCon] -- These cons can't happen when matching the default
-> SimplCont
-> Maybe InExpr
-> SimplM [OutAlt] -- One branch or none; we use a list because it's what
-- mergeAlts expects
simplDefault env case_bndr' imposs_cons cont Nothing
= return [] -- No default branch
simplDefault env case_bndr' imposs_cons cont (Just rhs)
| -- This branch handles the case where we are
-- scrutinisng an algebraic data type
Just (tycon, inst_tys) <- splitTyConApp_maybe (idType case_bndr'),
isAlgTyCon tycon, -- It's a data type, tuple, or unboxed tuples.
not (isNewTyCon tycon), -- We can have a newtype, if we are just doing an eval:
-- case x of { DEFAULT -> e }
-- and we don't want to fill in a default for them!
Just all_cons <- tyConDataCons_maybe tycon,
not (null all_cons), -- This is a tricky corner case. If the data type has no constructors,
-- which GHC allows, then the case expression will have at most a default
-- alternative. We don't want to eliminate that alternative, because the
-- invariant is that there's always one alternative. It's more convenient
-- to leave
-- case x of { DEFAULT -> e }
-- as it is, rather than transform it to
-- error "case cant match"
-- which would be quite legitmate. But it's a really obscure corner, and
-- not worth wasting code on.
let imposs_data_cons = [con | DataAlt con <- imposs_cons] -- We now know it's a data type
poss_data_cons = filterOut (`elem` imposs_data_cons) all_cons
gadt_imposs | all isTyVarTy inst_tys = []
| otherwise = filter (cant_match inst_tys) poss_data_cons
final_poss = filterOut (`elem` gadt_imposs) poss_data_cons
= case final_poss of
[] -> returnSmpl [] -- Eliminate the default alternative
-- altogether if it can't match
[con] -> -- It matches exactly one constructor, so fill it in
do { con_alt <- mkDataConAlt case_bndr' con inst_tys rhs
; Just (_, alt') <- simplAlt env [] case_bndr' cont con_alt
-- The simplAlt must succeed with Just because we have
-- already filtered out construtors that can't match
; return [alt'] }
simplAlt :: SimplEnv -> [AltCon] -> OutId -> InAlt -> SimplCont
two_or_more -> simplify_default (map DataAlt gadt_imposs ++ imposs_cons)
| otherwise
= simplify_default imposs_cons
where
cant_match tys data_con = not (dataConCanMatch data_con tys)
simplify_default imposs_cons
= do { let env' = mk_rhs_env env case_bndr' (mkOtherCon imposs_cons)
-- Record the constructors that the case-binder *can't* be.
; rhs' <- simplExprC env' rhs cont
; return [(DEFAULT, [], rhs')] }
mkDataConAlt :: Id -> DataCon -> [OutType] -> InExpr -> SimplM InAlt
-- Make a data-constructor alternative to replace the DEFAULT case
-- NB: there's something a bit bogus here, because we put OutTypes into an InAlt
mkDataConAlt case_bndr con tys rhs
= do { tick (FillInCaseDefault case_bndr)
; args <- mk_args con tys
; return (DataAlt con, args, rhs) }
where
mk_args con inst_tys
= do { (tv_bndrs, inst_tys') <- mk_tv_bndrs con inst_tys
; let arg_tys = dataConInstArgTys con inst_tys'
; arg_ids <- mapM (newId FSLIT("a")) arg_tys
; returnSmpl (tv_bndrs ++ arg_ids) }
mk_tv_bndrs con inst_tys
| isVanillaDataCon con
= return ([], inst_tys)
| otherwise
= do { tv_uniqs <- getUniquesSmpl
; let new_tvs = zipWith mk tv_uniqs (dataConTyVars con)
mk uniq tv = mkTyVar (mkSysTvName uniq FSLIT("t")) (tyVarKind tv)
; return (new_tvs, mkTyVarTys new_tvs) }
simplAlt :: SimplEnv
-> [AltCon] -- These constructors can't be present when
-- matching this alternative
-> OutId -- The case binder
-> SimplCont
-> InAlt
-> SimplM (Maybe (TvSubstEnv, OutAlt))
-- Simplify an alternative, returning the type refinement for the
-- alternative, if the alternative does any refinement at all
-- Nothing => the alternative is inaccessible
simplAlt env handled_cons case_bndr' (DEFAULT, bndrs, rhs) cont'
simplAlt env imposs_cons case_bndr' cont' (con, bndrs, rhs)
| con `elem` imposs_cons -- This case can't match
= return Nothing
simplAlt env handled_cons case_bndr' cont' (DEFAULT, bndrs, rhs)
-- TURGID DUPLICATION, needed only for the simplAlt call
-- in mkDupableAlt. Clean this up when moving to FC
= ASSERT( null bndrs )
simplExprC env' rhs cont' `thenSmpl` \ rhs' ->
returnSmpl (Just (emptyVarEnv, (DEFAULT, [], rhs')))
......@@ -1459,14 +1605,14 @@ simplAlt env handled_cons case_bndr' (DEFAULT, bndrs, rhs) cont'
env' = mk_rhs_env env case_bndr' (mkOtherCon handled_cons)
-- Record the constructors that the case-binder *can't* be.
simplAlt env handled_cons case_bndr' (LitAlt lit, bndrs, rhs) cont'
simplAlt env handled_cons case_bndr' cont' (LitAlt lit, bndrs, rhs)
= ASSERT( null bndrs )
simplExprC env' rhs cont' `thenSmpl` \ rhs' ->
returnSmpl (Just (emptyVarEnv, (LitAlt lit, [], rhs')))
where
env' = mk_rhs_env env case_bndr' (mkUnfolding False (Lit lit))
simplAlt env handled_cons case_bndr' (DataAlt con, vs, rhs) cont'
simplAlt env handled_cons case_bndr' cont' (DataAlt con, vs, rhs)
| isVanillaDataCon con
= -- Deal with the pattern-bound variables
-- Mark the ones that are in ! positions in the data constructor
......@@ -1765,7 +1911,7 @@ mkDupableAlts env case_bndr' alts dupable_cont
)}}
mkDupableAlt env case_bndr' cont alt
= simplAlt env [] case_bndr' alt cont `thenSmpl` \ mb_stuff ->
= simplAlt env [] case_bndr' cont alt `thenSmpl` \ mb_stuff ->
case mb_stuff of {
Nothing -> returnSmpl (emptyFloats env, Nothing) ;
......
......@@ -7,7 +7,7 @@ module Unify (
gadtRefineTys, BindFlag(..),
coreRefineTys, TypeRefinement,
coreRefineTys, dataConCanMatch, TypeRefinement,
-- Re-export
MaybeErr(..)
......@@ -23,7 +23,7 @@ import Type ( typeKind, tyVarsOfType, tyVarsOfTypes, tyVarsOfTheta, mkTyVarTys,
TvSubstEnv, emptyTvSubstEnv, TvSubst(..), substTy, tcEqTypeX,
mkOpenTvSubst, tcView )
import TypeRep ( Type(..), PredType(..), funTyCon )
import DataCon ( DataCon, dataConInstResTy )
import DataCon ( DataCon, isVanillaDataCon, dataConResTys, dataConInstResTy )
import Util ( snocView )
import ErrUtils ( Message )
import Outputable
......@@ -221,6 +221,17 @@ tcUnifyTys bind_fn tys1 tys2
tvs1 = tyVarsOfTypes tys1
tvs2 = tyVarsOfTypes tys2
----------------------------
dataConCanMatch :: DataCon -> [Type] -> Bool
-- Returns True iff the data con can match a scrutinee of type (T tys)
-- where T is the type constructor for the data con
dataConCanMatch con tys
| isVanillaDataCon con
= True
| otherwise
= isSuccess $ initUM (\tv -> BindMe) $
unify_tys emptyTvSubstEnv (dataConResTys con) tys
----------------------------
coreRefineTys :: DataCon -> [TyVar] -- Case pattern (con tv1 .. tvn ...)
-> Type -- Type of scrutinee
......
......@@ -8,7 +8,7 @@ module Maybes (
module Maybe, -- Re-export all of Maybe
MaybeErr(..), -- Instance of Monad
failME,
failME, isSuccess,
orElse,
mapCatMaybes,
......@@ -118,6 +118,10 @@ instance Monad (MaybeErr err) where
Succeeded v >>= k = k v
Failed e >>= k = Failed e
isSuccess :: MaybeErr err val -> Bool
isSuccess (Succeeded {}) = True
isSuccess (Failed {}) = False
failME :: err -> MaybeErr err val
failME e = Failed e
\end{code}
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