Commit 7fd71923 authored by dreixel's avatar dreixel
Browse files

Merge branch 'master' of http://darcs.haskell.org/ghc into ghc-generics

Fixed conflicts:
	compiler/typecheck/TcSMonad.lhs
parents 6ad311b7 9c23f06f
......@@ -4,7 +4,7 @@ module CmmExpr
, CmmReg(..), cmmRegType
, CmmLit(..), cmmLitType
, LocalReg(..), localRegType
, GlobalReg(..), globalRegType, spReg, hpReg, spLimReg, nodeReg, node
, GlobalReg(..), globalRegType, spReg, hpReg, spLimReg, nodeReg, node, baseReg
, VGcPtr(..), vgcFlag -- Temporary!
, DefinerOfLocalRegs, UserOfLocalRegs, foldRegsDefd, foldRegsUsed, filterRegsUsed
, DefinerOfSlots, UserOfSlots, foldSlotsDefd, foldSlotsUsed
......@@ -425,7 +425,8 @@ instance Ord GlobalReg where
compare _ EagerBlackholeInfo = GT
-- convenient aliases
spReg, hpReg, spLimReg, nodeReg :: CmmReg
baseReg, spReg, hpReg, spLimReg, nodeReg :: CmmReg
baseReg = CmmGlobal BaseReg
spReg = CmmGlobal Sp
hpReg = CmmGlobal Hp
spLimReg = CmmGlobal SpLim
......
......@@ -10,13 +10,17 @@ module CgPrimOp (
cgPrimOp
) where
import BasicTypes
import ForeignCall
import ClosureInfo
import StgSyn
import CgForeignCall
import CgBindery
import CgMonad
import CgHeapery
import CgInfoTbls
import CgTicky
import CgProf
import CgUtils
import OldCmm
import CLabel
......@@ -205,6 +209,19 @@ emitPrimOp [res] UnsafeFreezeArrayOp [arg] _
emitPrimOp [res] UnsafeFreezeByteArrayOp [arg] _
= stmtC (CmmAssign (CmmLocal res) arg)
emitPrimOp [] CopyArrayOp [src,src_off,dst,dst_off,n] live =
doCopyArrayOp src src_off dst dst_off n live
emitPrimOp [] CopyMutableArrayOp [src,src_off,dst,dst_off,n] live =
doCopyMutableArrayOp src src_off dst dst_off n live
emitPrimOp [res] CloneArrayOp [src,src_off,n] live =
emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n live
emitPrimOp [res] CloneMutableArrayOp [src,src_off,n] live =
emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n live
emitPrimOp [res] FreezeArrayOp [src,src_off,n] live =
emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n live
emitPrimOp [res] ThawArrayOp [src,src_off,n] live =
emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n live
-- Reading/writing pointer arrays
emitPrimOp [r] ReadArrayOp [obj,ix] _ = doReadPtrArrayOp r obj ix
......@@ -618,3 +635,198 @@ cmmLoadIndexOffExpr off rep base idx
setInfo :: CmmExpr -> CmmExpr -> CmmStmt
setInfo closure_ptr info_ptr = CmmStore closure_ptr info_ptr
-- ----------------------------------------------------------------------------
-- Copying pointer arrays
-- | Takes a source 'Array#', an offset in the source array, a
-- destination 'MutableArray#', an offset into the destination array,
-- and the number of elements to copy. Copies the given number of
-- elements from the source array to the destination array.
doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-> StgLiveVars -> Code
doCopyArrayOp = emitCopyArray copy
where
-- Copy data (we assume the arrays aren't overlapping since
-- they're of different types)
copy _src _dst = emitMemcpyCall
-- | Takes a source 'MutableArray#', an offset in the source array, a
-- destination 'MutableArray#', an offset into the destination array,
-- and the number of elements to copy. Copies the given number of
-- elements from the source array to the destination array.
doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-> StgLiveVars -> Code
doCopyMutableArrayOp = emitCopyArray copy
where
-- The only time the memory might overlap is when the two arrays
-- we were provided are the same array!
-- TODO: Optimize branch for common case of no aliasing.
copy src dst dst_p src_p bytes live =
emitIfThenElse (cmmEqWord src dst)
(emitMemmoveCall dst_p src_p bytes live)
(emitMemcpyCall dst_p src_p bytes live)
emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-> StgLiveVars -> Code)
-> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-> StgLiveVars
-> Code
emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 live = do
-- Assign the arguments to temporaries so the code generator can
-- calculate liveness for us.
src <- assignTemp_ src0
src_off <- assignTemp_ src_off0
dst <- assignTemp_ dst0
dst_off <- assignTemp_ dst_off0
n <- assignTemp_ n0
-- Set the dirty bit in the header.
stmtC (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
dst_elems_p <- assignTemp $ cmmOffsetB dst arrPtrsHdrSize
dst_p <- assignTemp $ cmmOffsetExprW dst_elems_p dst_off
src_p <- assignTemp $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize) src_off
bytes <- assignTemp $ cmmMulWord n (CmmLit (mkIntCLit wORD_SIZE))
copy src dst dst_p src_p bytes live
-- The base address of the destination card table
dst_cards_p <- assignTemp $ cmmOffsetExprW dst_elems_p (loadArrPtrsSize dst)
emitSetCards dst_off dst_cards_p n live
-- | Takes an info table label, a register to return the newly
-- allocated array in, a source array, an offset in the source array,
-- and the number of elements to copy. Allocates a new array and
-- initializes it form the source array.
emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> CmmExpr
-> StgLiveVars -> Code
emitCloneArray info_p res_r src0 src_off0 n0 live = do
-- Assign the arguments to temporaries so the code generator can
-- calculate liveness for us.
src <- assignTemp_ src0
src_off <- assignTemp_ src_off0
n <- assignTemp_ n0
card_words <- assignTemp $ (n `cmmUShrWord`
(CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)))
`cmmAddWord` CmmLit (mkIntCLit 1)
size <- assignTemp $ n `cmmAddWord` card_words
words <- assignTemp $ arrPtrsHdrSizeW `cmmAddWord` size
arr_r <- newTemp bWord
emitAllocateCall arr_r myCapability words live
tickyAllocPrim (CmmLit (mkIntCLit arrPtrsHdrSize)) (n `cmmMulWord` wordSize)
(CmmLit $ mkIntCLit 0)
let arr = CmmReg (CmmLocal arr_r)
emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCSAddr
stmtC $ CmmStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE +
oFFSET_StgMutArrPtrs_ptrs)) n
stmtC $ CmmStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE +
oFFSET_StgMutArrPtrs_size)) size
dst_p <- assignTemp $ cmmOffsetB arr arrPtrsHdrSize
src_p <- assignTemp $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize)
src_off
emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize) live
emitMemsetCall (cmmOffsetExprW dst_p n)
(CmmLit (CmmInt (toInteger (1 :: Int)) W8))
(card_words `cmmMulWord` wordSize)
live
stmtC $ CmmAssign (CmmLocal res_r) arr
where
arrPtrsHdrSizeW = CmmLit $ mkIntCLit $ fixedHdrSize +
(sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE)
wordSize = CmmLit (mkIntCLit wORD_SIZE)
myCapability = CmmReg baseReg `cmmSubWord`
CmmLit (mkIntCLit oFFSET_Capability_r)
-- | Takes and offset in the destination array, the base address of
-- the card table, and the number of elements affected (*not* the
-- number of cards). Marks the relevant cards as dirty.
emitSetCards :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code
emitSetCards dst_start dst_cards_start n live = do
start_card <- assignTemp $ card dst_start
emitMemsetCall (dst_cards_start `cmmAddWord` start_card)
(CmmLit (CmmInt (toInteger (1 :: Int)) W8))
((card (dst_start `cmmAddWord` n) `cmmSubWord` start_card)
`cmmAddWord` CmmLit (mkIntCLit 1))
live
where
-- Convert an element index to a card index
card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))
-- | Emit a call to @memcpy@.
emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code
emitMemcpyCall dst src n live = do
vols <- getVolatileRegs live
emitForeignCall' PlayRisky
[{-no results-}]
(CmmCallee memcpy CCallConv)
[ (CmmHinted dst AddrHint)
, (CmmHinted src AddrHint)
, (CmmHinted n NoHint)
]
(Just vols)
NoC_SRT -- No SRT b/c we do PlayRisky
CmmMayReturn
where
memcpy = CmmLit (CmmLabel (mkForeignLabel (fsLit "memcpy") Nothing
ForeignLabelInExternalPackage IsFunction))
-- | Emit a call to @memmove@.
emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code
emitMemmoveCall dst src n live = do
vols <- getVolatileRegs live
emitForeignCall' PlayRisky
[{-no results-}]
(CmmCallee memmove CCallConv)
[ (CmmHinted dst AddrHint)
, (CmmHinted src AddrHint)
, (CmmHinted n NoHint)
]
(Just vols)
NoC_SRT -- No SRT b/c we do PlayRisky
CmmMayReturn
where
memmove = CmmLit (CmmLabel (mkForeignLabel (fsLit "memmove") Nothing
ForeignLabelInExternalPackage IsFunction))
-- | Emit a call to @memset@. The second argument must be of type
-- 'W8'.
emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code
emitMemsetCall dst c n live = do
vols <- getVolatileRegs live
emitForeignCall' PlayRisky
[{-no results-}]
(CmmCallee memset CCallConv)
[ (CmmHinted dst AddrHint)
, (CmmHinted c NoHint)
, (CmmHinted n NoHint)
]
(Just vols)
NoC_SRT -- No SRT b/c we do PlayRisky
CmmMayReturn
where
memset = CmmLit (CmmLabel (mkForeignLabel (fsLit "memset") Nothing
ForeignLabelInExternalPackage IsFunction))
-- | Emit a call to @allocate@.
emitAllocateCall :: LocalReg -> CmmExpr -> CmmExpr -> StgLiveVars -> Code
emitAllocateCall res cap n live = do
vols <- getVolatileRegs live
emitForeignCall' PlayRisky
[CmmHinted res AddrHint]
(CmmCallee allocate CCallConv)
[ (CmmHinted cap AddrHint)
, (CmmHinted n NoHint)
]
(Just vols)
NoC_SRT -- No SRT b/c we do PlayRisky
CmmMayReturn
where
allocate = CmmLit (CmmLabel (mkForeignLabel (fsLit "allocate") Nothing
ForeignLabelInExternalPackage IsFunction))
......@@ -20,7 +20,7 @@ module CgUtils (
emitRODataLits, mkRODataLits,
emitIf, emitIfThenElse,
emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
assignTemp, newTemp,
assignTemp, assignTemp_, newTemp,
emitSimultaneously,
emitSwitch, emitLitSwitch,
tagToClosure,
......@@ -29,7 +29,7 @@ module CgUtils (
activeStgRegs, fixStgRegisters,
cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
cmmUGtWord,
cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,
cmmOffsetExprW, cmmOffsetExprB,
cmmRegOffW, cmmRegOffB,
cmmLabelOffW, cmmLabelOffB,
......@@ -180,8 +180,10 @@ cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2]
cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2]
cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2]
--cmmShlWord e1 e2 = CmmMachOp mo_wordShl [e1, e2]
--cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2]
cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2]
cmmAddWord e1 e2 = CmmMachOp mo_wordAdd [e1, e2]
cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2]
cmmMulWord e1 e2 = CmmMachOp mo_wordMul [e1, e2]
cmmNegate :: CmmExpr -> CmmExpr
cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
......@@ -587,6 +589,9 @@ mkByteStringCLit bytes
--
-------------------------------------------------------------------------
-- | If the expression is trivial, return it. Otherwise, assign the
-- expression to a temporary register and return an expression
-- referring to this register.
assignTemp :: CmmExpr -> FCode CmmExpr
-- For a non-trivial expression, e, create a local
-- variable and assign the expression to it
......@@ -596,6 +601,14 @@ assignTemp e
; stmtC (CmmAssign (CmmLocal reg) e)
; return (CmmReg (CmmLocal reg)) }
-- | Assign the expression to a temporary register and return an
-- expression referring to this register.
assignTemp_ :: CmmExpr -> FCode CmmExpr
assignTemp_ e = do
reg <- newTemp (cmmExprType e)
stmtC (CmmAssign (CmmLocal reg) e)
return (CmmReg (CmmLocal reg))
newTemp :: CmmType -> FCode LocalReg
newTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep) }
......
......@@ -626,6 +626,49 @@ primop UnsafeThawArrayOp "unsafeThawArray#" GenPrimOp
out_of_line = True
has_side_effects = True
primop CopyArrayOp "copyArray#" GenPrimOp
Array# a -> Int# -> MutableArray# s a -> Int# -> Int# -> State# s -> State# s
{Copy a range of the Array# to the specified region in the MutableArray#.
Both arrays must fully contain the specified ranges, but this is not checked.
The two arrays must not be the same array in different states, but this is not checked either.}
with
has_side_effects = True
primop CopyMutableArrayOp "copyMutableArray#" GenPrimOp
MutableArray# s a -> Int# -> MutableArray# s a -> Int# -> Int# -> State# s -> State# s
{Copy a range of the first MutableArray# to the specified region in the second MutableArray#.
Both arrays must fully contain the specified ranges, but this is not checked.}
with
has_side_effects = True
primop CloneArrayOp "cloneArray#" GenPrimOp
Array# a -> Int# -> Int# -> Array# a
{Return a newly allocated Array# with the specified subrange of the provided Array#.
The provided Array# should contain the full subrange specified by the two Int#s, but this is not checked.}
with
has_side_effects = True
primop CloneMutableArrayOp "cloneMutableArray#" GenPrimOp
MutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a #)
{Return a newly allocated Array# with the specified subrange of the provided Array#.
The provided MutableArray# should contain the full subrange specified by the two Int#s, but this is not checked.}
with
has_side_effects = True
primop FreezeArrayOp "freezeArray#" GenPrimOp
MutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, Array# a #)
{Return a newly allocated Array# with the specified subrange of the provided MutableArray#.
The provided MutableArray# should contain the full subrange specified by the two Int#s, but this is not checked.}
with
has_side_effects = True
primop ThawArrayOp "thawArray#" GenPrimOp
Array# a -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a #)
{Return a newly allocated Array# with the specified subrange of the provided MutableArray#.
The provided Array# should contain the full subrange specified by the two Int#s, but this is not checked.}
with
has_side_effects = True
------------------------------------------------------------------------
section "Byte Arrays"
{Operations on {\tt ByteArray\#}. A {\tt ByteArray\#} is a just a region of
......
......@@ -547,7 +547,7 @@ tidyFlavoredEvVar env (EvVarX v fl)
= EvVarX (tidyEvVar env v) (tidyFlavor env fl)
tidyFlavor :: TidyEnv -> CtFlavor -> CtFlavor
tidyFlavor env (Given loc) = Given (tidyGivenLoc env loc)
tidyFlavor env (Given loc gk) = Given (tidyGivenLoc env loc) gk
tidyFlavor _ fl = fl
tidyGivenLoc :: TidyEnv -> GivenLoc -> GivenLoc
......@@ -591,8 +591,8 @@ substFlavoredEvVar subst (EvVarX v fl)
= EvVarX (substEvVar subst v) (substFlavor subst fl)
substFlavor :: TvSubst -> CtFlavor -> CtFlavor
substFlavor subst (Given loc) = Given (substGivenLoc subst loc)
substFlavor _ fl = fl
substFlavor subst (Given loc gk) = Given (substGivenLoc subst loc) gk
substFlavor _ fl = fl
substGivenLoc :: TvSubst -> GivenLoc -> GivenLoc
substGivenLoc subst (CtLoc skol span ctxt) = CtLoc (substSkolemInfo subst skol) span ctxt
......
......@@ -93,7 +93,9 @@ expansions contain any type function applications would speed things
up a bit; right now we waste a lot of energy traversing the same types
multiple times.
\begin{code}
-- Flatten a bunch of types all at once.
flattenMany :: CtFlavor -> [Type] -> TcS ([Xi], [Coercion], CanonicalCts)
-- Coercions :: Xi ~ Type
......@@ -112,7 +114,7 @@ flatten ctxt ty
-- Preserve type synonyms if possible
-- We can tell if ty' is function-free by
-- whether there are any floated constraints
; if isEmptyCCan ccs then
; if isReflCo co then
return (ty, mkReflCo ty, emptyCCan)
else
return (xi, co, ccs) }
......@@ -140,7 +142,7 @@ flatten fl (TyConApp tc tys)
-- Otherwise, it's a type function application, and we have to
-- flatten it away as well, and generate a new given equality constraint
-- between the application and a newly generated flattening skolem variable.
| otherwise
| otherwise
= ASSERT( tyConArity tc <= length tys ) -- Type functions are saturated
do { (xis, cos, ccs) <- flattenMany fl tys
; let (xi_args, xi_rest) = splitAt (tyConArity tc) xis
......@@ -148,37 +150,41 @@ flatten fl (TyConApp tc tys)
-- The type function might be *over* saturated
-- in which case the remaining arguments should
-- be dealt with by AppTys
fam_ty = mkTyConApp tc xi_args
fam_co = mkReflCo fam_ty -- identity
; (ret_co, rhs_var, ct) <-
if isGiven fl then
do { rhs_var <- newFlattenSkolemTy fam_ty
; cv <- newGivenCoVar fam_ty rhs_var fam_co
; let ct = CFunEqCan { cc_id = cv
, cc_flavor = fl -- Given
, cc_fun = tc
, cc_tyargs = xi_args
, cc_rhs = rhs_var }
; return $ (mkCoVarCo cv, rhs_var, ct) }
else -- Derived or Wanted: make a new *unification* flatten variable
do { rhs_var <- newFlexiTcSTy (typeKind fam_ty)
; cv <- newCoVar fam_ty rhs_var
; let ct = CFunEqCan { cc_id = cv
, cc_flavor = mkWantedFlavor fl
-- Always Wanted, not Derived
, cc_fun = tc
, cc_tyargs = xi_args
, cc_rhs = rhs_var }
; return $ (mkCoVarCo cv, rhs_var, ct) }
fam_ty = mkTyConApp tc xi_args
; (ret_co, rhs_var, ct) <-
do { is_cached <- lookupFlatCacheMap tc xi_args fl
; case is_cached of
Just (rhs_var,ret_co,_fl) -> return (ret_co, rhs_var, emptyCCan)
Nothing
| isGivenOrSolved fl ->
do { rhs_var <- newFlattenSkolemTy fam_ty
; cv <- newGivenCoVar fam_ty rhs_var (mkReflCo fam_ty)
; let ct = CFunEqCan { cc_id = cv
, cc_flavor = fl -- Given
, cc_fun = tc
, cc_tyargs = xi_args
, cc_rhs = rhs_var }
; let ret_co = mkCoVarCo cv
; updateFlatCacheMap tc xi_args rhs_var fl ret_co
; return $ (ret_co, rhs_var, singleCCan ct) }
| otherwise ->
-- Derived or Wanted: make a new *unification* flatten variable
do { rhs_var <- newFlexiTcSTy (typeKind fam_ty)
; cv <- newCoVar fam_ty rhs_var
; let ct = CFunEqCan { cc_id = cv
, cc_flavor = mkWantedFlavor fl
-- Always Wanted, not Derived
, cc_fun = tc
, cc_tyargs = xi_args
, cc_rhs = rhs_var }
; let ret_co = mkCoVarCo cv
; updateFlatCacheMap tc xi_args rhs_var fl ret_co
; return $ (ret_co, rhs_var, singleCCan ct) } }
; return ( foldl AppTy rhs_var xi_rest
, foldl mkAppCo
(mkSymCo ret_co
`mkTransCo` mkTyConAppCo tc cos_args)
cos_rest
, ccs `extendCCans` ct) }
, foldl AppCo (mkSymCo ret_co
`mkTransCo` mkTyConAppCo tc cos_args)
cos_rest
, ccs `andCCan` ct) }
flatten ctxt (PredTy pred)
= do { (pred', co, ccs) <- flattenPred ctxt pred
......@@ -223,7 +229,7 @@ canWanteds :: [WantedEvVar] -> TcS WorkList
canWanteds = fmap unionWorkLists . mapM (\(EvVarX ev loc) -> mkCanonical (Wanted loc) ev)
canGivens :: GivenLoc -> [EvVar] -> TcS WorkList
canGivens loc givens = do { ccs <- mapM (mkCanonical (Given loc)) givens
canGivens loc givens = do { ccs <- mapM (mkCanonical (Given loc GivenOrig)) givens
; return (unionWorkLists ccs) }
mkCanonicals :: CtFlavor -> [EvVar] -> TcS WorkList
......@@ -239,6 +245,7 @@ mkCanonicalFEVs = foldrBagM canon_one emptyWorkList
canon_one fev wl = do { wl' <- mkCanonicalFEV fev
; return (unionWorkList wl' wl) }
mkCanonical :: CtFlavor -> EvVar -> TcS WorkList
mkCanonical fl ev = case evVarPred ev of
ClassP clas tys -> canClassToWorkList fl ev clas tys
......@@ -249,15 +256,15 @@ mkCanonical fl ev = case evVarPred ev of
canClassToWorkList :: CtFlavor -> EvVar -> Class -> [TcType] -> TcS WorkList
canClassToWorkList fl v cn tys
= do { (xis,cos,ccs) <- flattenMany fl tys -- cos :: xis ~ tys
; let no_flattening_happened = isEmptyCCan ccs
; let no_flattening_happened = all isReflCo cos
dict_co = mkTyConAppCo (classTyCon cn) cos
; v_new <- if no_flattening_happened then return v
else if isGiven fl then return v
; v_new <- if no_flattening_happened then return v
else if isGivenOrSolved fl then return v
-- The cos are all identities if fl=Given,
-- hence nothing to do
else do { v' <- newDictVar cn xis -- D xis
; when (isWanted fl) $ setDictBind v (EvCast v' dict_co)
; when (isGiven fl) $ setDictBind v' (EvCast v (mkSymCo dict_co))
; when (isGivenOrSolved fl) $ setDictBind v' (EvCast v (mkSymCo dict_co))
-- NB: No more setting evidence for derived now
; return v' }
......@@ -321,7 +328,7 @@ For Deriveds:
Here's an example that demonstrates why we chose to NOT add
superclasses during simplification: [Comes from ticket #4497]
class Num (RealOf t) => Normed t
type family RealOf x
......@@ -347,14 +354,18 @@ newSCWorkFromFlavored ev orig_flavor cls xis
= return emptyWorkList -- Deriveds don't yield more superclasses because we will
-- add them transitively in the case of wanteds.
| isGiven orig_flavor
= do { let sc_theta = immSuperClasses cls xis
flavor = orig_flavor
; sc_vars <- mapM newEvVar sc_theta
; _ <- zipWithM_ setEvBind sc_vars [EvSuperClass ev n | n <- [0..]]
; mkCanonicals flavor sc_vars }
| isEmptyVarSet (tyVarsOfTypes xis)
| Just gk <- isGiven_maybe orig_flavor
= case gk of
GivenOrig -> do { let sc_theta = immSuperClasses cls xis
flavor = orig_flavor
; sc_vars <- mapM newEvVar sc_theta
; _ <- zipWithM_ setEvBind sc_vars [EvSuperClass ev n | n <- [0..]]
; mkCanonicals flavor sc_vars }
GivenSolved -> return emptyWorkList
-- Seems very dangerous to add the superclasses for dictionaries that may be
-- partially solved because we may end up with evidence loops.
| isEmptyVarSet (tyVarsOfTypes xis)
= return emptyWorkList -- Wanteds with no variables yield no deriveds.
-- See Note [Improvement from Ground Wanteds]
......@@ -417,8 +428,7 @@ canEq fl cv (FunTy s1 t1) (FunTy s2 t2)
; setCoBind cv $
mkFunCo (mkCoVarCo argv) (mkCoVarCo resv)
; return (argv,resv) }
else if isGiven fl then
else if isGivenOrSolved fl then
let [arg,res] = decomposeCo 2 (mkCoVarCo cv)
in do { argv <- newGivenCoVar s1 s2 arg
; resv <- newGivenCoVar t1 t2 res
......@@ -452,10 +462,9 @@ canEq fl cv (TyConApp tc1 tys1) (TyConApp tc2 tys2)
do { argsv <- zipWithM newCoVar tys1 tys2
; setCoBind cv $
mkTyConAppCo tc1 (map mkCoVarCo argsv)
; return argsv }
else if isGiven fl then
let cos = decomposeCo (length tys1) (mkCoVarCo cv)
; return argsv }
else if isGivenOrSolved fl then
let cos = decomposeCo (length tys1) (mkCoVarCo cv)
in zipWith3M newGivenCoVar tys1 tys2 cos
else -- Derived
......@@ -691,7 +700,7 @@ canEqLeaf _untch fl cv cls1 cls2
then do { cv' <- newCoVar s2 s1
; setCoBind cv $ mkSymCo (mkCoVarCo cv')
; return cv' }
else if isGiven fl then
else if isGivenOrSolved fl then
newGivenCoVar s2 s1 (mkSymCo (mkCoVarCo cv))
else -- Derived
newDerivedId (EqPred s2 s1)
......@@ -723,9 +732,9 @@ canEqLeafOriented fl cv cls1@(FunCls fn tys1) s2 -- cv : F tys1
; (xi2, co2, ccs2) <- flatten fl s2 -- Flatten entire RHS
-- co2 :: xi2 ~ s2
; let ccs = ccs1 `andCCan` ccs2
no_flattening_happened = isEmptyCCan ccs
; cv_new <- if no_flattening_happened then return cv
else if isGiven fl then return cv
no_flattening_happened = all isReflCo (co2:cos1)
; cv_new <- if no_flattening_happened then return cv
else if isGivenOrSolved fl then return cv
else if isWanted fl then
do { cv' <- newCoVar (unClassify (FunCls fn xis1)) xi2
-- cv' : F xis ~ xi2
......@@ -769,9 +778,9 @@ canEqLeafTyVarLeft fl cv tv s2 -- cv : tv ~ s2
; case mxi2' of {
Nothing -> canEqFailure fl cv ;
Just xi2' ->
do { let no_flattening_happened = isEmptyCCan ccs2
; cv_new <- if no_flattening_happened then return cv
else if isGiven fl then return cv
do { let no_flattening_happened = isReflCo co
; cv_new <- if no_flattening_happened then return cv
else if isGivenOrSolved fl then return cv
else if isWanted fl then
do { cv' <- newCoVar (mkTyVarTy tv) xi2' -- cv' : tv ~ xi2
; setCoBind cv (mkCoVarCo cv' `mkTransCo` co)
......@@ -997,7 +1006,7 @@ instFunDepEqn fl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs
; mapM (do_one subst) eqs }
where
fl' = case fl of
Given _ -> panic "mkFunDepEqns"
Given {} -> panic "mkFunDepEqns"
Wanted loc -> Wanted (push_ctx loc)
Derived loc -> Derived (push_ctx loc)
......