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

15 files changed, 425 insertions, 245 deletions

diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 9e3acb41f9..293cc4a9a2 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -16,31 +16,31 @@ HsTypes: Abstract syntax: user-defined types
 {-# LANGUAGE DeriveDataTypeable #-}
 
 module HsTypes (
-	HsType(..), LHsType, HsKind, LHsKind,
-	HsBndrSig(..), HsTyVarBndr(..), LHsTyVarBndr,
-	HsTupleSort(..), HsExplicitFlag(..),
-	HsContext, LHsContext,
-	HsQuasiQuote(..),
+        HsType(..), LHsType, HsKind, LHsKind,
+        HsBndrSig(..), HsTyVarBndr(..), LHsTyVarBndr,
+        HsTupleSort(..), HsExplicitFlag(..),
+        HsContext, LHsContext,
+        HsQuasiQuote(..),
         HsTyWrapper(..),
         HsTyLit(..),
 
-	LBangType, BangType, HsBang(..), 
+        LBangType, BangType, HsBang(..), 
         getBangType, getBangStrictness, 
 
-	ConDeclField(..), pprConDeclFields,
-	
-	mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
-	hsTyVarName, hsTyVarNames, 
-	hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
-	splitHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe,
+        ConDeclField(..), pprConDeclFields,
+        
+        mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
+        hsTyVarName, hsTyVarNames, 
+        hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
+        splitHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe,
         splitHsForAllTy, splitLHsForAllTy,
         splitHsClassTy_maybe, splitLHsClassTy_maybe,
         splitHsFunType,
-	splitHsAppTys, mkHsAppTys, mkHsOpTy,
+        splitHsAppTys, mkHsAppTys, mkHsOpTy,
         placeHolderBndrs,
 
-	-- Printing
-	pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context,
+        -- Printing
+        pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context,
     ) where
 
 import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice )
@@ -62,16 +62,16 @@ import Data.Data
 
 
 %************************************************************************
-%*									*
-	Quasi quotes; used in types and elsewhere
-%*									*
+%*                                                                      *
+        Quasi quotes; used in types and elsewhere
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
 data HsQuasiQuote id = HsQuasiQuote 
-		       	   id		-- The quasi-quoter
-		       	   SrcSpan	-- The span of the enclosed string
-		       	   FastString	-- The enclosed string
+                           id           -- The quasi-quoter
+                           SrcSpan      -- The span of the enclosed string
+                           FastString   -- The enclosed string
   deriving (Data, Typeable)
 
 instance OutputableBndr id => Outputable (HsQuasiQuote id) where
@@ -85,14 +85,14 @@ ppr_qq (HsQuasiQuote quoter _ quote) =
 
 
 %************************************************************************
-%*									*
+%*                                                                      *
 \subsection{Bang annotations}
-%*									*
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
 type LBangType name = Located (BangType name)
-type BangType name  = HsType name	-- Bangs are in the HsType data type
+type BangType name  = HsType name       -- Bangs are in the HsType data type
 
 getBangType :: LHsType a -> LHsType a
 getBangType (L _ (HsBangTy _ ty)) = ty
@@ -105,9 +105,9 @@ getBangStrictness _                    = HsNoBang
 
 
 %************************************************************************
-%*									*
+%*                                                                      *
 \subsection{Data types}
-%*									*
+%*                                                                      *
 %************************************************************************
 
 This is the syntax for types as seen in type signatures.
@@ -148,8 +148,8 @@ placeHolderBndrs :: [Name]
 placeHolderBndrs = panic "placeHolderBndrs"
 
 data HsTyVarBndr name
-  = UserTyVar		-- No explicit kinding
-         name 		-- See Note [Printing KindedTyVars]
+  = UserTyVar           -- No explicit kinding
+         name           -- See Note [Printing KindedTyVars]
 
   | KindedTyVar
          name
@@ -160,57 +160,57 @@ data HsTyVarBndr name
   deriving (Data, Typeable)
 
 data HsType name
-  = HsForAllTy	HsExplicitFlag   	-- Renamer leaves this flag unchanged, to record the way
-					-- the user wrote it originally, so that the printer can
-					-- print it as the user wrote it
-		[LHsTyVarBndr name]	-- See Note [HsForAllTy tyvar binders]
-		(LHsContext name)
-		(LHsType name)
-
-  | HsTyVar		name		-- Type variable, type constructor, or data constructor
+  = HsForAllTy  HsExplicitFlag          -- Renamer leaves this flag unchanged, to record the way
+                                        -- the user wrote it originally, so that the printer can
+                                        -- print it as the user wrote it
+                [LHsTyVarBndr name]     -- See Note [HsForAllTy tyvar binders]
+                (LHsContext name)
+                (LHsType name)
+
+  | HsTyVar             name            -- Type variable, type constructor, or data constructor
                                         -- see Note [Promotions (HsTyVar)]
 
-  | HsAppTy		(LHsType name)
-			(LHsType name)
+  | HsAppTy             (LHsType name)
+                        (LHsType name)
 
-  | HsFunTy		(LHsType name)   -- function type
-			(LHsType name)
+  | HsFunTy             (LHsType name)   -- function type
+                        (LHsType name)
 
-  | HsListTy		(LHsType name)	-- Element type
+  | HsListTy            (LHsType name)  -- Element type
 
-  | HsPArrTy		(LHsType name)	-- Elem. type of parallel array: [:t:]
+  | HsPArrTy            (LHsType name)  -- Elem. type of parallel array: [:t:]
 
-  | HsTupleTy		HsTupleSort
-			[LHsType name]	-- Element types (length gives arity)
+  | HsTupleTy           HsTupleSort
+                        [LHsType name]  -- Element types (length gives arity)
 
-  | HsOpTy		(LHsType name) (LHsTyOp name) (LHsType name)
+  | HsOpTy              (LHsType name) (LHsTyOp name) (LHsType name)
 
-  | HsParTy		(LHsType name)   -- See Note [Parens in HsSyn] in HsExpr
-	-- Parenthesis preserved for the precedence re-arrangement in RnTypes
-	-- It's important that a * (b + c) doesn't get rearranged to (a*b) + c!
+  | HsParTy             (LHsType name)   -- See Note [Parens in HsSyn] in HsExpr
+        -- Parenthesis preserved for the precedence re-arrangement in RnTypes
+        -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c!
 
-  | HsIParamTy		(IPName name)    -- (?x :: ty)
+  | HsIParamTy          (IPName name)    -- (?x :: ty)
                         (LHsType name)   -- Implicit parameters as they occur in contexts
 
   | HsEqTy              (LHsType name)   -- ty1 ~ ty2
                         (LHsType name)   -- Always allowed even without TypeOperators, and has special kinding rule
 
-  | HsKindSig		(LHsType name)	-- (ty :: kind)
-			(LHsKind name)  -- A type with a kind signature
+  | HsKindSig           (LHsType name)  -- (ty :: kind)
+                        (LHsKind name)  -- A type with a kind signature
 
-  | HsQuasiQuoteTy	(HsQuasiQuote name)
+  | HsQuasiQuoteTy      (HsQuasiQuote name)
 
-  | HsSpliceTy		(HsSplice name) 
-                        FreeVars  	-- Variables free in the splice (filled in by renamer)
-			PostTcKind
+  | HsSpliceTy          (HsSplice name) 
+                        FreeVars        -- Variables free in the splice (filled in by renamer)
+                        PostTcKind
 
   | HsDocTy             (LHsType name) LHsDocString -- A documented type
 
-  | HsBangTy	HsBang (LHsType name)	-- Bang-style type annotations 
-  | HsRecTy [ConDeclField name]	        -- Only in data type declarations
+  | HsBangTy    HsBang (LHsType name)   -- Bang-style type annotations 
+  | HsRecTy [ConDeclField name]         -- Only in data type declarations
 
-  | HsCoreTy Type	-- An escape hatch for tunnelling a *closed* 
-    	       		-- Core Type through HsSyn.  
+  | HsCoreTy Type       -- An escape hatch for tunnelling a *closed* 
+                        -- Core Type through HsSyn.  
 
   | HsExplicitListTy     -- A promoted explicit list
         PostTcKind       -- See Note [Promoted lists and tuples]
@@ -339,16 +339,16 @@ data HsTupleSort = HsUnboxedTuple
 
 data HsExplicitFlag = Explicit | Implicit deriving (Data, Typeable)
 
-data ConDeclField name	-- Record fields have Haddoc docs on them
+data ConDeclField name  -- Record fields have Haddoc docs on them
   = ConDeclField { cd_fld_name :: Located name,
-		   cd_fld_type :: LBangType name, 
-		   cd_fld_doc  :: Maybe LHsDocString }
+                   cd_fld_type :: LBangType name, 
+                   cd_fld_doc  :: Maybe LHsDocString }
   deriving (Data, Typeable)
 
 -----------------------
 -- Combine adjacent for-alls. 
 -- The following awkward situation can happen otherwise:
---	f :: forall a. ((Num a) => Int)
+--      f :: forall a. ((Num a) => Int)
 -- might generate HsForAll (Just [a]) [] (HsForAll Nothing [Num a] t)
 -- Then a isn't discovered as ambiguous, and we abstract the AbsBinds wrt []
 -- but the export list abstracts f wrt [a].  Disaster.
@@ -367,14 +367,14 @@ mkHsForAllTy exp tvs ctxt ty = HsForAllTy exp tvs ctxt ty
 
 -- mk_forall_ty makes a pure for-all type (no context)
 mk_forall_ty :: HsExplicitFlag -> [LHsTyVarBndr name] -> LHsType name -> HsType name
-mk_forall_ty exp  tvs  (L _ (HsParTy ty))		    = mk_forall_ty exp tvs ty
+mk_forall_ty exp  tvs  (L _ (HsParTy ty))                   = mk_forall_ty exp tvs ty
 mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 tvs2 ctxt ty)) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ tvs2) ctxt ty
-mk_forall_ty exp  tvs  ty			            = HsForAllTy exp tvs (noLoc []) ty
-	-- Even if tvs is empty, we still make a HsForAll!
-	-- In the Implicit case, this signals the place to do implicit quantification
-	-- In the Explicit case, it prevents implicit quantification	
-	--	(see the sigtype production in Parser.y.pp)
-	-- 	so that (forall. ty) isn't implicitly quantified
+mk_forall_ty exp  tvs  ty                                   = HsForAllTy exp tvs (noLoc []) ty
+        -- Even if tvs is empty, we still make a HsForAll!
+        -- In the Implicit case, this signals the place to do implicit quantification
+        -- In the Explicit case, it prevents implicit quantification    
+        --      (see the sigtype production in Parser.y.pp)
+        --      so that (forall. ty) isn't implicitly quantified
 
 plus :: HsExplicitFlag -> HsExplicitFlag -> HsExplicitFlag
 Implicit `plus` Implicit = Implicit
@@ -410,14 +410,14 @@ hsLTyVarLocNames = map hsLTyVarLocName
 \begin{code}
 splitHsAppTys :: LHsType n -> [LHsType n] -> (LHsType n, [LHsType n])
 splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as)
-splitHsAppTys f          	  as = (f,as)
+splitHsAppTys f                   as = (f,as)
 
 mkHsAppTys :: OutputableBndr n => LHsType n -> [LHsType n] -> HsType n
 mkHsAppTys fun_ty [] = pprPanic "mkHsAppTys" (ppr fun_ty)
 mkHsAppTys fun_ty (arg_ty:arg_tys)
   = foldl mk_app (HsAppTy fun_ty arg_ty) arg_tys
   where
-    mk_app fun arg = HsAppTy (noLoc fun) arg	
+    mk_app fun arg = HsAppTy (noLoc fun) arg    
        -- Add noLocs for inner nodes of the application; 
        -- they are never used 
 
@@ -429,7 +429,7 @@ splitHsInstDeclTy_maybe ty
 splitLHsInstDeclTy_maybe
     :: LHsType name 
     -> Maybe ([LHsTyVarBndr name], HsContext name, Located name, [LHsType name])
-	-- Split up an instance decl type, returning the pieces
+        -- Split up an instance decl type, returning the pieces
 splitLHsInstDeclTy_maybe inst_ty = do
     let (tvs, cxt, ty) = splitLHsForAllTy inst_ty
     (cls, tys) <- splitLHsClassTy_maybe ty
@@ -471,20 +471,20 @@ splitLHsClassTy_maybe ty
 
 -- Splits HsType into the (init, last) parts
 -- Breaks up any parens in the result type: 
---	splitHsFunType (a -> (b -> c)) = ([a,b], c)
+--      splitHsFunType (a -> (b -> c)) = ([a,b], c)
 splitHsFunType :: LHsType name -> ([LHsType name], LHsType name)
 splitHsFunType (L _ (HsFunTy x y)) = (x:args, res)
   where
   (args, res) = splitHsFunType y
 splitHsFunType (L _ (HsParTy ty))  = splitHsFunType ty
-splitHsFunType other 	   	   = ([], other)
+splitHsFunType other               = ([], other)
 \end{code}
 
 
 %************************************************************************
-%*									*
+%*                                                                      *
 \subsection{Pretty printing}
-%*									*
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
@@ -507,12 +507,12 @@ pprHsForAll exp tvs cxt
   | otherwise   = pprHsContext (unLoc cxt)
   where
     show_forall =  opt_PprStyle_Debug
-		|| (not (null tvs) && is_explicit)
+                || (not (null tvs) && is_explicit)
     is_explicit = case exp of {Explicit -> True; Implicit -> False}
     forall_part = ptext (sLit "forall") <+> interppSP tvs <> dot
 
 pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc
-pprHsContext []	        = empty
+pprHsContext []         = empty
 pprHsContext [L _ pred] = ppr pred <+> darrow
 pprHsContext cxt        = ppr_hs_context cxt <+> darrow
 
@@ -524,8 +524,8 @@ pprConDeclFields :: OutputableBndr name => [ConDeclField name] -> SDoc
 pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
   where
     ppr_fld (ConDeclField { cd_fld_name = n, cd_fld_type = ty, 
-			    cd_fld_doc = doc })
-  	= ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
+                            cd_fld_doc = doc })
+        = ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
 \end{code}
 
 Note [Printing KindedTyVars]
@@ -549,12 +549,12 @@ pREC_OP  = 2  -- Used for arg of any infix operator
 pREC_CON = 3  -- Used for arg of type applicn:
               -- always parenthesise unless atomic
 
-maybeParen :: Int 	-- Precedence of context
-	   -> Int	-- Precedence of top-level operator
-	   -> SDoc -> SDoc	-- Wrap in parens if (ctxt >= op)
+maybeParen :: Int       -- Precedence of context
+           -> Int       -- Precedence of top-level operator
+           -> SDoc -> SDoc      -- Wrap in parens if (ctxt >= op)
 maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
-			       | otherwise	      = p
-	
+                               | otherwise            = p
+        
 -- printing works more-or-less as for Types
 
 pprHsType, pprParendHsType :: (OutputableBndr name) => HsType name -> SDoc
@@ -567,7 +567,7 @@ pprParendHsType ty = ppr_mono_ty pREC_CON ty
 -- (b) Drop top-level for-all type variables in user style
 --     since they are implicit in Haskell
 prepare :: PprStyle -> HsType name -> HsType name
-prepare sty (HsParTy ty)	  = prepare sty (unLoc ty)
+prepare sty (HsParTy ty)          = prepare sty (unLoc ty)
 prepare _   ty                    = ty
 
 ppr_mono_lty :: (OutputableBndr name) => Int -> LHsType name -> SDoc
@@ -588,8 +588,8 @@ ppr_mono_ty _    (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys)
                     HsUnboxedTuple -> UnboxedTuple
                     _              -> BoxedTuple
 ppr_mono_ty _    (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> ppr kind)
-ppr_mono_ty _    (HsListTy ty)	     = brackets (ppr_mono_lty pREC_TOP ty)
-ppr_mono_ty _    (HsPArrTy ty)	     = paBrackets (ppr_mono_lty pREC_TOP ty)
+ppr_mono_ty _    (HsListTy ty)       = brackets (ppr_mono_lty pREC_TOP ty)
+ppr_mono_ty _    (HsPArrTy ty)       = paBrackets (ppr_mono_lty pREC_TOP ty)
 ppr_mono_ty prec (HsIParamTy n ty)   = maybeParen prec pREC_FUN (ppr n <+> dcolon <+> ppr_mono_lty pREC_TOP ty)
 ppr_mono_ty _    (HsSpliceTy s _ _)  = pprSplice s
 ppr_mono_ty _    (HsCoreTy ty)       = ppr ty
@@ -627,7 +627,7 @@ ppr_mono_ty _         (HsParTy ty)
   = parens (ppr_mono_lty pREC_TOP ty)
   -- Put the parens in where the user did
   -- But we still use the precedence stuff to add parens because
-  --	toHsType doesn't put in any HsParTys, so we may still need them
+  --    toHsType doesn't put in any HsParTys, so we may still need them
 
 ppr_mono_ty ctxt_prec (HsDocTy ty doc) 
   = maybeParen ctxt_prec pREC_OP $
@@ -639,7 +639,7 @@ ppr_mono_ty ctxt_prec (HsDocTy ty doc)
 ppr_fun_ty :: (OutputableBndr name) => Int -> LHsType name -> LHsType name -> SDoc
 ppr_fun_ty ctxt_prec ty1 ty2
   = let p1 = ppr_mono_lty pREC_FUN ty1
-	p2 = ppr_mono_lty pREC_TOP ty2
+        p2 = ppr_mono_lty pREC_TOP ty2
     in
     maybeParen ctxt_prec pREC_FUN $
     sep [p1, ptext (sLit "->") <+> p2]
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 2cc8446ba1..13a5f01e7f 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -597,6 +597,7 @@ data DynFlags = DynFlags {
   flushErr              :: FlushErr,
 
   haddockOptions        :: Maybe String,
+  ghciScripts           :: [String],
 
   -- | what kind of {-# SCC #-} to add automatically
   profAuto              :: ProfAuto,
@@ -941,6 +942,7 @@ defaultDynFlags mySettings =
         haddockOptions = Nothing,
         flags = IntSet.fromList (map fromEnum defaultFlags),
         warningFlags = IntSet.fromList (map fromEnum standardWarnings),
+        ghciScripts = [],
         language = Nothing,
         safeHaskell = Sf_SafeInfered,
         thOnLoc = noSrcSpan,
@@ -1183,7 +1185,7 @@ setObjectDir, setHiDir, setStubDir, setDumpDir, setOutputDir,
          setDylibInstallName,
          setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode,
          setPgmP, addOptl, addOptP,
-         addCmdlineFramework, addHaddockOpts
+         addCmdlineFramework, addHaddockOpts, addGhciScript
    :: String -> DynFlags -> DynFlags
 setOutputFile, setOutputHi, setDumpPrefixForce
    :: Maybe String -> DynFlags -> DynFlags
@@ -1255,6 +1257,8 @@ addCmdlineFramework f d = d{ cmdlineFrameworks = f : cmdlineFrameworks d}
 
 addHaddockOpts f d = d{ haddockOptions = Just f}
 
+addGhciScript f d = d{ ghciScripts = f : ghciScripts d}
+
 -- -----------------------------------------------------------------------------
 -- Command-line options
 
@@ -1545,6 +1549,7 @@ dynamic_flags = [
   , Flag "haddock"        (NoArg (setDynFlag Opt_Haddock))
   , Flag "haddock-opts"   (hasArg addHaddockOpts)
   , Flag "hpcdir"         (SepArg setOptHpcDir)
+  , Flag "ghci-script"    (hasArg addGhciScript)
 
         ------- recompilation checker --------------------------------------
   , Flag "recomp"         (NoArg (do unSetDynFlag Opt_ForceRecomp
diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
index 6322024c9e..6ea12e51be 100644
--- a/compiler/main/HeaderInfo.hs
+++ b/compiler/main/HeaderInfo.hs
@@ -160,12 +160,12 @@ blockSize = 1024
 lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token]
 lazyGetToks dflags filename handle = do
   buf <- hGetStringBufferBlock handle blockSize
-  unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False
+  unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False blockSize
  where
   loc  = mkRealSrcLoc (mkFastString filename) 1 1
 
-  lazyLexBuf :: Handle -> PState -> Bool -> IO [Located Token]
-  lazyLexBuf handle state eof = do
+  lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token]
+  lazyLexBuf handle state eof size = do
     case unP (lexer return) state of
       POk state' t -> do
         -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ())
@@ -173,22 +173,26 @@ lazyGetToks dflags filename handle = do
            -- if this token reached the end of the buffer, and we haven't
            -- necessarily read up to the end of the file, then the token might
            -- be truncated, so read some more of the file and lex it again.
-           then getMore handle state
+           then getMore handle state size
            else case t of
                   L _ ITeof -> return [t]
-                  _other    -> do rest <- lazyLexBuf handle state' eof
+                  _other    -> do rest <- lazyLexBuf handle state' eof size
                                   return (t : rest)
-      _ | not eof   -> getMore handle state
+      _ | not eof   -> getMore handle state size
         | otherwise -> return [L (RealSrcSpan (last_loc state)) ITeof]
                          -- parser assumes an ITeof sentinel at the end
 
-  getMore :: Handle -> PState -> IO [Located Token]
-  getMore handle state = do
+  getMore :: Handle -> PState -> Int -> IO [Located Token]
+  getMore handle state size = do
      -- pprTrace "getMore" (text (show (buffer state))) (return ())
-     nextbuf <- hGetStringBufferBlock handle blockSize
-     if (len nextbuf == 0) then lazyLexBuf handle state True else do
+     let new_size = size * 2
+       -- double the buffer size each time we read a new block.  This
+       -- counteracts the quadratic slowdown we otherwise get for very
+       -- large module names (#5981)
+     nextbuf <- hGetStringBufferBlock handle new_size
+     if (len nextbuf == 0) then lazyLexBuf handle state True new_size else do
      newbuf <- appendStringBuffers (buffer state) nextbuf
-     unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False
+     unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size
 
 
 getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 8cc94a3ce8..a666220a6e 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -411,8 +411,8 @@ rethrow dflags io = Exception.catch io $ \se -> do
 
 withInterruptsSentTo :: ThreadId -> IO r -> IO r
 withInterruptsSentTo thread get_result = do
-  bracket (modifyMVar_ interruptTargetThread (return . (thread:)))
-          (\_ -> modifyMVar_ interruptTargetThread (\tl -> return $! tail tl))
+  bracket (pushInterruptTargetThread thread)
+          (\_ -> popInterruptTargetThread)
           (\_ -> get_result)
 
 -- This function sets up the interpreter for catching breakpoints, and
@@ -758,11 +758,16 @@ abandonAll = do
 --          with the partial computation, which still ends in takeMVar,
 --          so any attempt to evaluate one of these thunks will block
 --          unless we fill in the MVar.
+--      (c) wait for the thread to terminate by taking its status MVar.  This
+--          step is necessary to prevent race conditions with
+--          -fbreak-on-exception (see #5975).
 --  See test break010.
 abandon_ :: Resume -> IO ()
 abandon_ r = do
   killThread (resumeThreadId r)
   putMVar (resumeBreakMVar r) ()
+  _ <- takeMVar (resumeStatMVar r)
+  return ()
 
 -- -----------------------------------------------------------------------------
 -- Bounded list, optimised for repeated cons
diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs
index c2f8674aa9..cfbd4bab58 100644
--- a/compiler/main/StaticFlags.hs
+++ b/compiler/main/StaticFlags.hs
@@ -80,7 +80,6 @@ module StaticFlags (
 
 	-- misc opts
 	opt_IgnoreDotGhci,
-	opt_GhciScripts,
 	opt_ErrorSpans,
 	opt_GranMacros,
 	opt_HiVersion,
@@ -103,7 +102,7 @@ module StaticFlags (
 import Config
 import FastString
 import Util
-import Maybes		( firstJusts, catMaybes )
+import Maybes		( firstJusts )
 import Panic
 
 import Control.Monad    ( liftM3 )
@@ -133,7 +132,6 @@ lookUp	       	 :: FastString -> Bool
 lookup_def_int   :: String -> Int -> Int
 lookup_def_float :: String -> Float -> Float
 lookup_str       :: String -> Maybe String
-lookup_all_str   :: String -> [String]
 
 -- holds the static opts while they're being collected, before
 -- being unsafely read by unpacked_static_opts below.
@@ -164,10 +162,6 @@ lookup_str sw
 	Just str         -> Just str
 	Nothing		 -> Nothing
 
-lookup_all_str sw = map f $ catMaybes (map (stripPrefix sw) staticFlags) where
-   f ('=' : str) = str
-   f str = str
-
 lookup_def_int sw def = case (lookup_str sw) of
 			    Nothing -> def		-- Use default
 		  	    Just xx -> try_read sw xx
@@ -207,9 +201,6 @@ unpacked_opts =
 opt_IgnoreDotGhci :: Bool
 opt_IgnoreDotGhci		= lookUp (fsLit "-ignore-dot-ghci")
 
-opt_GhciScripts :: [String]
-opt_GhciScripts = lookup_all_str "-ghci-script"
-
 -- debugging options
 -- | Suppress all that is suppressable in core dumps.
 --   Except for uniques, as some simplifier phases introduce new varibles that
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 5fd0e9de76..dd842849e7 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -1053,6 +1053,9 @@ typedoc :: { LHsType RdrName }
         | btype '->'     ctypedoc        { LL $ HsFunTy $1 $3 }
         | btype docprev '->' ctypedoc    { LL $ HsFunTy (L (comb2 $1 $2) (HsDocTy $1 $2)) $4 }
         | btype '~'      btype           { LL $ HsEqTy $1 $3 }
+                                        -- see Note [Promotion]
+        | btype SIMPLEQUOTE qconop type     { LL $ mkHsOpTy $1 $3 $4 }
+        | btype SIMPLEQUOTE varop  type     { LL $ mkHsOpTy $1 $3 $4 }
 
 btype :: { LHsType RdrName }
         : btype atype                   { LL $ HsAppTy $1 $2 }
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 35806a1dc6..9b47edb169 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -276,8 +276,7 @@ basicKnownKeyNames
         -- Type-level naturals
         typeNatKindConName,
         typeStringKindConName,
-        typeNatClassName,
-        typeStringClassName,
+        singIClassName,
         typeNatLeqClassName,
         typeNatAddTyFamName,
         typeNatMulTyFamName,
@@ -1052,14 +1051,12 @@ isStringClassName   = clsQual dATA_STRING (fsLit "IsString") isStringClassKey
 
 -- Type-level naturals
 typeNatKindConName, typeStringKindConName,
-  typeNatClassName, typeStringClassName, typeNatLeqClassName,
+  singIClassName, typeNatLeqClassName,
   typeNatAddTyFamName, typeNatMulTyFamName, typeNatExpTyFamName :: Name
 typeNatKindConName    = tcQual gHC_TYPELITS (fsLit "Nat")  typeNatKindConNameKey
 typeStringKindConName = tcQual gHC_TYPELITS (fsLit "Symbol")
                                                         typeStringKindConNameKey
-typeNatClassName    = clsQual gHC_TYPELITS (fsLit "NatI") typeNatClassNameKey
-typeStringClassName = clsQual gHC_TYPELITS (fsLit "SymbolI")
-                                                         typeStringClassNameKey
+singIClassName      = clsQual gHC_TYPELITS (fsLit "SingI") singIClassNameKey
 typeNatLeqClassName = clsQual gHC_TYPELITS (fsLit "<=")  typeNatLeqClassNameKey
 typeNatAddTyFamName = tcQual  gHC_TYPELITS (fsLit "+")   typeNatAddTyFamNameKey
 typeNatMulTyFamName = tcQual  gHC_TYPELITS (fsLit "*")   typeNatMulTyFamNameKey
@@ -1179,10 +1176,9 @@ datatypeClassKey    = mkPreludeClassUnique 39
 constructorClassKey = mkPreludeClassUnique 40
 selectorClassKey    = mkPreludeClassUnique 41
 
-typeNatClassNameKey, typeStringClassNameKey, typeNatLeqClassNameKey :: Unique
-typeNatClassNameKey     = mkPreludeClassUnique 42
-typeStringClassNameKey  = mkPreludeClassUnique 43
-typeNatLeqClassNameKey  = mkPreludeClassUnique 44
+singIClassNameKey, typeNatLeqClassNameKey :: Unique
+singIClassNameKey       = mkPreludeClassUnique 42
+typeNatLeqClassNameKey  = mkPreludeClassUnique 43
 \end{code}
 
 %************************************************************************
diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index b24f76ce40..eb642b5f63 100644
--- a/compiler/typecheck/TcCanonical.lhs
+++ b/compiler/typecheck/TcCanonical.lhs
@@ -8,13 +8,13 @@
 
 module TcCanonical(
     canonicalize, flatten, flattenMany, 
+    FlattenMode (..),
     StopOrContinue (..)
  ) where
 
 #include "HsVersions.h"
 
 import BasicTypes ( IPName )
-import TcErrors
 import TcRnTypes
 import TcType
 import Type
@@ -26,7 +26,6 @@ import TypeRep
 import Name ( Name )
 import Var
 import VarEnv
--- import Util( equalLength )
 import Outputable
 import Control.Monad    ( when, unless )
 import MonadUtils
@@ -37,6 +36,9 @@ import VarSet
 import TcSMonad
 import FastString
 
+import Util ( equalLength )
+
+
 import TysWiredIn ( eqTyCon )
 
 import Data.Maybe ( isJust, fromMaybe )
@@ -258,7 +260,7 @@ canIP d fl nm ty
   =    -- Note [Canonical implicit parameter constraints] explains why it's 
        -- possible in principle to not flatten, but since flattening applies 
        -- the inert substitution we choose to flatten anyway.
-    do { (xi,co) <- flatten d fl (mkIPPred nm ty)
+    do { (xi,co) <- flatten d FMFullFlatten fl (mkIPPred nm ty)
        ; mb <- rewriteCtFlavor fl xi co 
        ; case mb of
             Just new_fl -> let IPPred _ xi_in = classifyPredType xi
@@ -304,7 +306,7 @@ canClassNC d fl cls tys
 
 canClass d fl cls tys
   = do { -- sctx <- getTcSContext
-       ; (xis, cos) <- flattenMany d fl tys
+       ; (xis, cos) <- flattenMany d FMFullFlatten fl tys
        ; let co = mkTcTyConAppCo (classTyCon cls) cos 
              xi = mkClassPred cls xis
              
@@ -458,7 +460,7 @@ canIrred :: SubGoalDepth -- Depth
 -- Precondition: ty not a tuple and no other evidence form
 canIrred d fl ty 
   = do { traceTcS "can_pred" (text "IrredPred = " <+> ppr ty) 
-       ; (xi,co) <- flatten d fl ty -- co :: xi ~ ty
+       ; (xi,co) <- flatten d FMFullFlatten fl ty -- co :: xi ~ ty
        ; let no_flattening = xi `eqType` ty 
                              -- In this particular case it is not safe to 
                              -- say 'isTcReflCo' because the new constraint may
@@ -485,7 +487,8 @@ Note [Flattening]
 ~~~~~~~~~~~~~~~~~~~~
   flatten ty  ==>   (xi, cc)
     where
-      xi has no type functions
+      xi has no type functions, unless they appear under ForAlls
+
       cc = Auxiliary given (equality) constraints constraining
            the fresh type variables in xi.  Evidence for these 
            is always the identity coercion, because internally the
@@ -522,17 +525,21 @@ unexpanded synonym.
 
 \begin{code}
 
+data FlattenMode = FMSubstOnly 
+                 | FMFullFlatten
+
 -- Flatten a bunch of types all at once.
 flattenMany :: SubGoalDepth -- Depth
+            -> FlattenMode
             -> CtFlavor -> [Type] -> TcS ([Xi], [TcCoercion])
 -- Coercions :: Xi ~ Type 
 -- Returns True iff (no flattening happened)
 -- NB: The EvVar inside the flavor is unused, we merely want Given/Solved/Derived/Wanted info
-flattenMany d ctxt tys 
+flattenMany d f ctxt tys 
   = -- pprTrace "flattenMany" empty $
     go tys 
   where go []       = return ([],[])
-        go (ty:tys) = do { (xi,co)    <- flatten d ctxt ty
+        go (ty:tys) = do { (xi,co)    <- flatten d f ctxt ty
                          ; (xis,cos)  <- go tys
                          ; return (xi:xis,co:cos) }
 
@@ -540,33 +547,34 @@ flattenMany d ctxt tys
 -- the new type-function-free type, and a collection of new equality
 -- constraints.  See Note [Flattening] for more detail.
 flatten :: SubGoalDepth -- Depth
+        -> FlattenMode 
         -> CtFlavor -> TcType -> TcS (Xi, TcCoercion)
 -- Postcondition: Coercion :: Xi ~ TcType
-flatten d ctxt ty 
+flatten d f ctxt ty 
   | Just ty' <- tcView ty
-  = do { (xi, co) <- flatten d ctxt ty'
+  = do { (xi, co) <- flatten d f ctxt ty'
        ; return (xi,co) } 
 
-flatten _ _ xi@(LitTy {}) = return (xi, mkTcReflCo xi)
+flatten _ _ _ xi@(LitTy {}) = return (xi, mkTcReflCo xi)
 
-flatten d ctxt (TyVarTy tv)
-  = flattenTyVar d ctxt tv
+flatten d f ctxt (TyVarTy tv)
+  = flattenTyVar d f ctxt tv
 
-flatten d ctxt (AppTy ty1 ty2)
-  = do { (xi1,co1) <- flatten d ctxt ty1
-       ; (xi2,co2) <- flatten d ctxt ty2
+flatten d f ctxt (AppTy ty1 ty2)
+  = do { (xi1,co1) <- flatten d f ctxt ty1
+       ; (xi2,co2) <- flatten d f ctxt ty2
        ; return (mkAppTy xi1 xi2, mkTcAppCo co1 co2) }
 
-flatten d ctxt (FunTy ty1 ty2)
-  = do { (xi1,co1) <- flatten d ctxt ty1
-       ; (xi2,co2) <- flatten d ctxt ty2
+flatten d f ctxt (FunTy ty1 ty2)
+  = do { (xi1,co1) <- flatten d f ctxt ty1
+       ; (xi2,co2) <- flatten d f ctxt ty2
        ; return (mkFunTy xi1 xi2, mkTcFunCo co1 co2) }
 
-flatten d fl (TyConApp tc tys)
+flatten d f fl (TyConApp tc tys)
   -- For a normal type constructor or data family application, we just
   -- recursively flatten the arguments.
   | not (isSynFamilyTyCon tc)
-    = do { (xis,cos) <- flattenMany d fl tys
+    = do { (xis,cos) <- flattenMany d f fl tys
          ; return (mkTyConApp tc xis, mkTcTyConAppCo tc cos) }
 
   -- Otherwise, it's a type function application, and we have to
@@ -574,7 +582,7 @@ flatten d fl (TyConApp tc tys)
   -- between the application and a newly generated flattening skolem variable.
   | otherwise
   = ASSERT( tyConArity tc <= length tys )	-- Type functions are saturated
-      do { (xis, cos) <- flattenMany d fl tys
+      do { (xis, cos) <- flattenMany d f 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
@@ -582,30 +590,34 @@ flatten d fl (TyConApp tc tys)
                fam_ty = mkTyConApp tc xi_args
                
          ; (ret_co, rhs_xi, ct) <-
-             do { flat_cache <- getFlatCache
-                ; case lookupTM fam_ty flat_cache of
-                    Just ct 
-                      | cc_flavor ct `canRewrite` fl 
-                        -> -- You may think that we can just return (cc_rhs ct) but not so. 
-                           --            return (mkTcCoVarCo (ctId ct), cc_rhs ct, []) 
-                           -- The cached constraint resides in the cache so we have to flatten 
-                           -- the rhs to make sure we have applied any inert substitution to it.
-                           -- Alternatively we could be applying the inert substitution to the 
-                           -- cache as well when we interact an equality with the inert. 
-                           -- The design choice is: do we keep the flat cache rewritten or not?
-                           -- For now I say we don't keep it fully rewritten.
-                          do { traceTcS "flatten/flat-cache hit" $ ppr ct
-                             ; let rhs_xi = cc_rhs ct
-                             ; (flat_rhs_xi,co) <- flatten (cc_depth ct) (cc_flavor ct) rhs_xi
-                             ; let final_co = mkTcCoVarCo (ctId ct) `mkTcTransCo` (mkTcSymCo co)
-                             ; return (final_co, flat_rhs_xi,[]) }
+             case f of 
+               FMSubstOnly -> 
+                 return (mkTcReflCo fam_ty, fam_ty, [])
+               FMFullFlatten -> 
+                 do { flat_cache <- getFlatCache
+                    ; case lookupTM fam_ty flat_cache of
+                        Just ct 
+                          | cc_flavor ct `canRewrite` fl 
+                          -> -- You may think that we can just return (cc_rhs ct) but not so. 
+                             --            return (mkTcCoVarCo (ctId ct), cc_rhs ct, []) 
+                             -- The cached constraint resides in the cache so we have to flatten 
+                             -- the rhs to make sure we have applied any inert substitution to it.
+                             -- Alternatively we could be applying the inert substitution to the 
+                             -- cache as well when we interact an equality with the inert. 
+                             -- The design choice is: do we keep the flat cache rewritten or not?
+                             -- For now I say we don't keep it fully rewritten.
+                            do { traceTcS "flatten/flat-cache hit" $ ppr ct
+                               ; let rhs_xi = cc_rhs ct
+                               ; (flat_rhs_xi,co) <- flatten (cc_depth ct) f (cc_flavor ct) rhs_xi
+                               ; let final_co = mkTcCoVarCo (ctId ct) `mkTcTransCo` (mkTcSymCo co)
+                               ; return (final_co, flat_rhs_xi,[]) }
                           
-                    _ | isGivenOrSolved fl -- Given or Solved: make new flatten skolem
-                        -> do { traceTcS "flatten/flat-cache miss" $ empty 
-                              ; rhs_xi_var <- newFlattenSkolemTy fam_ty
-                              ; mg <- newGivenEvVar (mkTcEqPred fam_ty rhs_xi_var) 
-                                                   (EvCoercion (mkTcReflCo fam_ty)) 
-                              ; case mg of 
+                        _ | isGivenOrSolved fl -- Given or Solved: make new flatten skolem
+                          -> do { traceTcS "flatten/flat-cache miss" $ empty 
+                                ; rhs_xi_var <- newFlattenSkolemTy fam_ty
+                                ; mg <- newGivenEvVar (mkTcEqPred fam_ty rhs_xi_var) 
+                                                      (EvCoercion (mkTcReflCo fam_ty)) 
+                                ; case mg of 
                                    Fresh eqv -> 
                                      do { let new_fl = Given (flav_gloc fl) eqv
                                               ct = CFunEqCan { cc_flavor = new_fl
@@ -617,11 +629,11 @@ flatten d fl (TyConApp tc tys)
                                         ; updFlatCache ct
                                         ; return (mkTcCoVarCo eqv, rhs_xi_var, [ct]) }
                                    Cached {} -> panic "flatten TyConApp, var must be fresh!" }
-                      | otherwise -- Wanted or Derived: make new unification variable
-                        -> do { traceTcS "flatten/flat-cache miss" $ empty 
-                              ; rhs_xi_var <- newFlexiTcSTy (typeKind fam_ty)
-                              ; mw <- newWantedEvVar (mkTcEqPred fam_ty rhs_xi_var)
-                              ; case mw of
+                         | otherwise -- Wanted or Derived: make new unification variable
+                         -> do { traceTcS "flatten/flat-cache miss" $ empty 
+                               ; rhs_xi_var <- newFlexiTcSTy (typeKind fam_ty)
+                               ; mw <- newWantedEvVar (mkTcEqPred fam_ty rhs_xi_var)
+                               ; case mw of
                                    Fresh eqv -> 
                                      do { let new_fl = Wanted (flav_wloc fl) eqv
                                               ct = CFunEqCan { cc_flavor = new_fl
@@ -633,7 +645,7 @@ flatten d fl (TyConApp tc tys)
                                         ; updFlatCache ct
                                         ; return (mkTcCoVarCo eqv, rhs_xi_var, [ct]) }
                                    Cached {} -> panic "flatten TyConApp, var must be fresh!" } 
-                }
+                    }
                   -- Emit the flat constraints
          ; updWorkListTcS $ appendWorkListEqs ct
          ; let (cos_args, cos_rest) = splitAt (tyConArity tc) cos
@@ -644,12 +656,16 @@ flatten d fl (TyConApp tc tys)
                   ) 
          }
 
-flatten d ctxt ty@(ForAllTy {})
+flatten d _f ctxt ty@(ForAllTy {})
 -- We allow for-alls when, but only when, no type function
 -- applications inside the forall involve the bound type variables.
   = do { let (tvs, rho) = splitForAllTys ty
+       ; (rho', co) <- flatten d FMSubstOnly ctxt rho
+       ; return (mkForAllTys tvs rho', foldr mkTcForAllCo co tvs) }
+                      {- DELETEME  
        ; when (under_families tvs rho) $ wrapErrTcS $ flattenForAllErrorTcS ctxt ty
-       ; (rho', co) <- flatten d ctxt rho
+       ; (rho', co) <- flatten d FMSubstOnly ctxt rho
+                       -- Only do substitutions, not flattening under ForAlls
        ; return (mkForAllTys tvs rho', foldr mkTcForAllCo co tvs) }
 
 -- DV: Simon and I have a better plan here related to #T5934 and that plan is to 
@@ -670,18 +686,22 @@ flatten d ctxt ty@(ForAllTy {})
                   go bound (FunTy arg res)  = go bound arg || go bound res
                   go bound (AppTy fun arg)  = go bound fun || go bound arg
                   go bound (ForAllTy tv ty) = go (bound `extendVarSet` tv) ty
+-}
+
 \end{code}
 
 \begin{code}
-flattenTyVar :: SubGoalDepth -> CtFlavor -> TcTyVar -> TcS (Xi, TcCoercion)
+flattenTyVar :: SubGoalDepth 
+             -> FlattenMode 
+             -> CtFlavor -> TcTyVar -> TcS (Xi, TcCoercion)
 -- "Flattening" a type variable means to apply the substitution to it
-flattenTyVar d ctxt tv
+flattenTyVar d f ctxt tv
   = do { ieqs <- getInertEqs
        ; let mco = tv_eq_subst (fst ieqs) tv  -- co : v ~ ty
        ; case mco of -- Done, but make sure the kind is zonked
            Nothing -> 
                do { let knd = tyVarKind tv
-                  ; (new_knd,_kind_co) <- flatten d ctxt knd
+                  ; (new_knd,_kind_co) <- flatten d f ctxt knd
                   ; let ty = mkTyVarTy (setVarType tv new_knd)
                   ; return (ty, mkTcReflCo ty) }
            -- NB recursive call. 
@@ -689,7 +709,7 @@ flattenTyVar d ctxt tv
            -- In fact, because of flavors, it couldn't possibly be idempotent,
            -- this is explained in Note [Non-idempotent inert substitution]
            Just (co,ty) -> 
-               do { (ty_final,co') <- flatten d ctxt ty
+               do { (ty_final,co') <- flatten d f ctxt ty
                   ; return (ty_final, co' `mkTcTransCo` mkTcSymCo co) } }  
   where tv_eq_subst subst tv
           | Just ct <- lookupVarEnv subst tv
@@ -820,13 +840,20 @@ canEq d fl ty1 ty2    -- e.g.  F a b ~ Maybe c
   = canEqAppTy d fl s1 t1 s2 t2
 
 canEq d fl s1@(ForAllTy {}) s2@(ForAllTy {})
- | tcIsForAllTy s1, tcIsForAllTy s2, 
-   Wanted {} <- fl 
- = canEqFailure d fl
+ | tcIsForAllTy s1, tcIsForAllTy s2
+ , Wanted loc orig_ev <- fl 
+ = do { let (tvs1,body1) = tcSplitForAllTys s1
+            (tvs2,body2) = tcSplitForAllTys s2
+      ; if not (equalLength tvs1 tvs2) then 
+          canEqFailure d fl
+        else
+          do { traceTcS "Creating implication for polytype equality" $ ppr fl
+             ; deferTcSForAllEq (loc,orig_ev) (tvs1,body1) (tvs2,body2) 
+             ; return Stop } }
  | otherwise
- = do { traceTcS "Ommitting decomposition of given polytype equality" (pprEq s1 s2)
+ = do { traceTcS "Ommitting decomposition of given polytype equality" $ 
+        pprEq s1 s2
       ; return Stop }
-
 canEq d fl _ _  = canEqFailure d fl
 
 ------------------------
@@ -1168,8 +1195,8 @@ canEqLeafFunEqLeftRec d fl (fn,tys1) ty2  -- fl :: F tys1 ~ ty2
   = do { traceTcS "canEqLeafFunEqLeftRec" $ pprEq (mkTyConApp fn tys1) ty2
        ; (xis1,cos1) <- 
            {-# SCC "flattenMany" #-}
-           flattenMany d fl tys1 -- Flatten type function arguments
-                                 -- cos1 :: xis1 ~ tys1
+           flattenMany d FMFullFlatten fl tys1 -- Flatten type function arguments
+                                               -- cos1 :: xis1 ~ tys1
            
        ; let fam_head = mkTyConApp fn xis1
          -- Fancy higher-dimensional coercion between equalities!
@@ -1194,7 +1221,7 @@ canEqLeafFunEqLeft d fl (fn,xis1) s2
    do { traceTcS "canEqLeafFunEqLeft" $ pprEq (mkTyConApp fn xis1) s2
       ; (xi2,co2) <- 
           {-# SCC "flatten" #-} 
-          flatten d fl s2 -- co2 :: xi2 ~ s2
+          flatten d FMFullFlatten fl s2 -- co2 :: xi2 ~ s2
           
       ; let fam_head = mkTyConApp fn xis1
       -- Fancy coercion between equalities! But it should just work! 
@@ -1216,7 +1243,7 @@ canEqLeafTyVarLeftRec :: SubGoalDepth
                       -> TcTyVar -> TcType -> TcS StopOrContinue
 canEqLeafTyVarLeftRec d fl tv s2              -- fl :: tv ~ s2
   = do {  traceTcS "canEqLeafTyVarLeftRec" $ pprEq (mkTyVarTy tv) s2
-       ; (xi1,co1) <- flattenTyVar d fl tv -- co1 :: xi1 ~ tv        
+       ; (xi1,co1) <- flattenTyVar d FMFullFlatten fl tv -- co1 :: xi1 ~ tv
        ; let is_still_var = isJust (getTyVar_maybe xi1) 
        
        ; traceTcS "canEqLeafTyVarLeftRec2" $ empty 
@@ -1243,8 +1270,8 @@ canEqLeafTyVarLeft :: SubGoalDepth -- Depth
 canEqLeafTyVarLeft d fl tv s2       -- eqv : tv ~ s2
   = do { let tv_ty = mkTyVarTy tv
        ; traceTcS "canEqLeafTyVarLeft" (pprEq tv_ty s2)
-       ; (xi2, co2) <- flatten d fl s2   -- Flatten RHS   co : xi2 ~ s2
-                                                                 
+       ; (xi2, co2) <- flatten d FMFullFlatten fl s2 -- Flatten RHS co:xi2 ~ s2 
+                       
        ; traceTcS "canEqLeafTyVarLeft" (nest 2 (vcat [ text "tv  =" <+> ppr tv
                                                      , text "s2  =" <+> ppr s2
                                                      , text "xi2 =" <+> ppr xi2]))
diff --git a/compiler/typecheck/TcEvidence.lhs b/compiler/typecheck/TcEvidence.lhs
index 571643c9f8..8ec0a5766b 100644
--- a/compiler/typecheck/TcEvidence.lhs
+++ b/compiler/typecheck/TcEvidence.lhs
@@ -473,7 +473,7 @@ data EvTerm
 
   | EvKindCast EvVar TcCoercion  -- See Note [EvKindCast]
 
-  | EvLit EvLit                  -- The dictionary for class "NatI"
+  | EvLit EvLit                  -- Dictionary for class "SingI" for type lits.
                                  -- Note [EvLit]
 
   deriving( Data.Data, Data.Typeable)
@@ -519,33 +519,39 @@ Conclusion: a new wanted coercion variable should be made mutable.
 
 Note [EvLit]
 ~~~~~~~~~~~~
-A part of the type-level naturals implementation is the class "NatI",
+A part of the type-level literals implementation is the class "SingI",
 which provides a "smart" constructor for defining singleton values.
 
-newtype TNat (n :: Nat) = TNat Integer
+newtype Sing n = Sing (SingRep n)
 
-class NatI n where
-  tNat :: TNat n
+class SingI n where
+  sing :: Sing n
+
+type family SingRep a
+type instance SingRep (a :: Nat)    = Integer
+type instance SingRep (a :: Symbol) = String
 
 Conceptually, this class has infinitely many instances:
 
-instance NatI 0 where natS = TNat 0
-instance NatI 1 where natS = TNat 1
-instance NatI 2 where natS = TNat 2
+instance Sing 0       where sing = Sing 0
+instance Sing 1       where sing = Sing 1
+instance Sing 2       where sing = Sing 2
+instance Sing "hello" where sing = Sing "hello"
 ...
 
-In practice, we solve "NatI" predicates in the type-checker because we can't
+In practice, we solve "SingI" predicates in the type-checker because we can't
 have infinately many instances.  The evidence (aka "dictionary")
-for "NatI n" is of the form "EvLit (EvNum n)".
+for "SingI (n :: Nat)" is of the form "EvLit (EvNum n)".
 
 We make the following assumptions about dictionaries in GHC:
-  1. The "dictionary" for classes with a single method---like NatI---is
+  1. The "dictionary" for classes with a single method---like SingI---is
      a newtype for the type of the method, so using a evidence amounts
      to a coercion, and
   2. Newtypes use the same representation as their definition types.
 
-So, the evidence for "NatI" is just an integer wrapped in 2 newtypes:
-one to make it into a "TNat" value, and another to make it into "NatI" evidence.
+So, the evidence for "SingI" is just a value of the representation type,
+wrapped in two newtype constructors: one to make it into a "Sing" value,
+and another to make it into "SingI" evidence.
 
 
 \begin{code}
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 64b839c83f..b7c953d2f7 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -836,7 +836,7 @@ mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id
             ; inst_sigs <- xoptM Opt_InstanceSigs
             ; if inst_sigs then 
                 checkTc (sig_ty `eqType` local_meth_ty)
-                        (badInstSigErr sel_name sig_ty) 
+                        (badInstSigErr sel_name local_meth_ty)
               else
                 addErrTc (misplacedInstSig sel_name hs_ty)
             ; return sig_ty }
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index 01dcda803a..a2e0b993ed 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -26,7 +26,7 @@ import Id
 import Var
 
 import TcType
-import PrelNames (typeNatClassName, typeStringClassName)
+import PrelNames (singIClassName)
 
 import Class
 import TyCon
@@ -91,12 +91,21 @@ If in Step 1 no such element exists, we have exceeded our context-stack
 depth and will simply fail.
 \begin{code}
 
-solveInteractCts :: [Ct] -> TcS ()
+solveInteractCts :: [Ct] -> TcS (Bag Implication)
+-- Returns a bag of residual implications that have arisen while solving
+-- this particular worklist.
 solveInteractCts cts 
   = do { traceTcS "solveInteractCtS" (vcat [ text "cts =" <+> ppr cts ]) 
-       ; updWorkListTcS (appendWorkListCt cts) >> solveInteract }
-
-solveInteractGiven :: GivenLoc -> [EvVar] -> TcS () 
+       ; updWorkListTcS (appendWorkListCt cts) >> solveInteract 
+       ; impls <- getTcSImplics
+       ; updTcSImplics (const emptyBag) -- Nullify residual implications
+       ; return impls }
+
+solveInteractGiven :: GivenLoc -> [EvVar] -> TcS (Bag Implication)
+-- In principle the givens can kick out some wanteds from the inert
+-- resulting in solving some more wanted goals here which could emit
+-- implications. That's why I return a bag of implications. Not sure
+-- if this can happen in practice though.
 solveInteractGiven gloc evs
   = solveInteractCts (map mk_noncan evs)
   where mk_noncan ev = CNonCanonical { cc_flavor = Given gloc ev
@@ -1614,9 +1623,9 @@ lkpFunEqCache fam_head
                                            , cc_fun = tc, cc_tyargs = xis
                                            , cc_rhs = xi}))
           = ASSERT (isSolved fl)
-            do { (xis_subst,cos) <- flattenMany d fl xis 
+            do { (xis_subst,cos) <- flattenMany d FMFullFlatten fl xis 
                                     -- cos :: xis_subst ~ xis 
-               ; (xi_subst,co) <- flatten d fl xi
+               ; (xi_subst,co) <- flatten d FMFullFlatten fl xi
                                     -- co :: xi_subst ~ xi
                ; let flat_fam_head = mkTyConApp tc xis_subst 
 
@@ -1865,11 +1874,11 @@ data LookupInstResult
 
 matchClassInst :: InertSet -> Class -> [Type] -> WantedLoc -> TcS LookupInstResult
 
-matchClassInst _ clas [ ty ] _
-  | className clas == typeNatClassName
+matchClassInst _ clas [ _, ty ] _
+  | className clas == singIClassName
   , Just n <- isNumLitTy ty = return $ GenInst [] $ EvLit $ EvNum n
 
-  | className clas == typeStringClassName
+  | className clas == singIClassName
   , Just s <- isStrLitTy ty = return $ GenInst [] $ EvLit $ EvStr s
 
 
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index f480bab3fa..6a79b738fd 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -831,10 +831,15 @@ instance Outputable WhereFrom where
 
 
 \begin{code}
--- Types without any type functions inside.  However, note that xi
--- types CAN contain unexpanded type synonyms; however, the
--- (transitive) expansions of those type synonyms will not contain any
--- type functions.
+-- The syntax of xi types:
+-- xi ::= a | T xis | xis -> xis | ... | forall a. tau
+-- Two important notes:
+--      (i) No type families, unless we are under a ForAll
+--      (ii) Note that xi types can contain unexpanded type synonyms; 
+--           however, the (transitive) expansions of those type synonyms 
+--           will not contain any type functions, unless we are under a ForAll.
+-- We enforce the structure of Xi types when we flatten (TcCanonical)
+
 type Xi = Type       -- In many comments, "xi" ranges over Xi
 
 type Cts = Bag Ct
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 33a049e9b0..b3a64e3b14 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -18,6 +18,8 @@ module TcSMonad (
 
     getTcSWorkList, updWorkListTcS, updWorkListTcS_return, keepWanted,
     getTcSWorkListTvs, 
+    
+    getTcSImplics, updTcSImplics, emitTcSImplication, 
 
     Ct(..), Xi, tyVarsOfCt, tyVarsOfCts, tyVarsOfCDicts, 
     emitFrozenError,
@@ -42,6 +44,7 @@ module TcSMonad (
     -- Getting and setting the flattening cache
     getFlatCache, updFlatCache, addToSolved, 
     
+    deferTcSForAllEq, 
     
     setEvBind,
     XEvTerm(..),
@@ -136,6 +139,7 @@ import Unique
 import UniqFM
 import Maybes ( orElse )
 
+
 import Control.Monad( when )
 import StaticFlags( opt_PprStyle_Debug )
 import Data.IORef
@@ -783,8 +787,11 @@ data TcSEnv
       tcs_count      :: IORef Int, -- Global step count
 
       tcs_inerts   :: IORef InertSet, -- Current inert set
-      tcs_worklist :: IORef WorkList  -- Current worklist
-
+      tcs_worklist :: IORef WorkList, -- Current worklist
+      
+      -- Residual implication constraints that are generated 
+      -- while solving the current worklist.
+      tcs_implics  :: IORef (Bag Implication)
     }
 
 type TcsUntouchables = (Untouchables,TcTyVarSet)
@@ -884,6 +891,7 @@ runTcS :: SimplContext
 runTcS context untouch is wl tcs 
   = do { ty_binds_var <- TcM.newTcRef emptyVarEnv
        ; ev_binds_var <- TcM.newTcEvBinds
+       ; impl_var <- TcM.newTcRef emptyBag
        ; step_count <- TcM.newTcRef 0
 
        ; inert_var <- TcM.newTcRef is 
@@ -896,7 +904,8 @@ runTcS context untouch is wl tcs
 			  , tcs_count    = step_count
 			  , tcs_ic_depth = 0
                           , tcs_inerts   = inert_var
-                          , tcs_worklist = wl_var }
+                          , tcs_worklist = wl_var 
+                          , tcs_implics  = impl_var }
 
 	     -- Run the computation
        ; res <- unTcS tcs env
@@ -930,7 +939,8 @@ nestImplicTcS ref (inner_range, inner_tcs) (TcS thing_inside)
                    , tcs_ic_depth = idepth
                    , tcs_context = ctxt
                    , tcs_inerts = inert_var
-                   , tcs_worklist = wl_var } -> 
+                   , tcs_worklist = wl_var 
+                   , tcs_implics = _impl_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 
@@ -940,6 +950,10 @@ nestImplicTcS ref (inner_range, inner_tcs) (TcS thing_inside)
          -- Inherit the inerts from the outer scope
        ; orig_inerts <- TcM.readTcRef inert_var
        ; new_inert_var <- TcM.newTcRef orig_inerts
+         -- Inherit residual implications from outer scope (?) or create
+         -- fresh var?                 
+--     ; orig_implics <- TcM.readTcRef impl_var                   
+       ; new_implics_var <- TcM.newTcRef emptyBag
                            
        ; let nest_env = TcSEnv { tcs_ev_binds    = ref
                                , tcs_ty_binds    = ty_binds
@@ -951,6 +965,7 @@ nestImplicTcS ref (inner_range, inner_tcs) (TcS thing_inside)
                                , tcs_worklist    = wl_var 
                                -- NB: worklist is going to be empty anyway, 
                                -- so reuse the same ref cell
+                               , tcs_implics     = new_implics_var
                                }
        ; thing_inside nest_env } 
 
@@ -996,6 +1011,13 @@ getTcSWorkListRef = TcS (return . tcs_worklist)
 getTcSInerts :: TcS InertSet 
 getTcSInerts = getTcSInertsRef >>= wrapTcS . (TcM.readTcRef) 
 
+
+getTcSImplicsRef :: TcS (IORef (Bag Implication))
+getTcSImplicsRef = TcS (return . tcs_implics) 
+
+getTcSImplics :: TcS (Bag Implication)
+getTcSImplics = getTcSImplicsRef >>= wrapTcS . (TcM.readTcRef)
+
 getTcSWorkList :: TcS WorkList
 getTcSWorkList = getTcSWorkListRef >>= wrapTcS . (TcM.readTcRef) 
 
@@ -1020,6 +1042,18 @@ updWorkListTcS_return f
        ; let (res,new_work) = f wl_curr
        ; wrapTcS (TcM.writeTcRef wl_var new_work)
        ; return res }
+    
+
+updTcSImplics :: (Bag Implication -> Bag Implication) -> TcS ()
+updTcSImplics f 
+ = do { impl_ref <- getTcSImplicsRef
+      ; implics <- wrapTcS (TcM.readTcRef impl_ref)
+      ; let new_implics = f implics
+      ; wrapTcS (TcM.writeTcRef impl_ref new_implics) }
+
+emitTcSImplication :: Implication -> TcS ()
+emitTcSImplication imp = updTcSImplics (consBag imp)
+
 
 emitFrozenError :: CtFlavor -> SubGoalDepth -> TcS ()
 -- Emits a non-canonical constraint that will stand for a frozen error in the inerts. 
@@ -1486,6 +1520,54 @@ matchFam :: TyCon -> [Type] -> TcS (Maybe (FamInst, [Type]))
 matchFam tycon args = wrapTcS $ tcLookupFamInst tycon args
 \end{code}
 
+\begin{code}
+-- Deferring forall equalities as implications
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+deferTcSForAllEq :: (WantedLoc,EvVar)  -- Original wanted equality flavor
+                 -> ([TyVar],TcType)   -- ForAll tvs1 body1
+                 -> ([TyVar],TcType)   -- ForAll tvs2 body2
+                 -> TcS ()
+-- Some of this functionality is repeated from TcUnify, 
+-- consider having a single place where we create fresh implications. 
+deferTcSForAllEq (loc,orig_ev) (tvs1,body1) (tvs2,body2)
+ = do { (subst1, skol_tvs) <- wrapTcS $ TcM.tcInstSkolTyVars tvs1
+      ; let tys  = mkTyVarTys skol_tvs
+            phi1 = Type.substTy subst1 body1
+            phi2 = Type.substTy (zipTopTvSubst tvs2 tys) body2
+            skol_info = UnifyForAllSkol skol_tvs phi1
+        ; mev <- newWantedEvVar (mkTcEqPred phi1 phi2)
+        ; let new_fl = Wanted loc (mn_thing mev)
+              new_ct = mkNonCanonical new_fl
+              new_co = mkTcCoVarCo (mn_thing mev)
+        ; coe_inside <- if isFresh mev then
+                           do { ev_binds_var <- wrapTcS $ TcM.newTcEvBinds
+                              ; let ev_binds = TcEvBinds ev_binds_var
+                              ; lcl_env <- wrapTcS $ TcM.getLclTypeEnv
+                              ; loc <- wrapTcS $ TcM.getCtLoc skol_info
+                              ; let wc = WC { wc_flat  = singleCt new_ct 
+                                            , wc_impl  = emptyBag
+                                            , wc_insol = emptyCts }
+                                    imp = Implic { ic_untch  = all_untouchables
+                                                 , ic_env    = lcl_env
+                                                 , ic_skols  = skol_tvs
+                                                 , ic_given  = []
+                                                 , ic_wanted = wc 
+                                                 , ic_insol  = False
+                                                 , ic_binds  = ev_binds_var
+                                                 , ic_loc    = loc }
+                           ; updTcSImplics (consBag imp) 
+                           ; return (TcLetCo ev_binds new_co) }
+                        else (return new_co)
+        ; setEvBind orig_ev $
+          EvCoercion (foldr mkTcForAllCo coe_inside skol_tvs)
+        }
+ where all_untouchables = TouchableRange u u
+       u = idUnique orig_ev -- HACK: empty range
+
+\end{code}
+
+
 
 -- Rewriting with respect to the inert equalities 
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 3c3c7f7299..26d4c9f124 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -384,8 +384,9 @@ simplifyWithApprox wanted
  = do { traceTcS "simplifyApproxLoop" (ppr wanted)
 
       ; let all_flats = wc_flat wanted `unionBags` keepWanted (wc_insol wanted) 
-      ; solveInteractCts $ bagToList all_flats
-      ; unsolved_implics <- simpl_loop 1 (wc_impl wanted)
+      ; implics_from_flats <- solveInteractCts $ bagToList all_flats
+      ; unsolved_implics <- simpl_loop 1 (wc_impl wanted `unionBags` 
+                                               implics_from_flats)
 
       ; let (residual_implics,floats) = approximateImplications unsolved_implics
 
@@ -777,11 +778,11 @@ solve_wanteds wanted@(WC { wc_flat = flats, wc_impl = implics, wc_insol = insols
                  -- wrong anyway!
 
        ; let all_flats = flats `unionBags` keepWanted insols
-       ; solveInteractCts $ bagToList all_flats
+       ; impls_from_flats <- solveInteractCts $ bagToList all_flats
 
        -- solve_wanteds iterates when it is able to float equalities 
        -- out of one or more of the implications. 
-       ; unsolved_implics <- simpl_loop 1 implics
+       ; unsolved_implics <- simpl_loop 1 (implics `unionBags` impls_from_flats)
 
        ; (insoluble_flats,unsolved_flats) <- extractUnsolvedTcS 
 
@@ -832,8 +833,9 @@ simpl_loop n implics
                   , text "unsolved_implics =" <+> ppr unsolved_implics ]
 
        ; if isEmptyBag improve_eqs then return unsolved_implics 
-         else do { solveInteractCts $ bagToList improve_eqs
-                 ; simpl_loop (n+1) unsolved_implics } }
+         else do { impls_from_eqs <- solveInteractCts $ bagToList improve_eqs
+                 ; simpl_loop (n+1) (unsolved_implics `unionBags` 
+                                                 impls_from_eqs)} }
 
 solveNestedImplications :: Bag Implication
                         -> TcS (Cts, Bag Implication)
@@ -855,7 +857,9 @@ solveNestedImplications implics
 	         -- Push the unsolved wanteds inwards, but as givens
                  ; traceTcS "solveWanteds: preparing inerts for implications {" $ 
                    vcat [ppr tcs_untouchables, ppr pushed_givens]
-                 ; solveInteractCts pushed_givens 
+                 ; impls_from_givens <- solveInteractCts pushed_givens 
+                 ; MASSERT (isEmptyBag impls_from_givens)
+                   
                  ; traceTcS "solveWanteds: } now doing nested implications {" empty
                  ; flatMapBagPairM (solveImplication tcs_untouchables) implics }
 
@@ -904,8 +908,9 @@ solveImplication tcs_untouchables
     do { traceTcS "solveImplication {" (ppr imp) 
 
          -- Solve flat givens
-       ; solveInteractGiven loc givens 
-
+       ; impls_from_givens <- solveInteractGiven loc givens 
+       ; MASSERT (isEmptyBag impls_from_givens)
+         
          -- Simplify the wanteds
        ; WC { wc_flat = unsolved_flats
             , wc_impl = unsolved_implics
@@ -1395,8 +1400,13 @@ disambigGroup (default_ty:default_tys) group
                                       in return [ CNonCanonical { cc_flavor = dfl, cc_depth = 0 } ] }
                             
                        ; traceTcS "disambigGroup (solving) {" 
-                                  (text "trying to solve constraints along with default equations ...") 
-                       ; solveInteractCts (derived_eq ++ wanteds)
+                                  (text "trying to solve constraints along with default equations ...")
+                       ; implics_from_defaulting <- 
+                                    solveInteractCts (derived_eq ++ wanteds)
+                       ; MASSERT (isEmptyBag implics_from_defaulting)
+                                     -- Ignore implics: I don't think that a defaulting equation can cause
+                                     -- new implications to be emitted. Maybe we have to revisit this.
+                                     
                        ; (_,unsolved) <- extractUnsolvedTcS 
                        ; traceTcS "disambigGroup (solving) }"
                                   (text "disambigGroup unsolved =" <+> ppr (keepWanted unsolved))
diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs
index 0fb206ca77..faaa62898e 100644
--- a/compiler/utils/Panic.lhs
+++ b/compiler/utils/Panic.lhs
@@ -24,15 +24,15 @@ module Panic (
      
      Exception.Exception(..), showException, safeShowException, try, tryMost, throwTo,
 
-     installSignalHandlers, interruptTargetThread
+     installSignalHandlers,
+     pushInterruptTargetThread, popInterruptTargetThread
 ) where
 #include "HsVersions.h"
 
 import Config
 import FastTypes
 import Exception
-import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar, modifyMVar_,
-                            myThreadId )
+import Control.Concurrent
 import Data.Dynamic
 import Debug.Trace	  ( trace )
 import System.IO.Unsafe
@@ -51,7 +51,11 @@ import GHC.ConsoleHandler
 import GHC.Stack
 #endif
 
--- | GHC's own exception type 
+#if __GLASGOW_HASKELL__ >= 705
+import System.Mem.Weak  ( Weak, deRefWeak )
+#endif
+
+-- | GHC's own exception type
 --   error messages all take the form:
 --
 --  @
@@ -233,16 +237,16 @@ tryMost action = do r <- try action
 installSignalHandlers :: IO ()
 installSignalHandlers = do
   main_thread <- myThreadId
-  modifyMVar_ interruptTargetThread (return . (main_thread :))
+  pushInterruptTargetThread main_thread
 
   let
       interrupt_exn = (toException UserInterrupt)
 
       interrupt = do
-	withMVar interruptTargetThread $ \targets ->
-	  case targets of
-	   [] -> return ()
-	   (thread:_) -> throwTo thread interrupt_exn
+        mt <- popInterruptTargetThread
+        case mt of
+          Nothing -> return ()
+          Just t  -> throwTo t interrupt_exn
 
   --
 #if !defined(mingw32_HOST_OS)
@@ -268,8 +272,41 @@ installSignalHandlers = do
   return ()
 #endif
 
+#if __GLASGOW_HASKELL__ >= 705
+{-# NOINLINE interruptTargetThread #-}
+interruptTargetThread :: MVar [Weak ThreadId]
+interruptTargetThread = unsafePerformIO (newMVar [])
+
+pushInterruptTargetThread :: ThreadId -> IO ()
+pushInterruptTargetThread tid = do
+ wtid <- mkWeakThreadId tid
+ modifyMVar_ interruptTargetThread $
+   return . (wtid :)
+
+popInterruptTargetThread :: IO (Maybe ThreadId)
+popInterruptTargetThread =
+  modifyMVar interruptTargetThread $ loop
+ where
+   loop [] = return ([], Nothing)
+   loop (t:ts) = do
+     r <- deRefWeak t
+     case r of
+       Nothing -> loop ts
+       Just t  -> return (ts, Just t)
+#else
 {-# NOINLINE interruptTargetThread #-}
 interruptTargetThread :: MVar [ThreadId]
 interruptTargetThread = unsafePerformIO (newMVar [])
 
+pushInterruptTargetThread :: ThreadId -> IO ()
+pushInterruptTargetThread tid = do
+ modifyMVar_ interruptTargetThread $
+   return . (tid :)
+
+popInterruptTargetThread :: IO (Maybe ThreadId)
+popInterruptTargetThread =
+  modifyMVar interruptTargetThread $
+   \tids -> return $! case tids of [] -> ([], Nothing)
+                                   (t:ts) -> (ts, Just t)
+#endif
 \end{code}