, 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
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
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
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
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))
emitRODataLits, mkRODataLits,
emitIf, emitIfThenElse,
emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
- assignTemp, newTemp,
+ assignTemp, assignTemp_, newTemp,
emitSimultaneously,
emitSwitch, emitLitSwitch,
tagToClosure,
activeStgRegs, fixStgRegisters,
cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
- cmmUGtWord,
+ cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,
cmmOffsetExprW, cmmOffsetExprB,
cmmRegOffW, cmmRegOffB,
cmmLabelOffW, cmmLabelOffB,
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)
--
-------------------------------------------------------------------------
+-- | 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
; 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) }
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
= 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
= 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
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
-- 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) }
-- 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
-- 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
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
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
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' }
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
= 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]
; 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
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
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)
; (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
; 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)
; 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)
import TcType
import TypeRep
import Type( isTyVarTy )
+import Unify ( tcMatchTys )
import Inst
import InstEnv
import TyCon
-- because they are unconditionally wrong
-- Moreover, if any of the insolubles are givens, stop right there
-- ignoring nested errors, because the code is inaccessible
- = do { let (given, other) = partitionBag (isGiven . evVarX) insols
+ = do { let (given, other) = partitionBag (isGivenOrSolved . evVarX) insols
insol_implics = filterBag ic_insol implics
; if isEmptyBag given
then do { mapBagM_ (reportInsoluble ctxt) other
| otherwise
= pprPanic "reportInsoluble" (pprEvVarWithType ev)
where
- inaccessible_msg | Given loc <- flav
+ inaccessible_msg | Given loc GivenOrig <- flav
+ -- If a GivenSolved then we should not report inaccessible code
= hang (ptext (sLit "Inaccessible code in"))
2 (ppr (ctLocOrigin loc))
| otherwise = empty
couldNotDeduce givens (wanteds, orig)
= vcat [ hang (ptext (sLit "Could not deduce") <+> pprTheta wanteds)
2 (pprArising orig)
- , vcat pp_givens ]
- where
- pp_givens
- = case givens of
+ , vcat (pp_givens givens)]
+
+pp_givens :: [([EvVar], GivenLoc)] -> [SDoc]
+pp_givens givens
+ = case givens of
[] -> []
(g:gs) -> ppr_given (ptext (sLit "from the context")) g
: map (ppr_given (ptext (sLit "or from"))) gs
-
- ppr_given herald (gs,loc)
- = hang (herald <+> pprEvVarTheta gs)
- 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc)
- , ptext (sLit "at") <+> ppr (ctLocSpan loc)])
+ where ppr_given herald (gs,loc)
+ = hang (herald <+> pprEvVarTheta gs)
+ 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc)
+ , ptext (sLit "at") <+> ppr (ctLocSpan loc)])
addExtraInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt
-- Add on extra info about the types themselves
<+> pprPredTy pred)
, sep [ptext (sLit "Matching instances") <> colon,
nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
+
+ , if not (null overlapping_givens) then
+ sep [ptext (sLit "Matching givens (or their superclasses)") <> colon, nest 2 (vcat overlapping_givens)]
+ else empty
+
+ , if null overlapping_givens && isSingleton matches && null unifiers then
+ -- Intuitively, some given matched the wanted in their flattened or rewritten (from given equalities)
+ -- form but the matcher can't figure that out because the constraints are non-flat and non-rewritten
+ -- so we simply report back the whole given context. Accelerate Smart.hs showed this problem.
+ sep [ptext (sLit "There exists a (perhaps superclass) match") <> colon, nest 2 (vcat (pp_givens givens))]
+ else empty
+
, if not (isSingleton matches)
then -- Two or more matches
empty
else -- One match, plus some unifiers
ASSERT( not (null unifiers) )
parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
- quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
- ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
- ptext (sLit "when compiling the other instance declarations")])]
+ quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
+ if null (overlapping_givens) then
+ vcat [ ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
+ ptext (sLit "when compiling the other instance declarations")]
+ else empty])]
where
ispecs = [ispec | (ispec, _) <- matches]
+ givens = getUserGivens ctxt
+ overlapping_givens = unifiable_givens givens
+
+ unifiable_givens [] = []
+ unifiable_givens (gg:ggs)
+ | Just ggdoc <- matchable gg
+ = ggdoc : unifiable_givens ggs
+ | otherwise
+ = unifiable_givens ggs
+
+ matchable (evvars,gloc)
+ = case ev_vars_matching of
+ [] -> Nothing
+ _ -> Just $ hang (pprTheta ev_vars_matching)
+ 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin gloc)
+ , ptext (sLit "at") <+> ppr (ctLocSpan gloc)])
+ where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
+ ev_var_matches (ClassP clas' tys')
+ | clas' == clas
+ , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys'
+ = True
+ ev_var_matches (ClassP clas' tys') =
+ any ev_var_matches (immSuperClasses clas' tys')
+ ev_var_matches _ = False
+
+
reportOverlap _ _ _ _ = panic "reportOverlap" -- Not a ClassP
----------------------
\begin{code}
setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
-setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing
-setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
-setCtFlavorLoc (Given loc) thing = setCtLoc loc thing
+setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing
+setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
+setCtFlavorLoc (Given loc _gk) thing = setCtLoc loc thing
\end{code}
%************************************************************************
addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
do { -- Instantiate the instance decl with skolem constants
; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id)
+ -- We instantiate the dfun_id with superSkolems.
+ -- See Note [Subtle interaction of recursion and overlap]
+ -- and Note [Binding when looking up instances]
; let (clas, inst_tys) = tcSplitDFunHead inst_head
(class_tyvars, sc_theta, _, op_items) = classBigSig clas
sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta
listToBag meth_binds)
}
where
- skol_info = InstSkol -- See Note [Subtle interaction of recursion and overlap]
+ skol_info = InstSkol
dfun_ty = idType dfun_id
dfun_id = instanceDFunId ispec
loc = getSrcSpan dfun_id
import TcCanonical
import VarSet
import Type
+import Unify
import Id
import Var
import Outputable
import TcRnTypes
+import TcMType ( isSilentEvVar )
import TcErrors
import TcSMonad
import Bag
will be marked as solved right before being pushed into the inert set.
See note [Touchables and givens].
- 8 No Given constraint mentions a touchable unification variable,
- except if the
+ 8 No Given constraint mentions a touchable unification variable, but
+ Given/Solved may do so.
+
+ 9 Given constraints will also have their superclasses in the inert set,
+ but Given/Solved will not.
Note that 6 and 7 are /not/ enforced by canonicalization but rather by
insertion in the inert list, ie by TcInteract.
, inert_funeqs = solved_funeqs }
in (is_solved, unsolved)
- where (unsolved_eqs, solved_eqs) = Bag.partitionBag (not.isGivenCt) eqs
+ where (unsolved_eqs, solved_eqs) = Bag.partitionBag (not.isGivenOrSolvedCt) eqs
(unsolved_ips, solved_ips) = extractUnsolvedCMap (inert_ips is)
(unsolved_dicts, solved_dicts) = extractUnsolvedCMap (inert_dicts is)
(unsolved_funeqs, solved_funeqs) = extractUnsolvedCMap (inert_funeqs is)
map mk_given evs
; return inert_ret }
where
- flav = Given gloc
+ flav = Given gloc GivenOrig
mk_given ev = mkEvVarX ev flav
solveInteractWanted :: InertSet -> [WantedEvVar] -> TcS InertSet
, sr_stop = ContinueWith workItem }
SPSolved workItem'
- | not (isGivenCt workItem)
+ | not (isGivenOrSolvedCt workItem)
-- Original was wanted or derived but we have now made him
-- given so we have to interact him with the inerts due to
-- its status change. This in turn may produce more work.
-- See Note [Touchables and givens]
trySpontaneousSolve :: WorkItem -> TcS SPSolveResult
trySpontaneousSolve workItem@(CTyEqCan { cc_id = cv, cc_flavor = gw, cc_tyvar = tv1, cc_rhs = xi })
- | isGiven gw
+ | isGivenOrSolved gw
= return SPCantSolve
| Just tv2 <- tcGetTyVar_maybe xi
= do { tch1 <- isTouchableMetaTyVar tv1
; when (isWanted wd) (setCoBind cv refl_xi)
-- We don't want to do this for Derived, that's why we use 'when (isWanted wd)'
-
; return $ SPSolved (CTyEqCan { cc_id = cv_given
- , cc_flavor = mkGivenFlavor wd UnkSkol
+ , cc_flavor = mkSolvedFlavor wd UnkSkol
, cc_tyvar = tv, cc_rhs = xi }) }
\end{code}
| cls1 == cls2 && eqTypes tys1 tys2
= solveOneFromTheOther "Cls/Cls" (EvId d1,fl1) workItem
- | cls1 == cls2 && (not (isGiven fl1 && isGiven fl2))
+ | cls1 == cls2 && (not (isGivenOrSolved fl1 && isGivenOrSolved fl2))
= -- See Note [When improvement happens]
do { let pty1 = ClassP cls1 tys1
pty2 = ClassP cls2 tys2
-- so we just generate a fresh coercion variable that isn't used anywhere.
doInteractWithInert (CIPCan { cc_id = id1, cc_flavor = ifl, cc_ip_nm = nm1, cc_ip_ty = ty1 })
workItem@(CIPCan { cc_flavor = wfl, cc_ip_nm = nm2, cc_ip_ty = ty2 })
- | nm1 == nm2 && isGiven wfl && isGiven ifl
+ | nm1 == nm2 && isGivenOrSolved wfl && isGivenOrSolved ifl
= -- See Note [Overriding implicit parameters]
-- Dump the inert item, override totally with the new one
-- Do not require type equality
, cc_tyargs = args1, cc_rhs = xi1 })
workItem@(CFunEqCan { cc_id = cv2, cc_flavor = fl2, cc_fun = tc2
, cc_tyargs = args2, cc_rhs = xi2 })
+ | tc1 == tc2 && and (zipWith eqType args1 args2)
+ , Just GivenSolved <- isGiven_maybe fl1
+ = mkIRContinue "Funeq/Funeq" workItem DropInert emptyWorkList
+ | tc1 == tc2 && and (zipWith eqType args1 args2)
+ , Just GivenSolved <- isGiven_maybe fl2
+ = mkIRStopK "Funeq/Funeq" emptyWorkList
+
| fl1 `canSolve` fl2 && lhss_match
= do { cans <- rewriteEqLHS LeftComesFromInert (mkCoVarCo cv1,xi1) (cv2,fl2,xi2)
; mkIRStopK "FunEq/FunEq" cans }
-- so it's safe to continue on from this point
= mkIRContinue ("Solved[DI] " ++ info) workItem DropInert emptyWorkList
+ | Just GivenSolved <- isGiven_maybe ifl, isGivenOrSolved wfl
+ -- Same if the inert is a GivenSolved -- just get rid of it
+ = mkIRContinue ("Solved[SI] " ++ info) workItem DropInert emptyWorkList
+
| otherwise
= ASSERT( ifl `canSolve` wfl )
-- Because of Note [The Solver Invariant], plus Derived dealt with
-- only reacted with functional dependencies
-- arising from top-level instances.
-topReactionsStage :: SimplifierStage
-topReactionsStage depth workItem inerts
- = do { tir <- tryTopReact workItem
- ; case tir of
- NoTopInt ->
- return $ SR { sr_inerts = inerts
- , sr_new_work = emptyWorkList
- , sr_stop = ContinueWith workItem }
- SomeTopInt tir_new_work tir_new_inert ->
+topReactionsStage :: SimplifierStage
+topReactionsStage depth workItem inerts
+ = do { tir <- tryTopReact inerts workItem
+ -- NB: we pass the inerts as well. See Note [Instance and Given overlap]
+ ; case tir of
+ NoTopInt ->
+ return $ SR { sr_inerts = inerts
+ , sr_new_work = emptyWorkList
+ , sr_stop = ContinueWith workItem }
+ SomeTopInt tir_new_work tir_new_inert ->
do { bumpStepCountTcS
; traceFireTcS depth (ptext (sLit "Top react")
<+> vcat [ ptext (sLit "Work =") <+> ppr workItem
, ptext (sLit "New =") <+> ppr tir_new_work ])
- ; return $ SR { sr_inerts = inerts
+ ; return $ SR { sr_inerts = inerts
, sr_new_work = tir_new_work
, sr_stop = tir_new_inert
} }
}
-tryTopReact :: WorkItem -> TcS TopInteractResult
-tryTopReact workitem
+tryTopReact :: InertSet -> WorkItem -> TcS TopInteractResult
+tryTopReact inerts workitem
= do { -- A flag controls the amount of interaction allowed
-- See Note [Simplifying RULE lhs constraints]
ctxt <- getTcSContext
; if allowedTopReaction (simplEqsOnly ctxt) workitem
then do { traceTcS "tryTopReact / calling doTopReact" (ppr workitem)
- ; doTopReact workitem }
+ ; doTopReact inerts workitem }
else return NoTopInt
}
allowedTopReaction eqs_only (CDictCan {}) = not eqs_only
allowedTopReaction _ _ = True
-doTopReact :: WorkItem -> TcS TopInteractResult
+doTopReact :: InertSet -> WorkItem -> TcS TopInteractResult
-- The work item does not react with the inert set, so try interaction with top-level instances
-- NB: The place to add superclasses in *not* in doTopReact stage. Instead superclasses are
-- added in the worklist as part of the canonicalisation process.
-- Given dictionary
-- See Note [Given constraint that matches an instance declaration]
-doTopReact (CDictCan { cc_flavor = Given {} })
+doTopReact _inerts (CDictCan { cc_flavor = Given {} })
= return NoTopInt -- NB: Superclasses already added since it's canonical
-- Derived dictionary: just look for functional dependencies
-doTopReact workItem@(CDictCan { cc_flavor = fl@(Derived loc)
- , cc_class = cls, cc_tyargs = xis })
+doTopReact _inerts workItem@(CDictCan { cc_flavor = fl@(Derived loc)
+ , cc_class = cls, cc_tyargs = xis })
= do { instEnvs <- getInstEnvs
; let fd_eqns = improveFromInstEnv instEnvs
(ClassP cls xis, pprArisingAt loc)
, tir_new_inert = ContinueWith workItem' } }
-- Wanted dictionary
-doTopReact workItem@(CDictCan { cc_id = dv, cc_flavor = fl@(Wanted loc)
- , cc_class = cls, cc_tyargs = xis })
+doTopReact inerts workItem@(CDictCan { cc_id = dv, cc_flavor = fl@(Wanted loc)
+ , cc_class = cls, cc_tyargs = xis })
= do { -- See Note [MATCHING-SYNONYMS]
- ; lkp_inst_res <- matchClassInst cls xis loc
+ ; lkp_inst_res <- matchClassInst inerts cls xis loc
; case lkp_inst_res of
NoInstance ->
do { traceTcS "doTopReact/ no class instance for" (ppr dv)
-- matches already so we won't get any more info
-- from functional dependencies
| null wtvs
- -> do { traceTcS "doTopReact/ found nullary class instance for" (ppr dv)
+ -> do { traceTcS "doTopReact/found nullary class instance for" (ppr dv)
; setDictBind dv ev_term
-- Solved in one step and no new wanted work produced.
-- i.e we directly matched a top-level instance
, tir_new_inert = Stop } }
| otherwise
- -> do { traceTcS "doTopReact/ found nullary class instance for" (ppr dv)
+ -> do { traceTcS "doTopReact/found non-nullary class instance for" (ppr dv)
; setDictBind dv ev_term
-- Solved and new wanted work produced, you may cache the
- -- (tentatively solved) dictionary as Given! (used to be: Derived)
- ; let solved = workItem { cc_flavor = given_fl }
- given_fl = Given (setCtLocOrigin loc UnkSkol)
+ -- (tentatively solved) dictionary as Solved given.
+ ; let solved = workItem { cc_flavor = solved_fl }
+ solved_fl = mkSolvedFlavor fl UnkSkol
; inst_work <- canWanteds wtvs
; return $ SomeTopInt { tir_new_work = inst_work
, tir_new_inert = ContinueWith solved } }
}
-- Type functions
-doTopReact (CFunEqCan { cc_id = cv, cc_flavor = fl
- , cc_fun = tc, cc_tyargs = args, cc_rhs = xi })
+doTopReact _inerts (CFunEqCan { cc_flavor = fl })
+ | Just GivenSolved <- isGiven_maybe fl
+ = return NoTopInt -- If Solved, no more interactions should happen
+
+-- Otherwise, it's a Given, Derived, or Wanted
+doTopReact _inerts workItem@(CFunEqCan { cc_id = cv, cc_flavor = fl
+ , cc_fun = tc, cc_tyargs = args, cc_rhs = xi })
= ASSERT (isSynFamilyTyCon tc) -- No associated data families have reached that far
do { match_res <- matchFam tc args -- See Note [MATCHING-SYNONYMS]
; case match_res of
- MatchInstNo
- -> return NoTopInt
+ MatchInstNo -> return NoTopInt
MatchInstSingle (rep_tc, rep_tys)
-> do { let Just coe_tc = tyConFamilyCoercion_maybe rep_tc
Just rhs_ty = tcView (mkTyConApp rep_tc rep_tys)
-- RHS of a type function, so that it never
-- appears in an error message
-- See Note [Type synonym families] in TyCon
- coe = mkAxInstCo coe_tc rep_tys
- ; cv' <- case fl of
- Wanted {} -> do { cv' <- newCoVar rhs_ty xi
- ; setCoBind cv $
- coe `mkTransCo`
- mkCoVarCo cv'
- ; return cv' }
- Given {} -> newGivenCoVar xi rhs_ty $
- mkSymCo (mkCoVarCo cv) `mkTransCo` coe
- Derived {} -> newDerivedId (EqPred xi rhs_ty)
- ; can_cts <- mkCanonical fl cv'
- ; return $ SomeTopInt can_cts Stop }
+ coe = mkAxInstCo coe_tc rep_tys
+ ; case fl of
+ Wanted {} -> do { cv' <- newCoVar rhs_ty xi
+ ; setCoBind cv $ coe `mkTransCo` mkCoVarCo cv'
+ ; can_cts <- mkCanonical fl cv'
+ ; let solved = workItem { cc_flavor = solved_fl }
+ solved_fl = mkSolvedFlavor fl UnkSkol
+ ; if isEmptyWorkList can_cts then
+ return (SomeTopInt can_cts Stop) -- No point in caching
+ else return $
+ SomeTopInt { tir_new_work = can_cts
+ , tir_new_inert = ContinueWith solved }
+ }
+ Given {} -> do { cv' <- newGivenCoVar xi rhs_ty $
+ mkSymCo (mkCoVarCo cv) `mkTransCo` coe
+ ; can_cts <- mkCanonical fl cv'
+ ; return $
+ SomeTopInt { tir_new_work = can_cts
+ , tir_new_inert = Stop }
+ }
+ Derived {} -> do { cv' <- newDerivedId (EqPred xi rhs_ty)
+ ; can_cts <- mkCanonical fl cv'
+ ; return $
+ SomeTopInt { tir_new_work = can_cts
+ , tir_new_inert = Stop }
+ }
+ }
_
-> panicTcS $ text "TcSMonad.matchFam returned multiple instances!"
}
-- Any other work item does not react with any top-level equations
-doTopReact _workItem = return NoTopInt
+doTopReact _inerts _workItem = return NoTopInt
\end{code}
= NoInstance
| GenInst [WantedEvVar] EvTerm
-matchClassInst :: Class -> [Type] -> WantedLoc -> TcS LookupInstResult
-matchClassInst clas tys loc
+matchClassInst :: InertSet -> Class -> [Type] -> WantedLoc -> TcS LookupInstResult
+matchClassInst inerts clas tys loc
= do { let pred = mkClassPred clas tys
; mb_result <- matchClass clas tys
+ ; untch <- getUntouchables
; case mb_result of
MatchInstNo -> return NoInstance
- MatchInstMany -> return NoInstance -- defer any reactions of a multitude until
+ MatchInstMany -> return NoInstance -- defer any reactions of a multitude until
-- we learn more about the reagent
- MatchInstSingle (dfun_id, mb_inst_tys) ->
+ MatchInstSingle (_,_)
+ | given_overlap untch ->
+ do { traceTcS "Delaying instance application" $
+ vcat [ text "Workitem=" <+> pprPredTy (ClassP clas tys)
+ , text "Silents and their superclasses=" <+> ppr silents_and_their_scs
+ , text "All given dictionaries=" <+> ppr all_given_dicts ]
+ ; return NoInstance -- see Note [Instance and Given overlap]
+ }
+
+ MatchInstSingle (dfun_id, mb_inst_tys) ->
do { checkWellStagedDFun pred dfun_id loc
-- It's possible that not all the tyvars are in
-- (presumably there's a functional dependency in class C)
-- Hence mb_inst_tys :: Either TyVar TcType
- ; tys <- instDFunTypes mb_inst_tys
+ ; tys <- instDFunTypes mb_inst_tys
; let (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
; if null theta then
return (GenInst [] (EvDFunApp dfun_id tys []))
; return $ GenInst wevs (EvDFunApp dfun_id tys ev_vars) }
}
}
+ where given_overlap :: TcsUntouchables -> Bool
+ given_overlap untch
+ = foldlBag (\r d -> r || matchable untch d) False all_given_dicts
+
+ matchable untch (CDictCan { cc_class = clas', cc_tyargs = sys, cc_flavor = fl })
+ | Just GivenOrig <- isGiven_maybe fl
+ , clas' == clas
+ , does_not_originate_in_a_silent clas' sys
+ = case tcUnifyTys (\tv -> if isTouchableMetaTyVar_InRange untch tv &&
+ tv `elemVarSet` tyVarsOfTypes tys
+ then BindMe else Skolem) tys sys of
+ -- We can't learn anything more about any variable at this point, so the only
+ -- cause of overlap can be by an instantiation of a touchable unification
+ -- variable. Hence we only bind touchable unification variables. In addition,
+ -- we use tcUnifyTys instead of tcMatchTys to rule out cyclic substitutions.
+ Nothing -> False
+ Just _ -> True
+ | otherwise = False -- No overlap with a solved, already been taken care of
+ -- by the overlap check with the instance environment.
+ matchable _tys ct = pprPanic "Expecting dictionary!" (ppr ct)
+
+ does_not_originate_in_a_silent clas sys
+ -- UGLY: See Note [Silent parameters overlapping]
+ = null $ filter (eqPred (ClassP clas sys)) silents_and_their_scs
+
+ silents_and_their_scs
+ = foldlBag (\acc rvnt -> case rvnt of
+ CDictCan { cc_id = d, cc_class = c, cc_tyargs = s }
+ | isSilentEvVar d -> (ClassP c s) : (transSuperClasses c s) ++ acc
+ _ -> acc) [] all_given_dicts
+
+ -- TODO:
+ -- When silent parameters will go away we should simply select from
+ -- the given map of the inert set.
+ all_given_dicts = Map.fold unionBags emptyCCan (cts_given $ inert_dicts inerts)
+
\end{code}
+
+Note [Silent parameters overlapping]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+DV 12/05/2011:
+The long-term goal is to completely remove silent superclass
+parameters when checking instance declarations. But until then we must
+make sure that we never prevent the application of an instance
+declaration because of a potential match from a silent parameter --
+after all we are supposed to have solved that silent parameter from
+some instance, anyway! In effect silent parameters behave more like
+Solved than like Given.
+
+A concrete example appears in typecheck/SilentParametersOverlapping.hs
+
+Note [Instance and Given overlap]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Assume that we have an inert set that looks as follows:
+ [Given] D [Int]
+And an instance declaration:
+ instance C a => D [a]
+A new wanted comes along of the form:
+ [Wanted] D [alpha]
+
+One possibility is to apply the instance declaration which will leave us
+with an unsolvable goal (C alpha). However, later on a new constraint may
+arise (for instance due to a functional dependency between two later dictionaries),
+that will add the equality (alpha ~ Int), in which case our ([Wanted] D [alpha])
+will be transformed to [Wanted] D [Int], which could have been discharged by the given.
+
+The solution is that in matchClassInst and eventually in topReact, we get back with
+a matching instance, only when there is no Given in the inerts which is unifiable to
+this particular dictionary.
+
+The end effect is that, much as we do for overlapping instances, we delay choosing a
+class instance if there is a possibility of another instance OR a given to match our
+constraint later on. This fixes bugs #4981 and #5002.
+
+This is arguably not easy to appear in practice due to our aggressive prioritization
+of equality solving over other constraints, but it is possible. I've added a test case
+in typecheck/should-compile/GivenOverlapping.hs
+
+Moreover notice that our goals here are different than the goals of the top-level
+overlapping checks. There we are interested in validating the following principle:
+
+ If we inline a function f at a site where the same global instance environment
+ is available as the instance environment at the definition site of f then we
+ should get the same behaviour.
+
+But for the Given Overlap check our goal is just related to completeness of
+constraint solving.
+
+
+
+
zonkWantedEvVar (EvVarX v l) = do { v' <- zonkEvVar v; return (EvVarX v' l) }
zonkFlavor :: CtFlavor -> TcM CtFlavor
-zonkFlavor (Given loc) = do { loc' <- zonkGivenLoc loc; return (Given loc') }
-zonkFlavor fl = return fl
+zonkFlavor (Given loc gk) = do { loc' <- zonkGivenLoc loc; return (Given loc' gk) }
+zonkFlavor fl = return fl
zonkGivenLoc :: GivenLoc -> TcM GivenLoc
-- GivenLocs may have unification variables inside them!
Implication(..),
CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin,
CtOrigin(..), EqOrigin(..),
- WantedLoc, GivenLoc, pushErrCtxt,
+ WantedLoc, GivenLoc, GivenKind(..), pushErrCtxt,
SkolemInfo(..),
- CtFlavor(..), pprFlavorArising, isWanted, isGiven, isDerived,
+ CtFlavor(..), pprFlavorArising, isWanted,
+ isGivenOrSolved, isGiven_maybe,
+ isDerived,
FlavoredEvVar,
-- Pretty printing
\begin{code}
data CtFlavor
- = Given GivenLoc -- We have evidence for this constraint in TcEvBinds
- | Derived WantedLoc
- -- We have evidence for this constraint in TcEvBinds;
- -- *however* this evidence can contain wanteds, so
- -- it's valid only provisionally to the solution of
- -- these wanteds
- | Wanted WantedLoc -- We have no evidence bindings for this constraint.
-
--- data DerivedOrig = DerSC | DerInst | DerSelf
--- Deriveds are either superclasses of other wanteds or deriveds, or partially
--- solved wanteds from instances, or 'self' dictionaries containing yet wanted
--- superclasses.
+ = Given GivenLoc GivenKind -- We have evidence for this constraint in TcEvBinds
+ | Derived WantedLoc -- Derived's are just hints for unifications
+ | Wanted WantedLoc -- We have no evidence bindings for this constraint.
+
+data GivenKind
+ = GivenOrig -- Originates in some given, such as signature or pattern match
+ | GivenSolved -- Is given as result of being solved, maybe provisionally on
+ -- some other wanted constraints.
instance Outputable CtFlavor where
- ppr (Given {}) = ptext (sLit "[G]")
- ppr (Wanted {}) = ptext (sLit "[W]")
- ppr (Derived {}) = ptext (sLit "[D]")
+ ppr (Given _ GivenOrig) = ptext (sLit "[G]")
+ ppr (Given _ GivenSolved) = ptext (sLit "[S]") -- Print [S] for Given/Solved's
+ ppr (Wanted {}) = ptext (sLit "[W]")
+ ppr (Derived {}) = ptext (sLit "[D]")
+
pprFlavorArising :: CtFlavor -> SDoc
-pprFlavorArising (Derived wl ) = pprArisingAt wl
+pprFlavorArising (Derived wl) = pprArisingAt wl
pprFlavorArising (Wanted wl) = pprArisingAt wl
-pprFlavorArising (Given gl) = pprArisingAt gl
+pprFlavorArising (Given gl _) = pprArisingAt gl
isWanted :: CtFlavor -> Bool
isWanted (Wanted {}) = True
isWanted _ = False
-isGiven :: CtFlavor -> Bool
-isGiven (Given {}) = True
-isGiven _ = False
+isGivenOrSolved :: CtFlavor -> Bool
+isGivenOrSolved (Given {}) = True
+isGivenOrSolved _ = False
+
+isGiven_maybe :: CtFlavor -> Maybe GivenKind
+isGiven_maybe (Given _ gk) = Just gk
+isGiven_maybe _ = Nothing
isDerived :: CtFlavor -> Bool
isDerived (Derived {}) = True
CanonicalCt(..), Xi, tyVarsOfCanonical, tyVarsOfCanonicals, tyVarsOfCDicts,
deCanonicalise, mkFrozenError,
- isWanted, isGiven, isDerived,
- isGivenCt, isWantedCt, isDerivedCt, pprFlavorArising,
+ isWanted, isGivenOrSolved, isDerived,
+ isGivenOrSolvedCt, isGivenCt_maybe,
+ isWantedCt, isDerivedCt, pprFlavorArising,
isFlexiTcsTv,
canRewrite, canSolve,
- combineCtLoc, mkGivenFlavor, mkWantedFlavor,
+ combineCtLoc, mkSolvedFlavor, mkGivenFlavor,
+ mkWantedFlavor,
getWantedLoc,
TcS, runTcS, failTcS, panicTcS, traceTcS, -- Basic functionality
setWantedTyBind,
+ lookupFlatCacheMap, updateFlatCacheMap,
+
getInstEnvs, getFamInstEnvs, -- Getting the environments
getTopEnv, getGblEnv, getTcEvBinds, getUntouchables,
getTcEvBindsBag, getTcSContext, getTcSTyBinds, getTcSTyBindsMap,
import Id
import TcRnTypes
import Data.IORef
+
+import qualified Data.Map as Map
+
#ifdef DEBUG
import StaticFlags( opt_PprStyle_Debug )
import Control.Monad( when )
isWantedCt :: CanonicalCt -> Bool
isWantedCt ct = isWanted (cc_flavor ct)
-isGivenCt :: CanonicalCt -> Bool
-isGivenCt ct = isGiven (cc_flavor ct)
isDerivedCt :: CanonicalCt -> Bool
isDerivedCt ct = isDerived (cc_flavor ct)
+isGivenCt_maybe :: CanonicalCt -> Maybe GivenKind
+isGivenCt_maybe ct = isGiven_maybe (cc_flavor ct)
+
+isGivenOrSolvedCt :: CanonicalCt -> Bool
+isGivenOrSolvedCt ct = isGivenOrSolved (cc_flavor ct)
+
+
canSolve :: CtFlavor -> CtFlavor -> Bool
-- canSolve ctid1 ctid2
-- The constraint ctid1 can be used to solve ctid2
combineCtLoc :: CtFlavor -> CtFlavor -> WantedLoc
-- Precondition: At least one of them should be wanted
-combineCtLoc (Wanted loc) _ = loc
-combineCtLoc _ (Wanted loc) = loc
-combineCtLoc (Derived loc ) _ = loc
-combineCtLoc _ (Derived loc ) = loc
+combineCtLoc (Wanted loc) _ = loc
+combineCtLoc _ (Wanted loc) = loc
+combineCtLoc (Derived loc ) _ = loc
+combineCtLoc _ (Derived loc ) = loc
combineCtLoc _ _ = panic "combineCtLoc: both given"
-mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
-mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk)
-mkGivenFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk)
-mkGivenFlavor (Given loc) sk = Given (setCtLocOrigin loc sk)
+mkSolvedFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
+-- To be called when we actually solve a wanted/derived (perhaps leaving residual goals)
+mkSolvedFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk) GivenSolved
+mkSolvedFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk) GivenSolved
+mkSolvedFlavor fl@(Given {}) _sk = pprPanic "Solving a given constraint!" $ ppr fl
+mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
+mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk) GivenOrig
+mkGivenFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk) GivenOrig
+mkGivenFlavor fl@(Given {}) _sk = pprPanic "Solving a given constraint!" $ ppr fl
mkWantedFlavor :: CtFlavor -> CtFlavor
mkWantedFlavor (Wanted loc) = Wanted loc
mkWantedFlavor (Derived loc) = Wanted loc
-mkWantedFlavor fl@(Given {}) = pprPanic "mkWantedFlavour" (ppr fl)
+mkWantedFlavor fl@(Given {}) = pprPanic "mkWantedFlavor" (ppr fl)
\end{code}
%************************************************************************
tcs_untch :: TcsUntouchables,
- tcs_ic_depth :: Int, -- Implication nesting depth
- tcs_count :: IORef Int -- Global step count
+ tcs_ic_depth :: Int, -- Implication nesting depth
+ tcs_count :: IORef Int, -- Global step count
+
+ tcs_flat_map :: IORef FlatCache
}
+data FlatCache
+ = FlatCache { givenFlatCache :: Map.Map FunEqHead (TcType,Coercion,CtFlavor)
+ -- Invariant: all CtFlavors here satisfy isGiven
+ , wantedFlatCache :: Map.Map FunEqHead (TcType,Coercion,CtFlavor) }
+ -- Invariant: all CtFlavors here satisfy isWanted
+
+emptyFlatCache :: FlatCache
+emptyFlatCache
+ = FlatCache { givenFlatCache = Map.empty, wantedFlatCache = Map.empty }
+
+newtype FunEqHead = FunEqHead (TyCon,[Xi])
+
+instance Eq FunEqHead where
+ FunEqHead (tc1,xis1) == FunEqHead (tc2,xis2) = tc1 == tc2 && eqTypes xis1 xis2
+
+instance Ord FunEqHead where
+ FunEqHead (tc1,xis1) `compare` FunEqHead (tc2,xis2)
+ = case compare tc1 tc2 of
+ EQ -> cmpTypes xis1 xis2
+ other -> other
+
type TcsUntouchables = (Untouchables,TcTyVarSet)
-- Like the TcM Untouchables,
-- but records extra TcsTv variables generated during simplification
= do { ty_binds_var <- TcM.newTcRef emptyVarEnv
; ev_binds_var@(EvBindsVar evb_ref _) <- TcM.newTcEvBinds
; step_count <- TcM.newTcRef 0
+ ; flat_cache_var <- TcM.newTcRef emptyFlatCache
; let env = TcSEnv { tcs_ev_binds = ev_binds_var
, tcs_ty_binds = ty_binds_var
, tcs_context = context
, tcs_untch = (untouch, emptyVarSet) -- No Tcs untouchables yet
, tcs_count = step_count
, tcs_ic_depth = 0
+ , tcs_flat_map = flat_cache_var
}
-- Run the computation
, tcs_untch = (_outer_range, outer_tcs)
, tcs_count = count
, tcs_ic_depth = idepth
- , tcs_context = ctxt } ->
- let
- inner_untch = (inner_range, outer_tcs `unionVarSet` inner_tcs)
+ , tcs_context = ctxt
+ , tcs_flat_map = orig_flat_cache_var
+ } ->
+ do { let inner_untch = (inner_range, outer_tcs `unionVarSet` inner_tcs)
-- The inner_range should be narrower than the outer one
-- (thus increasing the set of untouchables) but
-- the inner Tcs-untouchables must be unioned with the
-- outer ones!
- nest_env = TcSEnv { tcs_ev_binds = ref
- , tcs_ty_binds = ty_binds
- , tcs_untch = inner_untch
- , tcs_count = count
- , tcs_ic_depth = idepth+1
- , tcs_context = ctxtUnderImplic ctxt }
- in
- thing_inside nest_env
+
+ ; orig_flat_cache <- TcM.readTcRef orig_flat_cache_var
+ ; flat_cache_var <- TcM.newTcRef orig_flat_cache
+ -- One could be more conservative as well:
+ -- ; flat_cache_var <- TcM.newTcRef emptyFlatCache
+
+ -- Consider copying the results the tcs_flat_map of the
+ -- incomping constraint, but we must make sure that we
+ -- have pushed everything in, which seems somewhat fragile
+ ; let nest_env = TcSEnv { tcs_ev_binds = ref
+ , tcs_ty_binds = ty_binds
+ , tcs_untch = inner_untch
+ , tcs_count = count
+ , tcs_ic_depth = idepth+1
+ , tcs_context = ctxtUnderImplic ctxt
+ , tcs_flat_map = flat_cache_var }
+ ; thing_inside nest_env }
recoverTcS :: TcS a -> TcS a -> TcS a
recoverTcS (TcS recovery_code) (TcS thing_inside)
ctxtUnderImplic ctxt = ctxt
tryTcS :: TcS a -> TcS a
--- Like runTcS, but from within the TcS monad
+-- Like runTcS, but from within the TcS monad
-- Ignore all the evidence generated, and do not affect caller's evidence!
-tryTcS tcs
+tryTcS tcs
= TcS (\env -> do { ty_binds_var <- TcM.newTcRef emptyVarEnv
; ev_binds_var <- TcM.newTcEvBinds
+ ; flat_cache_var <- TcM.newTcRef emptyFlatCache
; let env1 = env { tcs_ev_binds = ev_binds_var
- , tcs_ty_binds = ty_binds_var }
- ; unTcS tcs env1 })
+ , tcs_ty_binds = ty_binds_var
+ , tcs_flat_map = flat_cache_var }
+ ; unTcS tcs env1 })
-- Update TcEvBinds
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
getTcSTyBindsMap :: TcS (TyVarEnv (TcTyVar, TcType))
getTcSTyBindsMap = getTcSTyBinds >>= wrapTcS . (TcM.readTcRef)
+getFlatCacheMapVar :: TcS (IORef FlatCache)
+getFlatCacheMapVar
+ = TcS (return . tcs_flat_map)
+
+lookupFlatCacheMap :: TyCon -> [Xi] -> CtFlavor
+ -> TcS (Maybe (TcType,Coercion,CtFlavor))
+-- For givens, we lookup in given flat cache
+lookupFlatCacheMap tc xis (Given {})
+ = do { cache_ref <- getFlatCacheMapVar
+ ; cache_map <- wrapTcS $ TcM.readTcRef cache_ref
+ ; return $ Map.lookup (FunEqHead (tc,xis)) (givenFlatCache cache_map) }
+-- For wanteds, we first lookup in givenFlatCache.
+-- If we get nothing back then we lookup in wantedFlatCache.
+lookupFlatCacheMap tc xis (Wanted {})
+ = do { cache_ref <- getFlatCacheMapVar
+ ; cache_map <- wrapTcS $ TcM.readTcRef cache_ref
+ ; case Map.lookup (FunEqHead (tc,xis)) (givenFlatCache cache_map) of
+ Nothing -> return $ Map.lookup (FunEqHead (tc,xis)) (wantedFlatCache cache_map)
+ other -> return other }
+lookupFlatCacheMap _tc _xis (Derived {}) = return Nothing
+
+updateFlatCacheMap :: TyCon -> [Xi]
+ -> TcType -> CtFlavor -> Coercion -> TcS ()
+updateFlatCacheMap _tc _xis _tv (Derived {}) _co
+ = return () -- Not caching deriveds
+updateFlatCacheMap tc xis ty fl co
+ = do { cache_ref <- getFlatCacheMapVar
+ ; cache_map <- wrapTcS $ TcM.readTcRef cache_ref
+ ; let new_cache_map
+ | isGivenOrSolved fl
+ = cache_map { givenFlatCache = Map.insert (FunEqHead (tc,xis)) (ty,co,fl) $
+ givenFlatCache cache_map }
+ | isWanted fl
+ = cache_map { wantedFlatCache = Map.insert (FunEqHead (tc,xis)) (ty,co,fl) $
+ wantedFlatCache cache_map }
+ | otherwise = pprPanic "updateFlatCacheMap, met Derived!" $ empty
+ ; wrapTcS $ TcM.writeTcRef cache_ref new_cache_map }
+
getTcEvBindsBag :: TcS EvBindMap
getTcEvBindsBag
= do { EvBindsVar ev_ref _ <- getTcEvBinds
; wrapTcS $ TcM.readTcRef ev_ref }
+
setCoBind :: CoVar -> Coercion -> TcS ()
setCoBind cv co = setEvBind cv (EvCoercion co)
unsolved_implics
}
-givensFromWanteds :: CanonicalCts -> Bag FlavoredEvVar
--- Extract the *wanted* ones from CanonicalCts
--- and make them into *givens*
-givensFromWanteds = foldrBag getWanted emptyBag
+givensFromWanteds :: SimplContext -> CanonicalCts -> Bag FlavoredEvVar
+-- Extract the Wanted ones from CanonicalCts and conver to
+-- Givens; not Given/Solved, see Note [Preparing inert set for implications]
+givensFromWanteds _ctxt = foldrBag getWanted emptyBag
where
getWanted :: CanonicalCt -> Bag FlavoredEvVar -> Bag FlavoredEvVar
getWanted cc givens
- | not (isCFrozenErr cc)
- , Wanted loc <- cc_flavor cc
- , let given = mkEvVarX (cc_id cc) (Given (setCtLocOrigin loc UnkSkol))
- = given `consBag` givens
- | otherwise
- = givens -- We are not helping anyone by pushing a Derived in!
- -- Because if we could not solve it to start with
- -- we are not going to do either inside the impl constraint
-
+ | pushable_wanted cc
+ = let given = mkEvVarX (cc_id cc) (mkGivenFlavor (cc_flavor cc) UnkSkol)
+ in given `consBag` givens -- and not mkSolvedFlavor,
+ -- see Note [Preparing inert set for implications]
+ | otherwise = givens
+
+ pushable_wanted :: CanonicalCt -> Bool
+ pushable_wanted cc
+ | not (isCFrozenErr cc)
+ , isWantedCt cc
+ = isEqPred (evVarPred (cc_id cc)) -- see Note [Preparing inert set for implications]
+ | otherwise = False
+
solveNestedImplications :: InertSet -> CanonicalCts
-> Bag Implication
-> TcS (Bag FlavoredEvVar, Bag Implication)
| otherwise
= do { -- See Note [Preparing inert set for implications]
-- Push the unsolved wanteds inwards, but as givens
- let pushed_givens = givensFromWanteds unsolved_cans
+
+ ; simpl_ctx <- getTcSContext
+
+ ; let pushed_givens = givensFromWanteds simpl_ctx unsolved_cans
tcs_untouchables = filterVarSet isFlexiTcsTv $
tyVarsOfEvVarXs pushed_givens
-- See Note [Extra TcsTv untouchables]
; traceTcS "solveWanteds: preparing inerts for implications {"
(vcat [ppr tcs_untouchables, ppr pushed_givens])
-
- ; (_, inert_for_implics) <- solveInteract just_given_inert pushed_givens
+
+ ; (_, inert_for_implics) <- solveInteract just_given_inert pushed_givens
; traceTcS "solveWanteds: } now doing nested implications {" $
vcat [ text "inerts_for_implics =" <+> ppr inert_for_implics
given because the resulting set is not inert. Hence we have to do a
'solveInteract' step first.
+Finally, note that we convert them to [Given] and NOT [Given/Solved].
+The reason is that Given/Solved are weaker than Givens and may be discarded.
+As an example consider the inference case, where we may have, the following
+original constraints:
+ [Wanted] F Int ~ Int
+ (F Int ~ a => F Int ~ a)
+If we convert F Int ~ Int to [Given/Solved] instead of Given, then the next
+given (F Int ~ a) is going to cause the Given/Solved to be ignored, casting
+the (F Int ~ a) insoluble. Hence we should really convert the residual
+wanteds to plain old Given.
+
+We need only push in unsolved equalities both in checking mode and inference mode:
+
+ (1) In checking mode we should not push given dictionaries in because of
+example LongWayOverlapping.hs, where we might get strange overlap
+errors between far-away constraints in the program. But even in
+checking mode, we must still push type family equations. Consider:
+
+ type instance F True a b = a
+ type instance F False a b = b
+
+ [w] F c a b ~ gamma
+ (c ~ True) => a ~ gamma
+ (c ~ False) => b ~ gamma
+
+Since solveCTyFunEqs happens at the very end of solving, the only way to solve
+the two implications is temporarily consider (F c a b ~ gamma) as Given (NB: not
+merely Given/Solved because it has to interact with the top-level instance
+environment) and push it inside the implications. Now, when we come out again at
+the end, having solved the implications solveCTyFunEqs will solve this equality.
+
+ (2) In inference mode, we recheck the final constraint in checking mode and
+hence we will be able to solve inner implications from top-level quantified
+constraints nonetheless.
+
+
Note [Extra TcsTv untouchables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Furthemore, we record the inert set simplifier-generated unification
, not (tv `elemVarSet` niSubstTvSet tv_subst (tyVarsOfTypes xis))
-- Occurs check: see Note [Solving Family Equations], Point 2
- = ASSERT ( not (isGiven fl) )
+ = ASSERT ( not (isGivenOrSolved fl) )
(cts_in, extendFunEqBinds feb cv tv (mkTyConApp tc xis))
dflt_funeq (cts_in, fun_eq_binds) ct
</para>
<para>
- In GHC version 6.12 building shared libraries is supported for Linux on
- x86 and x86-64 architectures and there is partial support on Windows (see
- <xref linkend="win32-dlls"/>). The crucial difference in support on
- Windows is that it is not currently possible to build each Haskell
- package as a separate DLL, it is only possible to link an entire Haskell
- program as one massive DLL.
+ In GHC version 6.12 building shared libraries is supported for Linux (on
+ x86 and x86-64 architectures). GHC version 7.0 adds support on Windows
+ (see <xref linkend="win32-dlls"/>), FreeBSD and OpenBSD (x86 and x86-64),
+ Solaris (x86) and Mac OS X (x86 and PowerPC).
</para>
<para>
that it can be linked against shared library versions of Haskell
packages (such as base). The second is when linking, to link against
the shared versions of the packages' libraries rather than the static
- versions. Obviously this requires that the packages were build with
+ versions. Obviously this requires that the packages were built with
shared libraries. On supported platforms GHC comes with shared
libraries for all the core packages, but if you install extra packages
(e.g. with Cabal) then they would also have to be built with shared
In particular Haskell shared libraries <emphasis>must</emphasis> be
made into packages. You cannot freely assign which modules go in which
shared libraries. The Haskell shared libraries must match the package
- boundaries. Most of the conventions GHC expects when using packages are
- described in <xref linkend="building-packages"/>.
- </para>
- <para>
+ boundaries. The reason for this is that
GHC handles references to symbols <emphasis>within</emphasis> the same
shared library (or main executable binary) differently from references
to symbols <emphasis>between</emphasis> different shared libraries. GHC
<literal>-dynamic</literal> in the link step. That means to
statically link the rts all the base libraries into your new shared
library. This would make a very big, but standalone shared library.
- Indeed this is exactly what we must currently do on Windows where
- -dynamic is not yet supported (see <xref linkend="win32-dlls"/>).
On most platforms however that would require all the static libraries
to have been built with <literal>-fPIC</literal> so that the code is
suitable to include into a shared library and we do not do that at the
The details of how this works varies between platforms, in particular
the three major systems: Unix ELF platforms, Windows and Mac OS X.
</para>
+ <sect3 id="finding-shared-libs-unix">
+ <title>Unix</title>
<para>
On Unix there are two mechanisms. Shared libraries can be installed
into standard locations that the dynamic linker knows about. For
<para>
GHC has a <literal>-dynload</literal> linking flag to select the method
that is used to find shared libraries at runtime. There are currently
- three modes:
+ two modes:
<variablelist>
<varlistentry>
<term>sysdep</term>
<listitem>
<para>
A system-dependent mode. This is also the default mode. On Unix
- ELF systems this embeds rpaths into the shared library or
- executable. In particular it uses absolute paths to where the
- shared libraries for the rts and each package can be found.
- This means the program can immediately be run and it will be
- able to find the libraries it needs. However it may not be
- suitable for deployment if the libraries are installed in a
- different location on another machine.
+ ELF systems this embeds
+ <literal>RPATH</literal>/<literal>RUNPATH</literal> entries into the
+ shared library or executable. In particular it uses absolute paths to
+ where the shared libraries for the rts and each package can be found.
+ This means the program can immediately be run and it will be able to
+ find the libraries it needs. However it may not be suitable for
+ deployment if the libraries are installed in a different location on
+ another machine.
</para>
</listitem>
</varlistentry>
</varlistentry>
</variablelist>
To use relative paths for dependent libraries on Linux and Solaris you
- can use the <literal>deploy</literal> mode and pass suitable a -rpath
- flag to the linker:
+ can pass a suitable <literal>-rpath</literal> flag to the linker:
<programlisting>
ghc -dynamic Main.hs -o main -lfoo -L. -optl-Wl,-rpath,'$ORIGIN'
</programlisting>
executable e.g. <literal>-optl-Wl,-rpath,'$ORIGIN/lib'</literal>.
</para>
<para>
- The standard assumption on Darwin/MacOS X is that dynamic libraries will
+ This relative path technique can be used with either of the two
+ <literal>-dynload</literal> modes, though it makes most sense with the
+ <literal>deploy</literal> mode. The difference is that with the
+ <literal>deploy</literal> mode, the above example will end up with an ELF
+ <literal>RUNPATH</literal> of just <literal>$ORIGIN</literal> while with
+ the <literal>sysdep</literal> mode the <literal>RUNPATH</literal> will be
+ <literal>$ORIGIN</literal> followed by all the library directories of all
+ the packages that the program depends on (e.g. <literal>base</literal>
+ and <literal>rts</literal> packages etc.) which are typically absolute
+ paths. The unix tool <literal>readelf --dynamic</literal> is handy for
+ inspecting the <literal>RPATH</literal>/<literal>RUNPATH</literal>
+ entries in ELF shared libraries and executables.
+ </para>
+ </sect3>
+ <sect3 id="finding-shared-libs-mac">
+ <title>Mac OS X</title>
+ <para>
+ The standard assumption on Darwin/Mac OS X is that dynamic libraries will
be stamped at build time with an "install name", which is the full
ultimate install path of the library file. Any libraries or executables
that subsequently link against it (even if it hasn't been installed yet)
for you. It automatically sets the install name for dynamic libraries to
the absolute path of the ultimate install location.
</para>
+ </sect3>
</sect2>
</sect1>
</title>
<para>
-<emphasis>Making Haskell libraries into DLLs doesn't work on Windows at the
-moment; we hope to re-instate this facility in the future
-(see <xref linkend="using-shared-libs"/>). Note that
-building an entire Haskell application as a single DLL is still supported: it's
- just multi-DLL Haskell programs that don't work. The Windows
- distribution of GHC contains static libraries only.</emphasis></para>
-
-<!--
-<para>
<indexterm><primary>Dynamic link libraries, Win32</primary></indexterm>
<indexterm><primary>DLLs, Win32</primary></indexterm>
On Win32 platforms, the compiler is capable of both producing and using
</para>
<para>
+There are two distinct ways in which DLLs can be used:
+<itemizedlist>
+ <listitem>
+ <para>
+ You can turn each Haskell package into a DLL, so that multiple
+ Haskell executables using the same packages can share the DLL files.
+ (As opposed to linking the libraries statically, which in effect
+ creates a new copy of the RTS and all libraries for each executable
+ produced.)
+ </para>
+ <para>
+ That is the same as the dynamic linking on other platforms, and it
+ is described in <xref linkend="using-shared-libs"/>.
+ </para>
+ </listitem>
+ <listitem>
+ <para>
+ You can package up a complete Haskell program as a DLL, to be called
+ by some external (usually non-Haskell) program. This is usually used
+ to implement plugins and the like, and is described below.
+ </para>
+ </listitem>
+</itemizedlist>
+</para>
+
+<!--
+<para>
Until recently, <command>strip</command> didn't work reliably on DLLs, so you
should test your version with care, or make sure you have the latest
binutils. Unfortunately, we don't know exactly which version of binutils
#define StgFunInfoExtra_bitmap(i) StgFunInfoExtraFwd_bitmap(i)
#endif
-#define mutArrPtrsCardWords(n) \
- ROUNDUP_BYTES_TO_WDS(((n) + (1 << MUT_ARR_PTRS_CARD_BITS) - 1) >> MUT_ARR_PTRS_CARD_BITS)
+#define mutArrCardMask ((1 << MUT_ARR_PTRS_CARD_BITS) - 1)
+#define mutArrPtrCardDown(i) ((i) >> MUT_ARR_PTRS_CARD_BITS)
+#define mutArrPtrCardUp(i) (((i) + mutArrCardMask) >> MUT_ARR_PTRS_CARD_BITS)
+#define mutArrPtrsCardWords(n) ROUNDUP_BYTES_TO_WDS(mutArrPtrCardUp(n))
#if defined(PROFILING) || (!defined(THREADED_RTS) && defined(DEBUG))
#define OVERWRITING_CLOSURE(c) foreign "C" overwritingClosure(c "ptr")
#define EVENT_GC_END 10 /* () */
#define EVENT_REQUEST_SEQ_GC 11 /* () */
#define EVENT_REQUEST_PAR_GC 12 /* () */
+/* 13, 14 deprecated */
#define EVENT_CREATE_SPARK_THREAD 15 /* (spark_thread) */
#define EVENT_LOG_MSG 16 /* (message ...) */
#define EVENT_STARTUP 17 /* (num_capabilities) */
#define EVENT_GC_IDLE 20 /* () */
#define EVENT_GC_WORK 21 /* () */
#define EVENT_GC_DONE 22 /* () */
+/* 23, 24 used by eden */
+#define EVENT_CAPSET_CREATE 25 /* (capset, capset_type) */
+#define EVENT_CAPSET_DELETE 26 /* (capset) */
+#define EVENT_CAPSET_ASSIGN_CAP 27 /* (capset, cap) */
+#define EVENT_CAPSET_REMOVE_CAP 28 /* (capset, cap) */
+/* the RTS identifier is in the form of "GHC-version rts_way" */
+#define EVENT_RTS_IDENTIFIER 29 /* (capset, name_version_string) */
+/* the vectors in these events are null separated strings */
+#define EVENT_PROGRAM_ARGS 30 /* (capset, commandline_vector) */
+#define EVENT_PROGRAM_ENV 31 /* (capset, environment_vector) */
+#define EVENT_OSPROCESS_PID 32 /* (capset, pid, parent_pid) */
-#define NUM_EVENT_TAGS 23
+
+/* Range 33 - 59 is available for new events */
+
+/* Range 60 - 80 is used by eden for parallel tracing
+ * see http://www.mathematik.uni-marburg.de/~eden/
+ */
+
+/*
+ * The highest event code +1 that ghc itself emits. Note that some event
+ * ranges higher than this are reserved but not currently emitted by ghc.
+ * This must match the size of the EventDesc[] array in EventLog.c
+ */
+#define NUM_EVENT_TAGS 33
#if 0 /* DEPRECATED EVENTS: */
+/* ghc changed how it handles sparks so these are no longer applicable */
#define EVENT_CREATE_SPARK 13 /* (cap, thread) */
#define EVENT_SPARK_TO_THREAD 14 /* (cap, thread, spark_thread) */
+/* these are used by eden but are replaced by new alternatives for ghc */
+#define EVENT_VERSION 23 /* (version_string) */
+#define EVENT_PROGRAM_INVOCATION 24 /* (commandline_string) */
#endif
/*
*/
#define THREAD_SUSPENDED_FOREIGN_CALL 6
+/*
+ * Capset type values for EVENT_CAPSET_CREATE
+ */
+#define CAPSET_TYPE_CUSTOM 1 /* reserved for end-user applications */
+#define CAPSET_TYPE_OSPROCESS 2 /* caps belong to the same OS process */
+#define CAPSET_TYPE_CLOCKDOMAIN 3 /* caps share a local clock/time */
+
#ifndef EVENTLOG_CONSTANTS_ONLY
typedef StgWord16 EventTypeNum;
typedef StgWord16 EventCapNo;
typedef StgWord16 EventPayloadSize; /* variable-size events */
typedef StgWord16 EventThreadStatus; /* status for EVENT_STOP_THREAD */
+typedef StgWord32 EventCapsetID;
+typedef StgWord16 EventCapsetType; /* types for EVENT_CAPSET_CREATE */
#endif
cap->transaction_tokens = 0;
cap->context_switch = 0;
cap->pinned_object_block = NULL;
+
+ traceCapsetAssignCap(CAPSET_OSPROCESS_DEFAULT, i);
}
/* ---------------------------------------------------------------------------
void
initCapabilities( void )
{
+
#if defined(THREADED_RTS)
nat i;
#else
freeCapability(&MainCapability);
#endif
+ traceCapsetDelete(CAPSET_OSPROCESS_DEFAULT);
}
/* ---------------------------------------------------------------------------
}
}
+
/* -----------------------------------------------------------------------------
MutVar primitives
-------------------------------------------------------------------------- */
* typedef uint16_t EventCapNo;
* typedef uint16_t EventPayloadSize; // variable-size events
* typedef uint16_t EventThreadStatus;
+ * typedef uint32_t EventCapsetID;
+ * typedef uint16_t EventCapsetType; // types for EVENT_CAPSET_CREATE
*/
/* -----------------------------------------------------------------------------
probe gc__idle (EventCapNo);
probe gc__work (EventCapNo);
probe gc__done (EventCapNo);
+ probe capset__create(EventCapsetID, EventCapsetType);
+ probe capset__delete(EventCapsetID);
+ probe capset__assign__cap(EventCapsetID, EventCapNo);
+ probe capset__remove__cap(EventCapsetID, EventCapNo);
};
*/
dtraceEventStartup();
+ /* Trace some basic information about the process
+ */
+ traceCapsetDetails(argc, argv);
+
/* initialise scheduler data structures (needs to be done before
* initStorage()).
*/
}
sched_state = SCHED_SHUTTING_DOWN;
+ nat i;
+
+ for (i = 0; i < n_capabilities; i++) {
#if defined(THREADED_RTS)
- {
- nat i;
-
- for (i = 0; i < n_capabilities; i++) {
- ASSERT(task->incall->tso == NULL);
- shutdownCapability(&capabilities[i], task, wait_foreign);
- }
- }
+ ASSERT(task->incall->tso == NULL);
+ shutdownCapability(&capabilities[i], task, wait_foreign);
#endif
+ traceCapsetRemoveCap(CAPSET_OSPROCESS_DEFAULT, i);
+ }
+ traceCapsetDelete(CAPSET_OSPROCESS_DEFAULT);
boundTaskExiting(task);
}
#include "Threads.h"
#include "Printer.h"
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
#ifdef DEBUG
// debugging flags, set with +RTS -D<something>
int DEBUG_sched;
}
}
+void traceCapsetModify_ (EventTypeNum tag,
+ CapsetID capset,
+ StgWord32 other,
+ StgWord32 other2)
+{
+#ifdef DEBUG
+ if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) {
+ ACQUIRE_LOCK(&trace_utx);
+
+ tracePreface();
+ switch (tag) {
+ case EVENT_CAPSET_CREATE: // (capset, capset_type)
+ debugBelch("created capset %d of type %d\n", capset, other);
+ break;
+ case EVENT_CAPSET_DELETE: // (capset)
+ debugBelch("deleted capset %d\n", capset);
+ break;
+ case EVENT_CAPSET_ASSIGN_CAP: // (capset, capno)
+ debugBelch("assigned cap %d to capset %d\n", other, capset);
+ break;
+ case EVENT_CAPSET_REMOVE_CAP: // (capset, capno)
+ debugBelch("removed cap %d from capset %d\n", other, capset);
+ break;
+ }
+ RELEASE_LOCK(&trace_utx);
+ } else
+#endif
+ {
+ if(eventlog_enabled) postCapsetModifyEvent(tag, capset, other, other2);
+ }
+}
+
+extern char **environ;
+
+void traceCapsetDetails_(int *argc, char **argv[]){
+ if(eventlog_enabled){
+ postCapsetModifyEvent(EVENT_OSPROCESS_PID,
+ CAPSET_OSPROCESS_DEFAULT,
+ getpid(),
+ getppid());
+
+ char buf[256];
+ snprintf(buf, sizeof(buf), "GHC-%s %s", ProjectVersion, RtsWay);
+ postCapsetStrEvent(EVENT_RTS_IDENTIFIER,
+ CAPSET_OSPROCESS_DEFAULT,
+ buf);
+
+ if(argc != NULL && argv != NULL){
+ postCapsetVecEvent(EVENT_PROGRAM_ARGS,
+ CAPSET_OSPROCESS_DEFAULT,
+ *argc,
+ *argv);
+ }
+
+ int env_len;
+ for( env_len = 0; environ[env_len] != NULL; env_len++);
+ postCapsetVecEvent(EVENT_PROGRAM_ENV,
+ CAPSET_OSPROCESS_DEFAULT,
+ env_len,
+ environ);
+ }
+}
+
void traceEvent_ (Capability *cap, EventTypeNum tag)
{
#ifdef DEBUG
#endif /* TRACING */
+typedef StgWord32 CapsetID;
+typedef StgWord16 CapsetType;
+enum CapsetType { CapsetTypeCustom = CAPSET_TYPE_CUSTOM,
+ CapsetTypeOsProcess = CAPSET_TYPE_OSPROCESS,
+ CapsetTypeClockdomain = CAPSET_TYPE_CLOCKDOMAIN };
+#define CAPSET_OSPROCESS_DEFAULT 0
+
// -----------------------------------------------------------------------------
// Message classes
// -----------------------------------------------------------------------------
void traceThreadStatus_ (StgTSO *tso);
+/*
+ * Events for describing capability sets in the eventlog
+ *
+ * Note: unlike other events, these are not conditional on TRACE_sched or
+ * similar because they are not "real" events themselves but provide
+ * information and context for other "real" events. Other events depend on
+ * the capset info events so for simplicity, rather than working out if
+ * they're necessary we always emit them. They should be very low volume.
+ */
+void traceCapsetModify_ (EventTypeNum tag,
+ CapsetID capset,
+ StgWord32 other,
+ StgWord32 other2);
+
+void traceCapsetDetails_ (int *argc, char **argv[]);
#else /* !TRACING */
#define traceSchedEvent(cap, tag, tso, other) /* nothing */
#define debugTrace(class, str, ...) /* nothing */
#define debugTraceCap(class, cap, str, ...) /* nothing */
#define traceThreadStatus(class, tso) /* nothing */
+#define traceCapsetModify_(tag, capset, other, other2) /* nothing */
+#define traceCapsetDetails_(argc, argv) /* nothing */
#endif /* TRACING */
HASKELLEVENT_GC_WORK(cap)
#define dtraceGcDone(cap) \
HASKELLEVENT_GC_DONE(cap)
+#define dtraceCapsetCreate(capset, capset_type) \
+ HASKELLEVENT_CAPSET_CREATE(capset, capset_type)
+#define dtraceCapsetDelete(capset) \
+ HASKELLEVENT_CAPSET_DELETE(capset)
+#define dtraceCapsetAssignCap(capset, capno) \
+ HASKELLEVENT_CAPSET_ASSIGN_CAP(capset, capno)
+#define dtraceCapsetRemoveCap(capset, capno) \
+ HASKELLEVENT_CAPSET_REMOVE_CAP(capset, capno)
#else /* !defined(DTRACE) */
#define dtraceGcIdle(cap) /* nothing */
#define dtraceGcWork(cap) /* nothing */
#define dtraceGcDone(cap) /* nothing */
+#define dtraceCapsetCreate(capset, capset_type) /* nothing */
+#define dtraceCapsetDelete(capset) /* nothing */
+#define dtraceCapsetAssignCap(capset, capno) /* nothing */
+#define dtraceCapsetRemoveCap(capset, capno) /* nothing */
#endif
dtraceGcDone((EventCapNo)cap->no);
}
+INLINE_HEADER void traceCapsetCreate(CapsetID capset STG_UNUSED,
+ CapsetType capset_type STG_UNUSED)
+{
+ traceCapsetModify_(EVENT_CAPSET_CREATE, capset, capset_type, 0);
+ dtraceCapsetCreate(capset, capset_type);
+}
+
+INLINE_HEADER void traceCapsetDelete(CapsetID capset STG_UNUSED)
+{
+ traceCapsetModify_(EVENT_CAPSET_DELETE, capset, 0, 0);
+ dtraceCapsetDelete(capset);
+}
+
+INLINE_HEADER void traceCapsetAssignCap(CapsetID capset STG_UNUSED,
+ nat capno STG_UNUSED)
+{
+ traceCapsetModify_(EVENT_CAPSET_ASSIGN_CAP, capset, capno, 0);
+ dtraceCapsetAssignCap(capset, capno);
+}
+
+INLINE_HEADER void traceCapsetRemoveCap(CapsetID capset STG_UNUSED,
+ nat capno STG_UNUSED)
+{
+ traceCapsetModify_(EVENT_CAPSET_REMOVE_CAP, capset, capno, 0);
+ dtraceCapsetRemoveCap(capset, capno);
+}
+
+INLINE_HEADER void traceCapsetDetails(int *argc STG_UNUSED, char **argv[] STG_UNUSED)
+{
+ traceCapsetCreate(CAPSET_OSPROCESS_DEFAULT, CapsetTypeOsProcess);
+ traceCapsetDetails_(argc, argv);
+}
+
#include "EndPrivate.h"
#endif /* TRACE_H */
[EVENT_GC_IDLE] = "GC idle",
[EVENT_GC_WORK] = "GC working",
[EVENT_GC_DONE] = "GC done",
- [EVENT_BLOCK_MARKER] = "Block marker"
+ [EVENT_BLOCK_MARKER] = "Block marker",
+ [EVENT_CAPSET_CREATE] = "Create capability set",
+ [EVENT_CAPSET_DELETE] = "Delete capability set",
+ [EVENT_CAPSET_ASSIGN_CAP] = "Add capability to capability set",
+ [EVENT_CAPSET_REMOVE_CAP] = "Remove capability from capability set",
+ [EVENT_RTS_IDENTIFIER] = "Identify the RTS version",
+ [EVENT_PROGRAM_ARGS] = "Identify the program arguments",
+ [EVENT_PROGRAM_ENV] = "Identify the environment variables",
+ [EVENT_OSPROCESS_PID] = "Identify the process ID of a capability set"
};
// Event type.
static inline void postCapNo(EventsBuf *eb, EventCapNo no)
{ postWord16(eb,no); }
+static inline void postCapsetID(EventsBuf *eb, EventCapsetID id)
+{ postWord32(eb,id); }
+
+static inline void postCapsetType(EventsBuf *eb, EventCapsetType type)
+{ postWord16(eb,type); }
+
static inline void postPayloadSize(EventsBuf *eb, EventPayloadSize size)
{ postWord16(eb,size); }
eventTypes[t].size = sizeof(EventCapNo);
break;
+ case EVENT_CAPSET_CREATE: // (capset, capset_type)
+ eventTypes[t].size =
+ sizeof(EventCapsetID) + sizeof(EventCapsetType);
+ break;
+
+ case EVENT_CAPSET_DELETE: // (capset)
+ eventTypes[t].size = sizeof(EventCapsetID);
+ break;
+
+ case EVENT_CAPSET_ASSIGN_CAP: // (capset, cap)
+ case EVENT_CAPSET_REMOVE_CAP:
+ eventTypes[t].size =
+ sizeof(EventCapsetID) + sizeof(EventCapNo);
+ break;
+
+ case EVENT_OSPROCESS_PID: // (cap, pid, parent pid)
+ eventTypes[t].size =
+ sizeof(EventCapsetID) + 2*sizeof(StgWord32);
+ break;
+
case EVENT_SHUTDOWN: // (cap)
case EVENT_REQUEST_SEQ_GC: // (cap)
case EVENT_REQUEST_PAR_GC: // (cap)
case EVENT_LOG_MSG: // (msg)
case EVENT_USER_MSG: // (msg)
+ case EVENT_RTS_IDENTIFIER: // (capset, str)
+ case EVENT_PROGRAM_ARGS: // (capset, strvec)
+ case EVENT_PROGRAM_ENV: // (capset, strvec)
eventTypes[t].size = 0xffff;
break;
}
}
+void postCapsetModifyEvent (EventTypeNum tag,
+ EventCapsetID capset,
+ StgWord32 other,
+ StgWord32 other2)
+{
+ ACQUIRE_LOCK(&eventBufMutex);
+
+ if (!hasRoomForEvent(&eventBuf, tag)) {
+ // Flush event buffer to make room for new event.
+ printAndClearEventBuf(&eventBuf);
+ }
+
+ postEventHeader(&eventBuf, tag);
+ postCapsetID(&eventBuf, capset);
+
+ switch (tag) {
+ case EVENT_CAPSET_CREATE: // (capset, capset_type)
+ {
+ postCapsetType(&eventBuf, other /* capset_type */);
+ break;
+ }
+
+ case EVENT_CAPSET_DELETE: // (capset)
+ {
+ break;
+ }
+
+ case EVENT_CAPSET_ASSIGN_CAP: // (capset, capno)
+ case EVENT_CAPSET_REMOVE_CAP: // (capset, capno)
+ {
+ postCapNo(&eventBuf, other /* capno */);
+ break;
+ }
+ case EVENT_OSPROCESS_PID:
+ {
+ postWord32(&eventBuf, other);
+ postWord32(&eventBuf, other2);
+ break;
+ }
+ default:
+ barf("postCapsetModifyEvent: unknown event tag %d", tag);
+ }
+
+ RELEASE_LOCK(&eventBufMutex);
+}
+
+void postCapsetStrEvent (EventTypeNum tag,
+ EventCapsetID capset,
+ char *msg)
+{
+ int strsize = strlen(msg);
+ int size = strsize + sizeof(EventCapsetID)
+
+ ACQUIRE_LOCK(&eventBufMutex);
+
+ if (!hasRoomForVariableEvent(&eventBuf, size)){
+ printAndClearEventBuf(&eventBuf);
+
+ if (!hasRoomForVariableEvent(&eventBuf, size)){
+ // Event size exceeds buffer size, bail out:
+ RELEASE_LOCK(&eventBufMutex);
+ return;
+ }
+ }
+
+ postEventHeader(&eventBuf, tag);
+ postPayloadSize(&eventBuf, size);
+ postCapsetID(&eventBuf, capset);
+
+ postBuf(&eventBuf, (StgWord8*) msg, strsize);
+
+ RELEASE_LOCK(&eventBufMutex);
+}
+
+void postCapsetVecEvent (EventTypeNum tag,
+ EventCapsetID capset,
+ int argc,
+ char *argv[])
+{
+ int i, size = sizeof(EventCapsetID);
+
+ for (i = 0; i < argc; i++) {
+ // 1 + strlen to account for the trailing \0, used as separator
+ size += 1 + strlen(argv[i]);
+ }
+
+ ACQUIRE_LOCK(&eventBufMutex);
+
+ if (!hasRoomForVariableEvent(&eventBuf, size)){
+ printAndClearEventBuf(&eventBuf);
+
+ if(!hasRoomForVariableEvent(&eventBuf, size)){
+ // Event size exceeds buffer size, bail out:
+ RELEASE_LOCK(&eventBufMutex);
+ return;
+ }
+ }
+
+ postEventHeader(&eventBuf, tag);
+ postPayloadSize(&eventBuf, size);
+ postCapsetID(&eventBuf, capset);
+
+ for( i = 0; i < argc; i++ ) {
+ // again, 1 + to account for \0
+ postBuf(&eventBuf, (StgWord8*) argv[i], 1 + strlen(argv[i]));
+ }
+
+ RELEASE_LOCK(&eventBufMutex);
+}
+
void
postEvent (Capability *cap, EventTypeNum tag)
{
StgThreadID id, StgWord info1, StgWord info2);
/*
+ * Post a capability set modification event
+ */
+void postCapsetModifyEvent (EventTypeNum tag,
+ EventCapsetID capset,
+ StgWord32 other,
+ StgWord32 other2);
+
+/*
+ * Post a capability set event with a string payload
+ */
+void postCapsetStrEvent (EventTypeNum tag,
+ EventCapsetID capset,
+ char *msg);
+
+/*
+ * Post a capability set event with several strings payload
+ */
+void postCapsetVecEvent (EventTypeNum tag,
+ EventCapsetID capset,
+ int argc,
+ char *msg[]);
+
+/*
* Post a nullary event.
*/
void postEvent(Capability *cap, EventTypeNum tag);
StgWord info2 STG_UNUSED)
{ /* nothing */ }
+INLINE_HEADER void postCapsetModifyEvent (EventTypeNum tag STG_UNUSED,
+ EventCapsetID capset STG_UNUSED,
+ StgWord32 other STG_UNUSED,
+ StgWord32 other2 STG_UNUSED)
+{ /* nothing */ }
+
INLINE_HEADER void postEvent (Capability *cap STG_UNUSED,
EventTypeNum tag STG_UNUSED)
{ /* nothing */ }
rts/RtsMessages_CC_OPTS += -DProjectVersion=\"$(ProjectVersion)\"
rts/RtsUtils_CC_OPTS += -DProjectVersion=\"$(ProjectVersion)\"
+rts/Trace_CC_OPTS += -DProjectVersion=\"$(ProjectVersion)\"
#
rts/RtsUtils_CC_OPTS += -DHostPlatform=\"$(HOSTPLATFORM)\"
rts/RtsUtils_CC_OPTS += -DHostArch=\"$(HostArch_CPP)\"
my @scm_args = ("log", "$branch_name..");
scm ($localpath, $scm, @scm_args, @args);
}
+ elsif ($command =~ /^log$/) {
+ scm ($localpath, $scm, "log", @args);
+ }
elsif ($command =~ /^remote$/) {
my @scm_args;
if ($subcommand eq 'add') {
* clean
* reset
* config
+ * log
Available package-tags are:
END
projects / ghc-hetmet.git / commitdiff