Commit f5e53165 authored by ian@well-typed.com's avatar ian@well-typed.com

Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc

parents 699f8e16 38622200
......@@ -273,7 +273,7 @@ data DataCon
-- dcExTyVars = [x,y]
-- dcEqSpec = [a~(x,y)]
-- dcOtherTheta = [x~y, Ord x]
-- dcOrigArgTys = [a,List b]
-- dcOrigArgTys = [x,y]
-- dcRepTyCon = T
dcVanilla :: Bool, -- True <=> This is a vanilla Haskell 98 data constructor
......
......@@ -1065,6 +1065,12 @@ doReturn exprs_code = do
updfr_off <- getUpdFrameOff
emit (mkReturnSimple dflags exprs updfr_off)
mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkReturnSimple dflags actuals updfr_off =
mkReturn dflags e actuals updfr_off
where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off)
(gcWord dflags))
doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()
doRawJump expr_code vols = do
dflags <- getDynFlags
......
......@@ -12,7 +12,7 @@ module MkGraph
, mkJump, mkJumpExtra, mkDirectJump, mkForeignJump, mkForeignJumpExtra
, mkRawJump
, mkCbranch, mkSwitch
, mkReturn, mkReturnSimple, mkComment, mkCallEntry, mkBranch
, mkReturn, mkComment, mkCallEntry, mkBranch
, copyInOflow, copyOutOflow
, noExtraStack
, toCall, Transfer(..)
......@@ -23,7 +23,6 @@ import BlockId
import Cmm
import CmmCallConv
import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..))
import DynFlags
import FastString
......@@ -241,11 +240,6 @@ mkReturn dflags e actuals updfr_off =
lastWithArgs dflags Ret Old NativeReturn actuals updfr_off $
toCall e Nothing updfr_off 0
mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkReturnSimple dflags actuals updfr_off =
mkReturn dflags e actuals updfr_off
where e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags)
mkBranch :: BlockId -> CmmAGraph
mkBranch bid = mkLast (CmmBranch bid)
......
......@@ -306,6 +306,11 @@ loadThreadState dflags tso stack = do
-- SpLim = stack->stack + RESERVED_STACK_WORDS;
mkAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags))
(rESERVED_STACK_WORDS dflags)),
-- HpAlloc = 0;
-- HpAlloc is assumed to be set to non-zero only by a failed
-- a heap check, see HeapStackCheck.cmm:GC_GENERIC
mkAssign hpAlloc (zeroExpr dflags),
openNursery dflags,
-- and load the current cost centre stack from the TSO when profiling:
if gopt Opt_SccProfilingOn dflags then
......@@ -367,13 +372,14 @@ stgHp = CmmReg hp
stgCurrentTSO = CmmReg currentTSO
stgCurrentNursery = CmmReg currentNursery
sp, spLim, hp, hpLim, currentTSO, currentNursery :: CmmReg
sp, spLim, hp, hpLim, currentTSO, currentNursery, hpAlloc :: CmmReg
sp = CmmGlobal Sp
spLim = CmmGlobal SpLim
hp = CmmGlobal Hp
hpLim = CmmGlobal HpLim
currentTSO = CmmGlobal CurrentTSO
currentNursery = CmmGlobal CurrentNursery
hpAlloc = CmmGlobal HpAlloc
-- -----------------------------------------------------------------------------
-- For certain types passed to foreign calls, we adjust the actual
......
......@@ -749,7 +749,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
-- In such case, we return a best approximation:
-- ignore the unpointed args, and recover the pointeds
-- This preserves laziness, and should be safe.
traceTR (text "Nothing" <+> ppr dcname)
traceTR (text "Not constructor" <+> ppr dcname)
let dflags = hsc_dflags hsc_env
tag = showPpr dflags dcname
vars <- replicateM (length$ elems$ ptrs clos)
......@@ -758,7 +758,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
| (i, tv) <- zip [0..] vars]
return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
Just dc -> do
traceTR (text "Just" <+> ppr dc)
traceTR (text "Is constructor" <+> (ppr dc $$ ppr my_ty))
subTtypes <- getDataConArgTys dc my_ty
subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) clos subTtypes
return (Term my_ty (Right dc) a subTerms)
......@@ -939,14 +939,16 @@ getDataConArgTys :: DataCon -> Type -> TR [Type]
-- not be fully known. Moreover, the arg types might involve existentials;
-- if so, make up fresh RTTI type variables for them
getDataConArgTys dc con_app_ty
= do { (_, ex_tys, _) <- instTyVars ex_tvs
= do { (_, ex_tys, ex_subst) <- instTyVars ex_tvs
; let UnaryRep rep_con_app_ty = repType con_app_ty
; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty))
; ty_args <- case tcSplitTyConApp_maybe rep_con_app_ty of
Just (tc, ty_args) | dataConTyCon dc == tc
-> ASSERT( univ_tvs `equalLength` ty_args)
return ty_args
_ -> do { (_, ty_args, subst) <- instTyVars univ_tvs
; let res_ty = substTy subst (dataConOrigResTy dc)
_ -> do { (_, ty_args, univ_subst) <- instTyVars univ_tvs
; let res_ty = substTy ex_subst (substTy univ_subst (dataConOrigResTy dc))
-- See Note [Constructor arg types]
; addConstraint rep_con_app_ty res_ty
; return ty_args }
-- It is necessary to check dataConTyCon dc == tc
......@@ -954,11 +956,38 @@ getDataConArgTys dc con_app_ty
-- newtype and tcSplitTyConApp has not removed it. In
-- that case, we happily give up and don't match
; let subst = zipTopTvSubst (univ_tvs ++ ex_tvs) (ty_args ++ ex_tys)
; traceTR (text "getDataConArgTys 2" <+> (ppr rep_con_app_ty $$ ppr ty_args $$ ppr subst))
; return (substTys subst (dataConRepArgTys dc)) }
where
univ_tvs = dataConUnivTyVars dc
ex_tvs = dataConExTyVars dc
{- Note [Constructor arg types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider a GADT (cf Trac #7386)
data family D a b
data instance D [a] b where
MkT :: b -> D [a] (Maybe b)
In getDataConArgTys
* con_app_ty is the known type (from outside) of the constructor application,
say D [Int] Bool
* The data constructor MkT has a (representation) dataConTyCon = DList,
say where
data DList a b where
MkT :: b -> DList a (Maybe b)
So the dataConTyCon of the data constructor, DList, differs from
the "outside" type, D. So we can't straightforwardly decompose the
"outside" type, and we end up in the "_" branch of the case.
Then we match the dataConOrigResTy of the data constructor against the
outside type, hoping to get a substitution that tells how to instantiate
the *representation* type constructor. This looks a bit delicate to
me, but it seems to work.
-}
-- Soundness checks
--------------------
{-
......
......@@ -335,13 +335,17 @@ kickOutRewritable new_flav new_tv
-- constraints that mention type variables whose
-- kinds could contain this variable!
kick_out_eq inert_ct = kick_out_ct inert_ct &&
not (ctFlavour inert_ct `canRewrite` new_flav)
-- If also the inert can rewrite the subst then there is no danger of
-- occurs check errors sor keep it there. No need to rewrite the inert equality
-- (as we did in the past) because of point (8) of
-- See Note [Detailed InertCans Invariants]
-- and Note [Delicate equality kick-out]
kick_out_eq (CTyEqCan { cc_tyvar = tv, cc_rhs = rhs, cc_ev = ev })
= (new_flav `canRewrite` inert_flav) -- See Note [Delicate equality kick-out]
&& (new_tv `elemVarSet` kind_vars || -- (1)
(not (inert_flav `canRewrite` new_flav) && -- (2)
new_tv `elemVarSet` (extendVarSet (tyVarsOfType rhs) tv)))
where
inert_flav = ctEvFlavour ev
kind_vars = tyVarsOfType (tyVarKind tv) `unionVarSet`
tyVarsOfType (typeKind rhs)
kick_out_eq other_ct = pprPanic "kick_out_eq" (ppr other_ct)
\end{code}
Note [Kick out insolubles]
......@@ -355,27 +359,34 @@ outer type constructors match.
Note [Delicate equality kick-out]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Delicate:
When kicking out rewritable constraints, it would be safe to simply
kick out all rewritable equalities, but instead we only kick out those
that, when rewritten, may result in occur-check errors. Example:
WorkItem = [G] a ~ b
Inerts = { [W] b ~ [a] }
Now at this point the work item cannot be further rewritten by the
inert (due to the weaker inert flavor). Instead the workitem can
rewrite the inert leading to potential occur check errors. So we must
kick the inert out. On the other hand, if the inert flavor was as
powerful or more powerful than the workitem flavor, the work-item could
not have reached this stage (because it would have already been
rewritten by the inert).
The coclusion is: we kick out the 'dangerous' equalities that may
require recanonicalization (occurs checks) and the rest we keep
there in the inerts without further checks.
In the past we used to rewrite-on-the-spot those equalities that we keep in,
but this is no longer necessary see Note [Non-idempotent inert substitution].
When adding an equality (a ~ xi), we kick out an inert type-variable
equality (b ~ phi) in two cases
(1) If the new tyvar can rewrite the kind LHS or RHS of the inert
equality. Example:
Work item: [W] k ~ *
Inert: [W] (a:k) ~ ty
[W] (b:*) ~ c :: k
We must kick out those blocked inerts so that we rewrite them
and can subsequently unify.
(2) If the new tyvar can
Work item: [G] a ~ b
Inert: [W] b ~ [a]
Now at this point the work item cannot be further rewritten by the
inert (due to the weaker inert flavor). But we can't add the work item
as-is because the inert set would then have a cyclic substitution,
when rewriting a wanted type mentioning 'a'. So we must kick the inert out.
We have to do this only if the inert *cannot* rewrite the work item;
it it can, then the work item will have been fully rewritten by the
inert during canonicalisation. So for example:
Work item: [W] a ~ Int
Inert: [W] b ~ [a]
No need to kick out the inert, beause the inert substitution is not
necessarily idemopotent. See Note [Non-idempotent inert substitution].
See also point (8) of Note [Detailed InertCans Invariants]
\begin{code}
data SPSolveResult = SPCantSolve
......
......@@ -915,7 +915,7 @@ built (in TcCanonical).
In contrast, the type of the evidence *term* (ccev_evtm or ctev_evar) in
the evidence may *not* be fully zonked; we are careful not to look at it
during constraint solving. Seee Note [Evidence field of CtEvidence]
during constraint solving. See Note [Evidence field of CtEvidence]
\begin{code}
mkNonCanonical :: CtLoc -> CtEvidence -> Ct
......
......@@ -477,29 +477,34 @@ The InertCans represents a collection of constraints with the following properti
7 Non-equality constraints are fully rewritten with respect to the equalities (CTyEqCan)
8 Equalities _do_not_ form an idempotent substitution but they are guarranteed to not have
any occurs errors. Additional notes:
- The lack of idempotence of the inert substitution implies that we must make sure
that when we rewrite a constraint we apply the substitution /recursively/ to the
types involved. Currently the one AND ONLY way in the whole constraint solver
that we rewrite types and constraints wrt to the inert substitution is
TcCanonical/flattenTyVar.
- In the past we did try to have the inert substituion as idempotent as possible but
this would only be true for constraints of the same flavor, so in total the inert
substitution could not be idempotent, due to flavor-related issued.
Note [Non-idempotent inert substitution] explains what is going on.
- Whenever a constraint ends up in the worklist we do recursively apply exhaustively
the inert substitution to it to check for occurs errors but if an equality is already
in the inert set and we can guarantee that adding a new equality will not cause the
first equality to have an occurs check then we do not rewrite the inert equality.
This happens in TcInteract, rewriteInertEqsFromInertEq.
8 Equalities _do_not_ form an idempotent substitution, but they are
guaranteed to not have any occurs errors. Additional notes:
- The lack of idempotence of the inert substitution implies
that we must make sure that when we rewrite a constraint we
apply the substitution /recursively/ to the types
involved. Currently the one AND ONLY way in the whole
constraint solver that we rewrite types and constraints wrt
to the inert substitution is TcCanonical/flattenTyVar.
- In the past we did try to have the inert substitution as
idempotent as possible but this would only be true for
constraints of the same flavor, so in total the inert
substitution could not be idempotent, due to flavor-related
issued. Note [Non-idempotent inert substitution] explains
what is going on.
- Whenever a constraint ends up in the worklist we do
recursively apply exhaustively the inert substitution to it
to check for occurs errors. But if an equality is already in
the inert set and we can guarantee that adding a new equality
will not cause the first equality to have an occurs check
then we do not rewrite the inert equality. This happens in
TcInteract, rewriteInertEqsFromInertEq.
See Note [Delicate equality kick-out] to see which inert equalities can safely stay
in the inert set and which must be kicked out to be rewritten and re-checked for
occurs errors.
See Note [Delicate equality kick-out] to see which inert
equalities can safely stay in the inert set and which must be
kicked out to be rewritten and re-checked for occurs errors.
9 Given family or dictionary constraints don't mention touchable unification variables
......@@ -1596,11 +1601,17 @@ Main purpose: create new evidence for new_pred;
Not Just new_evidence
-}
-- If derived, don't even look at the coercion
-- NB: this allows us to sneak away with ``error'' thunks for
-- coercions that come from derived ids (which don't exist!)
rewriteCtFlavor (CtDerived {}) new_pred _co
= -- If derived, don't even look at the coercion.
-- This is very important, DO NOT re-order the equations for
-- rewriteCtFlavor to put the isTcReflCo test first!
-- Why? Because for *Derived* constraints, c, the coercion, which
-- was produced by flattening, may contain suspended calls to
-- (ctEvTerm c), which fails for Derived constraints.
-- (Getting this wrong caused Trac #7384.)
newDerived new_pred
rewriteCtFlavor old_ev new_pred co
| isTcReflCo co -- If just reflexivity then you may re-use the same variable
= return (Just (if ctEvPred old_ev `eqType` new_pred
......@@ -1612,9 +1623,6 @@ rewriteCtFlavor old_ev new_pred co
-- However, if they *do* look the same, we'd prefer to stick with old_pred
-- then retain the old type, so that error messages come out mentioning synonyms
rewriteCtFlavor (CtDerived {}) new_pred _co
= newDerived new_pred
rewriteCtFlavor (CtGiven { ctev_evtm = old_tm }) new_pred co
= do { new_ev <- newGivenEvVar new_pred new_tm -- See Note [Bind new Givens immediately]
; return (Just new_ev) }
......
......@@ -662,7 +662,7 @@ Prelude>
an attempt to distinguish it from the new <literal>T</literal>,
which is displayed as simply <literal>T</literal>.</para>
<para>Class and type-family instance declarations are simply added to the list of available isntances, with one
<para>Class and type-family instance declarations are simply added to the list of available instances, with one
exception. Since type-family instances are not permitted to overlap, but you might want to re-define one,
a type-family instance <emphasis>replaces</emphasis> any earlier type instance with an identical left hand side.
(See <xref linkend="type-families"/>.)</para>
......
......@@ -631,7 +631,10 @@ main(int argc, char *argv[])
closure_field(StgTVarWatchQueue, next_queue_entry);
closure_field(StgTVarWatchQueue, prev_queue_entry);
closure_size(StgTVar);
closure_field(StgTVar, current_value);
closure_field(StgTVar, first_watch_queue_entry);
closure_field(StgTVar, num_updates);
closure_size(StgWeak);
closure_field(StgWeak,link);
......
......@@ -55,6 +55,9 @@ INFO_TABLE_RET(stg_unmaskAsyncExceptionszh_ret, RET_SMALL, W_ info_ptr)
{
CInt r;
P_ ret;
ret = R1;
StgTSO_flags(CurrentTSO) = %lobits32(
TO_W_(StgTSO_flags(CurrentTSO)) & ~(TSO_BLOCKEX|TSO_INTERRUPTIBLE));
......@@ -68,18 +71,18 @@ INFO_TABLE_RET(stg_unmaskAsyncExceptionszh_ret, RET_SMALL, W_ info_ptr)
* thread, which might result in the thread being killed.
*/
Sp_adj(-2);
Sp(1) = R1;
Sp(1) = ret;
Sp(0) = stg_ret_p_info;
SAVE_THREAD_STATE();
(r) = ccall maybePerformBlockedException (MyCapability() "ptr",
(r) = ccall maybePerformBlockedException (MyCapability() "ptr",
CurrentTSO "ptr");
if (r != 0::CInt) {
if (StgTSO_what_next(CurrentTSO) == ThreadKilled::I16) {
jump stg_threadFinished [];
} else {
LOAD_THREAD_STATE();
ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
R1 = ret;
jump %ENTRY_CODE(Sp(0)) [R1];
}
}
......@@ -94,6 +97,7 @@ INFO_TABLE_RET(stg_unmaskAsyncExceptionszh_ret, RET_SMALL, W_ info_ptr)
}
Sp_adj(1);
R1 = ret;
jump %ENTRY_CODE(Sp(0)) [R1];
}
......@@ -184,7 +188,10 @@ stg_unmaskAsyncExceptionszh /* explicit stack */
W_ level;
/* Args: R1 :: IO a */
STK_CHK_P (WDS(4), stg_unmaskAsyncExceptionszh, R1);
P_ io;
io = R1;
STK_CHK_P (WDS(4), stg_unmaskAsyncExceptionszh, io);
/* 4 words: one for the unblock frame, 3 for setting up the
* stack to call maybePerformBlockedException() below.
*/
......@@ -222,11 +229,11 @@ stg_unmaskAsyncExceptionszh /* explicit stack */
*/
Sp_adj(-3);
Sp(2) = stg_ap_v_info;
Sp(1) = R1;
Sp(1) = io;
Sp(0) = stg_enter_info;
SAVE_THREAD_STATE();
(r) = ccall maybePerformBlockedException (MyCapability() "ptr",
(r) = ccall maybePerformBlockedException (MyCapability() "ptr",
CurrentTSO "ptr");
if (r != 0::CInt) {
......@@ -235,6 +242,7 @@ stg_unmaskAsyncExceptionszh /* explicit stack */
} else {
LOAD_THREAD_STATE();
ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
R1 = io;
jump %ENTRY_CODE(Sp(0)) [R1];
}
} else {
......@@ -246,6 +254,7 @@ stg_unmaskAsyncExceptionszh /* explicit stack */
}
TICK_UNKNOWN_CALL();
TICK_SLOW_CALL_v();
R1 = io;
jump stg_ap_v_fast [R1];
}
......
......@@ -1062,8 +1062,15 @@ stg_newTVarzh (P_ init)
{
W_ tv;
MAYBE_GC_P (stg_newTVarzh, init);
("ptr" tv) = ccall stmNewTVar(MyCapability() "ptr", init "ptr");
ALLOC_PRIM_P (SIZEOF_StgTVar, stg_newTVarzh, init);
tv = Hp - SIZEOF_StgTVar + WDS(1);
SET_HDR (tv, stg_TVAR_info, CCCS);
StgTVar_current_value(tv) = init;
StgTVar_first_watch_queue_entry(tv) = stg_END_STM_WATCH_QUEUE_closure;
StgTVar_num_updates(tv) = 0;
return (tv);
}
......
......@@ -1648,18 +1648,3 @@ void stmWriteTVar(Capability *cap,
}
/*......................................................................*/
StgTVar *stmNewTVar(Capability *cap,
StgClosure *new_value) {
StgTVar *result;
result = (StgTVar *)allocate(cap, sizeofW(StgTVar));
SET_HDR (result, &stg_TVAR_info, CCS_SYSTEM);
result -> current_value = new_value;
result -> first_watch_queue_entry = END_STM_WATCH_QUEUE;
#if defined(THREADED_RTS)
result -> num_updates = 0;
#endif
return result;
}
/*......................................................................*/
......@@ -181,14 +181,6 @@ void stmWaitUnlock(Capability *cap, StgTRecHeader *trec);
StgBool stmReWait(Capability *cap, StgTSO *tso);
/*----------------------------------------------------------------------
TVar management operations
--------------------------
*/
StgTVar *stmNewTVar(Capability *cap, StgClosure *new_value);
/*----------------------------------------------------------------------
Data access operations
......
......@@ -239,7 +239,7 @@ usageHeader prog = substProg prog $
" Prints the highest registered version of a package.\n" ++
"\n" ++
" $p check\n" ++
" Check the consistency of package depenencies and list broken packages.\n" ++
" Check the consistency of package dependencies and list broken packages.\n" ++
" Accepts the --simple-output flag.\n" ++
"\n" ++
" $p describe {pkg}\n" ++
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment