Commit 03d45973 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

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

parents 8f16b3cd a1448ec2
......@@ -376,12 +376,12 @@ literalType (MachWord64 _) = word64PrimTy
literalType (MachFloat _) = floatPrimTy
literalType (MachDouble _) = doublePrimTy
literalType (MachLabel _ _ _) = addrPrimTy
literalType (LitInteger _ mkIntegerId)
literalType (LitInteger _ mk_integer_id)
-- We really mean idType, rather than varType, but importing Id
-- causes a module import loop
= case varType mkIntegerId of
FunTy _ (FunTy _ integerTy) -> integerTy
_ -> panic "literalType: mkIntegerId has the wrong type"
= case varType mk_integer_id of
FunTy _ (FunTy _ integerTy) -> integerTy
_ -> panic "literalType: mkIntegerId has the wrong type"
absentLiteralOf :: TyCon -> Maybe Literal
-- Return a literal of the appropriate primtive
......
......@@ -32,7 +32,7 @@ module CoreSubst (
-- ** Simple expression optimiser
simpleOptPgm, simpleOptExpr, simpleOptExprWith,
exprIsConApp_maybe
exprIsConApp_maybe, exprIsLiteral_maybe
) where
#include "HsVersions.h"
......@@ -40,6 +40,7 @@ module CoreSubst (
import CoreSyn
import CoreFVs
import CoreUtils
import Literal ( Literal )
import OccurAnal( occurAnalyseExpr, occurAnalysePgm )
import qualified Type
......@@ -1263,3 +1264,18 @@ Note [DFun arity check]
Here we check that the total number of supplied arguments (inclding
type args) matches what the dfun is expecting. This may be *less*
than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn
\begin{code}
exprIsLiteral_maybe :: IdUnfoldingFun -> CoreExpr -> Maybe Literal
-- Same deal as exprIsConApp_maybe, but much simpler
-- Nevertheless we do need to look through unfoldings for
-- Integer literals, which are vigorously hoisted to top level
-- and not subsequently inlined
exprIsLiteral_maybe id_unf e
= case e of
Lit l -> Just l
Note _ e' -> exprIsLiteral_maybe id_unf e'
Var v | Just rhs <- expandUnfolding_maybe (id_unf v)
-> exprIsLiteral_maybe id_unf rhs
_ -> Nothing
\end{code}
......@@ -33,7 +33,7 @@ module CoreUnfold (
-- Reexport from CoreSubst (it only live there so it can be used
-- by the Very Simple Optimiser)
exprIsConApp_maybe
exprIsConApp_maybe, exprIsLiteral_maybe
) where
#include "HsVersions.h"
......
......@@ -547,10 +547,11 @@ checkKindSigs :: [LTyClDecl RdrName] -> P ()
checkKindSigs = mapM_ check
where
check (L l tydecl)
| isFamilyDecl tydecl
|| isTypeDecl tydecl = return ()
| otherwise =
parseErrorSDoc l (text "Type declaration in a class must be a kind signature or synonym default:" $$ ppr tydecl)
| isFamilyDecl tydecl = return ()
| isTypeDecl tydecl = return ()
| otherwise
= parseErrorSDoc l (text "Type declaration in a class must be a kind signature or synonym default:"
$$ ppr tydecl)
checkContext :: LHsType RdrName -> P (LHsContext RdrName)
checkContext (L l orig_t)
......
......@@ -120,8 +120,8 @@ import FastString
This *local* name is used by the interactive stuff
\begin{code}
itName :: Unique -> Name
itName uniq = mkInternalName uniq (mkOccNameFS varName (fsLit "it")) noSrcSpan
itName :: Unique -> SrcSpan -> Name
itName uniq loc = mkInternalName uniq (mkOccNameFS varName (fsLit "it")) loc
\end{code}
\begin{code}
......
......@@ -22,6 +22,7 @@ import CoreSyn
import MkCore
import Id
import Literal
import CoreSubst ( exprIsLiteral_maybe )
import PrimOp ( PrimOp(..), tagToEnumKey )
import TysWiredIn
import TysPrim
......@@ -731,24 +732,28 @@ match_Integer_convert :: Num a
-> IdUnfoldingFun
-> [Expr CoreBndr]
-> Maybe (Expr CoreBndr)
match_Integer_convert convert _ [Lit (LitInteger x _)]
= Just (convert (fromIntegral x))
match_Integer_convert convert id_unf [xl]
| Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
= Just (convert (fromIntegral x))
match_Integer_convert _ _ _ = Nothing
match_Integer_unop :: (Integer -> Integer)
-> IdUnfoldingFun
-> [Expr CoreBndr]
-> Maybe (Expr CoreBndr)
match_Integer_unop unop _ [Lit (LitInteger x i)]
= Just (Lit (LitInteger (unop x) i))
match_Integer_unop unop id_unf [xl]
| Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
= Just (Lit (LitInteger (unop x) i))
match_Integer_unop _ _ _ = Nothing
match_Integer_binop :: (Integer -> Integer -> Integer)
-> IdUnfoldingFun
-> [Expr CoreBndr]
-> Maybe (Expr CoreBndr)
match_Integer_binop binop _ [Lit (LitInteger x i), Lit (LitInteger y _)]
= Just (Lit (LitInteger (x `binop` y) i))
match_Integer_binop binop id_unf [xl,yl]
| Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
, Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
= Just (Lit (LitInteger (x `binop` y) i))
match_Integer_binop _ _ _ = Nothing
-- This helper is used for the quotRem and divMod functions
......@@ -756,18 +761,19 @@ match_Integer_divop :: (Integer -> Integer -> (Integer, Integer))
-> IdUnfoldingFun
-> [Expr CoreBndr]
-> Maybe (Expr CoreBndr)
match_Integer_divop divop _ [Lit (LitInteger x i), Lit (LitInteger y _)]
| y /= 0
= case x `divop` y of
(r, s) ->
case idType i of
FunTy _ (FunTy _ integerTy) ->
match_Integer_divop divop id_unf [xl,yl]
| Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
, Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
, y /= 0
, (r,s) <- x `divop` y
= case idType i of
FunTy _ (FunTy _ integerTy) ->
Just $ mkConApp (tupleCon UnboxedTuple 2)
[Type integerTy,
Type integerTy,
Lit (LitInteger r i),
Lit (LitInteger s i)]
_ -> panic "match_Integer_divop: mkIntegerId has the wrong type"
_ -> panic "match_Integer_divop: mkIntegerId has the wrong type"
match_Integer_divop _ _ _ = Nothing
......@@ -775,24 +781,30 @@ match_Integer_Int_binop :: (Integer -> Int -> Integer)
-> IdUnfoldingFun
-> [Expr CoreBndr]
-> Maybe (Expr CoreBndr)
match_Integer_Int_binop binop _ [Lit (LitInteger x i), Lit (MachInt y)]
= Just (Lit (LitInteger (x `binop` fromIntegral y) i))
match_Integer_Int_binop binop id_unf [xl,yl]
| Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
, Just (MachInt y) <- exprIsLiteral_maybe id_unf yl
= Just (Lit (LitInteger (x `binop` fromIntegral y) i))
match_Integer_Int_binop _ _ _ = Nothing
match_Integer_binop_Bool :: (Integer -> Integer -> Bool)
-> IdUnfoldingFun
-> [Expr CoreBndr]
-> Maybe (Expr CoreBndr)
match_Integer_binop_Bool binop _ [Lit (LitInteger x _), Lit (LitInteger y _)]
= Just (if x `binop` y then trueVal else falseVal)
match_Integer_binop_Bool binop id_unf [xl, yl]
| Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
, Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
= Just (if x `binop` y then trueVal else falseVal)
match_Integer_binop_Bool _ _ _ = Nothing
match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering)
-> IdUnfoldingFun
-> [Expr CoreBndr]
-> Maybe (Expr CoreBndr)
match_Integer_binop_Ordering binop _ [Lit (LitInteger x _), Lit (LitInteger y _)]
= Just $ case x `binop` y of
match_Integer_binop_Ordering binop id_unf [xl, yl]
| Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
, Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
= Just $ case x `binop` y of
LT -> ltVal
EQ -> eqVal
GT -> gtVal
......
......@@ -1106,7 +1106,14 @@ setInteractiveContext hsc_env icxt thing_inside
-- Perhaps it would be better to just extend the global TyVar
-- list from the free tyvars in the Ids here? Anyway, at least
-- this hack is localised.
--
-- Note [delete shadowed tcg_rdr_env entries]
-- We also *delete* entries from tcg_rdr_env that we have
-- shadowed in the local env (see above). This isn't strictly
-- necessary, but in an out-of-scope error when GHC suggests
-- names it can be confusing to see multiple identical
-- entries. (#5564)
--
(tmp_ids, types_n_classes) = partitionWith sel_id (ic_tythings icxt)
where sel_id (AnId id) = Left id
sel_id other = Right other
......@@ -1123,7 +1130,9 @@ setInteractiveContext hsc_env icxt thing_inside
, c <- tyConDataCons t ]
in
updGblEnv (\env -> env {
tcg_rdr_env = ic_rn_gbl_env icxt
tcg_rdr_env = delListFromOccEnv (ic_rn_gbl_env icxt)
(map getOccName visible_tmp_ids)
-- Note [delete shadowed tcg_rdr_env entries]
, tcg_type_env = type_env
, tcg_inst_env = extendInstEnvList
(extendInstEnvList (tcg_inst_env env) ic_insts)
......@@ -1269,12 +1278,12 @@ runPlans (p:ps) = tryTcLIE_ (runPlans ps) p
mkPlan :: LStmt Name -> TcM PlanResult
mkPlan (L loc (ExprStmt expr _ _ _)) -- An expression typed at the prompt
= do { uniq <- newUnique -- is treated very specially
; let fresh_it = itName uniq
; let fresh_it = itName uniq loc
the_bind = L loc $ mkTopFunBind (L loc fresh_it) matches
matches = [mkMatch [] expr emptyLocalBinds]
let_stmt = L loc $ LetStmt $ HsValBinds $
ValBindsOut [(NonRecursive,unitBag the_bind)] []
bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr
bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it)) expr
(HsVar bindIOName) noSyntaxExpr
print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
(HsVar thenIOName) noSyntaxExpr placeHolderType
......@@ -1390,7 +1399,7 @@ tcRnExpr hsc_env ictxt rdr_expr
-- Now typecheck the expression;
-- it might have a rank-2 type (e.g. :t runST)
uniq <- newUnique ;
let { fresh_it = itName uniq } ;
let { fresh_it = itName uniq (getLoc rdr_expr) } ;
((_tc_expr, res_ty), lie) <- captureConstraints (tcInferRho rn_expr) ;
((qtvs, dicts, _, _), lie_top) <- captureConstraints $
simplifyInfer True {- Free vars are closed -}
......
......@@ -112,15 +112,70 @@ mkSynEdges syn_decls = [ (ldecl, unLoc (tcdLName decl),
calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)]
calcSynCycles = stronglyConnCompFromEdgedVertices . mkSynEdges
\end{code}
Note [Superclass cycle check]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We can't allow cycles via superclasses because it would result in the
type checker looping when it canonicalises a class constraint (superclasses
are added during canonicalisation). More precisely, given a constraint
C ty1 .. tyn
we want to instantiate all of C's superclasses, transitively, and
that set must be finite. So if
class (D b, E b a) => C a b
then when we encounter the constraint
C ty1 ty2
we'll instantiate the superclasses
(D ty2, E ty2 ty1)
and then *their* superclasses, and so on. This set must be finite!
It is OK for superclasses to be type synonyms for other classes, so
must "look through" type synonyms. Eg
type X a = C [a]
class X a => C a -- No! Recursive superclass!
We want definitions such as:
class C cls a where cls a => a -> a
class C D a => D a where
to be accepted, even though a naive acyclicity check would reject the
program as having a cycle between D and its superclass. Why? Because
when we instantiate
D ty1
we get the superclas
C D ty1
and C has no superclasses, so we have terminated with a finite set.
More precisely, the rule is this: the superclasses sup_C of a class C
are rejected iff:
C \elem expand(sup_C)
Where expand is defined as follows:
-- We can't allow cycles via superclasses because it would result in the
-- type checker looping when it canonicalises a class constraint (superclasses
-- are added during canonicalisation)
--
-- It is OK for superclasses to be type synonyms for other classes, so look for cycles
-- through there too.
(1) expand(a ty1 ... tyN) = expand(ty1) \union ... \union expand(tyN)
(2) expand(D ty1 ... tyN) = {D}
\union sup_D[ty1/x1, ..., tyP/xP]
\union expand(ty(P+1)) ... \union expand(tyN)
where (D x1 ... xM) is a class, P = min(M,N)
(3) expand(T ty1 ... tyN) = expand(ty1) \union ... \union expand(tyN)
where T is not a class
Eqn (1) is conservative; when there's a type variable at the head,
look in all the argument types. Eqn (2) expands superclasses; the
third component of the union is like Eqn (1). Eqn (3) happens mainly
when the context is a (constraint) tuple, such as (Eq a, Show a).
Furthermore, expand always looks through type synonyms.
\begin{code}
calcClassCycles :: Class -> [[TyCon]]
calcClassCycles cls = nubBy eqAsCycle $ expandTheta (unitUniqSet cls) [classTyCon cls] (classSCTheta cls) []
calcClassCycles cls
= nubBy eqAsCycle $
expandTheta (unitUniqSet cls) [classTyCon cls] (classSCTheta cls) []
where
-- The last TyCon in the cycle is always the same as the first
eqAsCycle xs ys = any (xs ==) (cycles (tail ys))
......@@ -128,6 +183,7 @@ calcClassCycles cls = nubBy eqAsCycle $ expandTheta (unitUniqSet cls) [classTyCo
where n = length xs
-- No more superclasses to expand ==> no problems with cycles
-- See Note [Superclass cycle check]
expandTheta :: UniqSet Class -- Path of Classes to here in set form
-> [TyCon] -- Path to here
-> ThetaType -- Superclass work list
......@@ -139,7 +195,8 @@ calcClassCycles cls = nubBy eqAsCycle $ expandTheta (unitUniqSet cls) [classTyCo
{-
expandTree seen path (ClassPred cls tys)
| cls `elemUniqSet` seen =
| otherwise = expandTheta (addOneToUniqSet cls seen) (classTyCon cls:path) (substTysWith (classTyVars cls) tys (classSCTheta cls))
| otherwise = expandTheta (addOneToUniqSet cls seen) (classTyCon cls:path)
(substTysWith (classTyVars cls) tys (classSCTheta cls))
expandTree seen path (TuplePred ts) = flip (foldr (expandTree seen path)) ts
expandTree _ _ (EqPred _ _) = id
expandTree _ _ (IPPred _ _) = id
......@@ -153,18 +210,26 @@ calcClassCycles cls = nubBy eqAsCycle $ expandTheta (unitUniqSet cls) [classTyCo
, let (env, remainder) = papp (classTyVars cls) tys
rest_tys = either (const []) id remainder
= if cls `elementOfUniqSet` seen
then (reverse (classTyCon cls:path):) . flip (foldr (expandType seen path)) tys
else expandTheta (addOneToUniqSet seen cls) (tc:path) (substTys (mkTopTvSubst env) (classSCTheta cls)) . flip (foldr (expandType seen path)) rest_tys
-- For synonyms, try to expand them: some arguments might be phantoms, after all. We can expand
-- with impunity because at this point the type synonym cycle check has already happened.
then (reverse (classTyCon cls:path):)
. flip (foldr (expandType seen path)) tys
else expandTheta (addOneToUniqSet seen cls) (tc:path)
(substTys (mkTopTvSubst env) (classSCTheta cls))
. flip (foldr (expandType seen path)) rest_tys
-- For synonyms, try to expand them: some arguments might be
-- phantoms, after all. We can expand with impunity because at
-- this point the type synonym cycle check has already happened.
| isSynTyCon tc
, SynonymTyCon rhs <- synTyConRhs tc
, let (env, remainder) = papp (tyConTyVars tc) tys
rest_tys = either (const []) id remainder
= expandType seen (tc:path) (substTy (mkTopTvSubst env) rhs) . flip (foldr (expandType seen path)) rest_tys
= expandType seen (tc:path) (substTy (mkTopTvSubst env) rhs)
. flip (foldr (expandType seen path)) rest_tys
-- For non-class, non-synonyms, just check the arguments
| otherwise
= flip (foldr (expandType seen path)) tys
expandType _ _ (TyVarTy _) = id
expandType seen path (AppTy t1 t2) = expandType seen path t1 . expandType seen path t2
expandType seen path (FunTy t1 t2) = expandType seen path t1 . expandType seen path t2
......
......@@ -4922,6 +4922,7 @@ class IsBoolMap v where
instance IsBoolMap [(Int, Bool)] where
lookupKey = lookup
</programlisting>
A default declaration is not permitted for an associated <emphasis>data</emphasis> type.
</para>
</sect3>
......
......@@ -412,7 +412,7 @@ runGHCi paths maybe_exprs = do
-- This would be a good place for runFileInputT.
Right hdl ->
do runInputTWithPrefs defaultPrefs defaultSettings $
runCommands False $ fileLoop hdl
runCommands $ fileLoop hdl
liftIO (hClose hdl `catchIO` \_ -> return ())
where
getDirectory f = case takeDirectory f of "" -> "."; d -> d
......@@ -447,11 +447,14 @@ runGHCi paths maybe_exprs = do
dflags <- getDynFlags
let show_prompt = verbosity dflags > 0 || is_tty
-- reset line number
getGHCiState >>= \st -> setGHCiState st{line_number=1}
case maybe_exprs of
Nothing ->
do
-- enter the interactive loop
runGHCiInput $ runCommands False $ nextInputLine show_prompt is_tty
runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
Just exprs -> do
-- just evaluate the expression we were given
enqueueCommands exprs
......@@ -465,7 +468,7 @@ runGHCi paths maybe_exprs = do
-- this used to be topHandlerFastExit, see #2228
$ topHandler e
runInputTWithPrefs defaultPrefs defaultSettings $ do
runCommands' handle False (return Nothing)
runCommands' handle (return Nothing)
-- and finally, exit
liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
......@@ -485,7 +488,9 @@ nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
nextInputLine show_prompt is_tty
| is_tty = do
prompt <- if show_prompt then lift mkPrompt else return ""
getInputLine prompt
r <- getInputLine prompt
incrementLineNo
return r
| otherwise = do
when show_prompt $ lift mkPrompt >>= liftIO . putStr
fileLoop stdin
......@@ -521,8 +526,8 @@ checkPerms name =
else return True
#endif
incrementLines :: InputT GHCi ()
incrementLines = do
incrementLineNo :: InputT GHCi ()
incrementLineNo = do
st <- lift $ getGHCiState
let ln = 1+(line_number st)
lift $ setGHCiState st{line_number=ln}
......@@ -540,7 +545,7 @@ fileLoop hdl = do
-- perhaps did getContents which closes stdin at
-- EOF.
Right l -> do
incrementLines
incrementLineNo
return (Just l)
mkPrompt :: GHCi String
......@@ -593,15 +598,12 @@ queryQueue = do
c:cs -> do setGHCiState st{ cmdqueue = cs }
return (Just c)
runCommands :: Bool -> InputT GHCi (Maybe String) -> InputT GHCi ()
runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
runCommands = runCommands' handler
runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler
-> Bool
-> InputT GHCi (Maybe String) -> InputT GHCi ()
runCommands' eh resetLineTo1 getCmd = do
when resetLineTo1 $ lift $ do st <- getGHCiState
setGHCiState $ st { line_number = 0 }
runCommands' eh getCmd = do
b <- ghandle (\e -> case fromException e of
Just UserInterrupt -> return $ Just False
_ -> case fromException e of
......@@ -613,7 +615,7 @@ runCommands' eh resetLineTo1 getCmd = do
(runOneCommand eh getCmd)
case b of
Nothing -> return ()
Just _ -> runCommands' eh resetLineTo1 getCmd
Just _ -> runCommands' eh getCmd
runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
-> InputT GHCi (Maybe Bool)
......
......@@ -653,7 +653,15 @@ yieldCapability (Capability** pCap, Task *task)
continue;
}
if (task->incall->tso == NULL) {
if (task->cap != cap) {
// see Note [migrated bound threads]
debugTrace(DEBUG_sched,
"task has been migrated to cap %d", task->cap->no);
RELEASE_LOCK(&cap->lock);
continue;
}
if (task->incall->tso == NULL) {
ASSERT(cap->spare_workers != NULL);
// if we're not at the front of the queue, release it
// again. This is unlikely to happen.
......@@ -681,6 +689,23 @@ yieldCapability (Capability** pCap, Task *task)
return;
}
// Note [migrated bound threads]
//
// There's a tricky case where:
// - cap A is running an unbound thread T1
// - there is a bound thread T2 at the head of the run queue on cap A
// - T1 makes a safe foreign call, the task bound to T2 is woken up on cap A
// - T1 returns quickly grabbing A again (T2 is still waking up on A)
// - T1 blocks, the scheduler migrates T2 to cap B
// - the task bound to T2 wakes up on cap B
//
// We take advantage of the following invariant:
//
// - A bound thread can only be migrated by the holder of the
// Capability on which the bound thread currently lives. So, if we
// hold Capabilty C, and task->cap == C, then task cannot be
// migrated under our feet.
/* ----------------------------------------------------------------------------
* prodCapability
*
......
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