Commit 02779cb1 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

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

parents af457be6 0d6529f6
......@@ -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}
......
......@@ -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 -}
......
......@@ -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