Merge remote-tracking branch 'origin/master' into imp-param-clss

18 files changed, 269 insertions, 186 deletions

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 6d1520ba8a..625c17ab33 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -280,7 +280,7 @@ mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name
 mk_extra_tvs tc tvs defn
   | TyData { td_kindSig = Just hs_kind } <- defn
   = do { extra_tvs <- go hs_kind
-       ; return (mkHsQTvs (hsQTvBndrs tvs ++ extra_tvs)) }
+       ; return (tvs { hsq_tvs = hsq_tvs tvs ++ extra_tvs }) }
   | otherwise
   = return tvs
   where
@@ -360,7 +360,7 @@ repFamInstD (FamInstDecl { fid_tycon = tc_name
                                                 -- polymorphism in Template Haskell (sigh)
     do { tc <- lookupLOcc tc_name 		-- See note [Binders and occurrences]  
        ; let loc = getLoc tc_name
-             hs_tvs = mkHsQTvs (userHsTyVarBndrs loc tv_names)   -- Yuk
+             hs_tvs = HsQTvs { hsq_kvs = kv_names, hsq_tvs = userHsTyVarBndrs loc tv_names }   -- Yuk
        ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
          do { tys1 <- repLTys tys
             ; tys2 <- coreList typeQTyConName tys1
@@ -420,27 +420,30 @@ ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
 
 repC :: [Name] -> LConDecl Name -> DsM (Core TH.ConQ)
 repC _ (L _ (ConDecl { con_name = con, con_qvars = con_tvs, con_cxt = L _ []
-                       , con_details = details, con_res = ResTyH98 }))
+                     , con_details = details, con_res = ResTyH98 }))
   | null (hsQTvBndrs con_tvs)
-  = do { con1 <- lookupLOcc con 	-- See note [Binders and occurrences] 
+  = do { con1 <- lookupLOcc con 	-- See Note [Binders and occurrences] 
        ; repConstr con1 details  }
+
 repC tvs (L _ (ConDecl { con_name = con
                        , con_qvars = con_tvs, con_cxt = L _ ctxt
                        , con_details = details
                        , con_res = res_ty }))
   = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty
-       ; let ex_tvs = mkHsQTvs [ tv | tv <- hsQTvBndrs con_tvs, not (hsLTyVarName tv `in_subst` con_tv_subst)]
+       ; let ex_tvs = HsQTvs { hsq_kvs = filterOut (in_subst con_tv_subst) (hsq_kvs con_tvs)
+                             , hsq_tvs = filterOut (in_subst con_tv_subst . hsLTyVarName) (hsq_tvs con_tvs) }
+
        ; binds <- mapM dupBinder con_tv_subst 
        ; dsExtendMetaEnv (mkNameEnv binds) $     -- Binds some of the con_tvs
          addTyVarBinds ex_tvs $ \ ex_bndrs ->   -- Binds the remaining con_tvs
-    do { con1      <- lookupLOcc con 	-- See note [Binders and occurrences] 
+    do { con1      <- lookupLOcc con 	-- See Note [Binders and occurrences] 
        ; c'        <- repConstr con1 details
        ; ctxt'     <- repContext (eq_ctxt ++ ctxt)
        ; rep2 forallCName [unC ex_bndrs, unC ctxt', unC c'] } }
 
-in_subst :: Name -> [(Name,Name)] -> Bool
-in_subst _ []          = False
-in_subst n ((n',_):ns) = n==n' || in_subst n ns
+in_subst :: [(Name,Name)] -> Name -> Bool
+in_subst []          _ = False
+in_subst ((n',_):ns) n = n==n' || in_subst ns n
 
 mkGadtCtxt :: [Name]		-- Tyvars of the data type
            -> ResType (LHsType Name)
@@ -472,7 +475,7 @@ mkGadtCtxt data_tvs (ResTyGADT res_ty)
     go cxt subst ((data_tv, ty) : rest)
        | Just con_tv <- is_hs_tyvar ty
        , isTyVarName con_tv
-       , not (in_subst con_tv subst)
+       , not (in_subst subst con_tv)
        = go cxt ((con_tv, data_tv) : subst) rest
        | otherwise
        = go (eq_pred : cxt) subst rest
@@ -628,7 +631,7 @@ addTyVarBinds :: LHsTyVarBndrs Name	                       -- the binders to be
 -- meta environment and gets the *new* names on Core-level as an argument
 
 addTyVarBinds tvs m
-  = do { freshNames <- mkGenSyms (hsLTyVarNames tvs)
+  = do { freshNames <- mkGenSyms (hsLKiTyVarNames tvs)
        ; term <- addBinds freshNames $ 
 	    	 do { kbs1 <- mapM mk_tv_bndr (hsQTvBndrs tvs `zip` freshNames)
                     ; kbs2 <- coreList tyVarBndrTyConName kbs1
@@ -647,7 +650,7 @@ addTyClTyVarBinds :: LHsTyVarBndrs Name
 --      type W (T a) = blah
 -- The 'a' in the type instance is the one bound by the instance decl
 addTyClTyVarBinds tvs m
-  = do { let tv_names = hsLTyVarNames tvs
+  = do { let tv_names = hsLKiTyVarNames tvs
        ; env <- dsGetMetaEnv
        ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)
        	    -- Make fresh names for the ones that are not already in scope
diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 183960a4e8..fe4a266700 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -34,7 +34,7 @@ module HsTypes (
         
         mkHsQTvs, hsQTvBndrs,
         mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
-        hsTyVarName, hsTyVarNames, mkHsWithBndrs,
+        hsTyVarName, mkHsWithBndrs, hsLKiTyVarNames,
         hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
         splitLHsInstDeclTy_maybe,
         splitHsClassTy_maybe, splitLHsClassTy_maybe,
@@ -51,6 +51,7 @@ import HsLit
 
 import NameSet( FreeVars )
 import Name( Name )
+import RdrName( RdrName )
 import Type
 import HsDoc
 import BasicTypes
@@ -143,9 +144,14 @@ data LHsTyVarBndrs name
     }
   deriving( Data, Typeable )
 
-mkHsQTvs :: [LHsTyVarBndr name] -> LHsTyVarBndrs name
+mkHsQTvs :: [LHsTyVarBndr RdrName] -> LHsTyVarBndrs RdrName
+-- Just at RdrName because in the Name variant we should know just
+-- what the kind-variable binders are; and we don't
 mkHsQTvs tvs = HsQTvs { hsq_kvs = panic "mkHsQTvs", hsq_tvs = tvs }
 
+emptyHsQTvs :: LHsTyVarBndrs name   -- Use only when you know there are no kind binders
+emptyHsQTvs =  HsQTvs { hsq_kvs = [], hsq_tvs = [] }
+
 hsQTvBndrs :: LHsTyVarBndrs name -> [LHsTyVarBndr name]
 hsQTvBndrs = hsq_tvs
 
@@ -387,18 +393,18 @@ data ConDeclField name  -- Record fields have Haddoc docs on them
 --
 -- A valid type must have one for-all at the top of the type, or of the fn arg types
 
-mkImplicitHsForAllTy ::                        LHsContext name -> LHsType name -> HsType name
-mkExplicitHsForAllTy :: [LHsTyVarBndr name] -> LHsContext name -> LHsType name -> HsType name
+mkImplicitHsForAllTy ::                           LHsContext RdrName -> LHsType RdrName -> HsType RdrName
+mkExplicitHsForAllTy :: [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> HsType RdrName
 mkImplicitHsForAllTy     ctxt ty = mkHsForAllTy Implicit []  ctxt ty
 mkExplicitHsForAllTy tvs ctxt ty = mkHsForAllTy Explicit tvs ctxt ty
 
-mkHsForAllTy :: HsExplicitFlag -> [LHsTyVarBndr name] -> LHsContext name -> LHsType name -> HsType name
+mkHsForAllTy :: HsExplicitFlag -> [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> HsType RdrName
 -- Smart constructor for HsForAllTy
 mkHsForAllTy exp tvs (L _ []) ty = mk_forall_ty exp tvs ty
 mkHsForAllTy exp tvs ctxt     ty = HsForAllTy exp (mkHsQTvs 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 :: HsExplicitFlag -> [LHsTyVarBndr RdrName] -> LHsType RdrName -> HsType RdrName
 mk_forall_ty exp  tvs  (L _ (HsParTy ty))                    = mk_forall_ty exp tvs ty
 mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 qtvs2 ctxt ty)) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ hsq_tvs qtvs2) ctxt ty
 mk_forall_ty exp  tvs  ty                                    = HsForAllTy exp (mkHsQTvs tvs) (noLoc []) ty
@@ -425,12 +431,15 @@ hsTyVarName (KindedTyVar n _) = n
 hsLTyVarName :: LHsTyVarBndr name -> name
 hsLTyVarName = hsTyVarName . unLoc
 
-hsTyVarNames :: [HsTyVarBndr name] -> [name]
-hsTyVarNames tvs = map hsTyVarName tvs
-
 hsLTyVarNames :: LHsTyVarBndrs name -> [name]
+-- Type variables only
 hsLTyVarNames qtvs = map hsLTyVarName (hsQTvBndrs qtvs)
 
+hsLKiTyVarNames :: LHsTyVarBndrs Name -> [Name]
+-- Kind and type variables
+hsLKiTyVarNames (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs })
+  = kvs ++ map hsLTyVarName tvs
+
 hsLTyVarLocName :: LHsTyVarBndr name -> Located name
 hsLTyVarLocName = fmap hsTyVarName
 
@@ -469,7 +478,7 @@ splitLHsForAllTy poly_ty
   = case unLoc poly_ty of
         HsParTy ty              -> splitLHsForAllTy ty
         HsForAllTy _ tvs cxt ty -> (tvs, unLoc cxt, ty)
-        _                       -> (mkHsQTvs [], [], poly_ty)
+        _                       -> (emptyHsQTvs, [], poly_ty)
         -- The type vars should have been computed by now, even if they were implicit
 
 splitHsClassTy_maybe :: HsType name -> Maybe (name, [LHsType name])
diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index b4876754fa..d3d16033eb 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -170,13 +170,13 @@ rnTopBindsLHS :: MiniFixityEnv
 rnTopBindsLHS fix_env binds
   = rnValBindsLHS (topRecNameMaker fix_env) binds
 
-rnTopBindsRHS :: HsValBindsLR Name RdrName 
+rnTopBindsRHS :: NameSet -> HsValBindsLR Name RdrName 
               -> RnM (HsValBinds Name, DefUses)
-rnTopBindsRHS binds
+rnTopBindsRHS bound_names binds
   = do { is_boot <- tcIsHsBoot
        ; if is_boot 
          then rnTopBindsBoot binds
-         else rnValBindsRHS TopSigCtxt binds }
+         else rnValBindsRHS (TopSigCtxt bound_names False) binds }
 
 rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses)
 -- A hs-boot file has no bindings. 
@@ -538,7 +538,7 @@ mkSigTvFn sigs
   = \n -> lookupNameEnv env n `orElse` []
   where
     env :: NameEnv [Name]
-    env = mkNameEnv [ (name, hsLTyVarNames ltvs)
+    env = mkNameEnv [ (name, hsLKiTyVarNames ltvs)  -- Kind variables and type variables
 		    | L _ (TypeSig names
 			           (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs
                     , (L _ name) <- names]
@@ -695,8 +695,8 @@ renameSig _ (SpecInstSig ty)
 -- then the SPECIALISE pragma is ambiguous, unlike all other signatures
 renameSig ctxt sig@(SpecSig v ty inl)
   = do	{ new_v <- case ctxt of 
-                     TopSigCtxt -> lookupLocatedOccRn v
-                     _          -> lookupSigOccRn ctxt sig v
+                     TopSigCtxt {} -> lookupLocatedOccRn v
+                     _             -> lookupSigOccRn ctxt sig v
 	; (new_ty, fvs) <- rnHsSigType (quotes (ppr v)) ty
 	; return (SpecSig new_v new_ty inl, fvs) }
 
@@ -722,14 +722,14 @@ okHsSig ctxt (L _ sig)
      (FixSig {}, InstDeclCtxt {}) -> False
      (FixSig {}, _)               -> True
 
-     (IdSig {}, TopSigCtxt)      -> True
+     (IdSig {}, TopSigCtxt {})   -> True
      (IdSig {}, InstDeclCtxt {}) -> True
      (IdSig {}, _)               -> False
 
      (InlineSig {}, HsBootCtxt) -> False
      (InlineSig {}, _)          -> True
 
-     (SpecSig {}, TopSigCtxt)       -> True
+     (SpecSig {}, TopSigCtxt {})    -> True
      (SpecSig {}, LocalBindCtxt {}) -> True
      (SpecSig {}, InstDeclCtxt {})  -> True
      (SpecSig {}, _)                -> False
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index b1f393baaf..2f1de923c2 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -837,13 +837,36 @@ We don't want to say 'f' is out of scope; instead, we want to
 return the imported 'f', so that later on the reanamer will
 correctly report "misplaced type sig".
 
+Note [Signatures for top level things]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+data HsSigCtxt = ... | TopSigCtxt NameSet Bool | ....
+
+* The NameSet says what is bound in this group of bindings.
+  We can't use isLocalGRE from the GlobalRdrEnv, because of this:
+       f x = x
+       $( ...some TH splice... )
+       f :: Int -> Int
+  When we encounter the signature for 'f', the binding for 'f'
+  will be in the GlobalRdrEnv, and will be a LocalDef. Yet the
+  signature is mis-placed
+
+* The Bool says whether the signature is ok for a class method
+  or record selector.  Consider
+      infix 3 `f`          -- Yes, ok
+      f :: C a => a -> a   -- No, not ok
+      class C a where
+        f :: a -> a
+
 \begin{code}
 data HsSigCtxt 
-  = HsBootCtxt		     -- Top level of a hs-boot file
-  | TopSigCtxt		     -- At top level
+  = TopSigCtxt NameSet Bool  -- At top level, binding these names
+                             -- See Note [Signatures for top level things]
+                             -- Bool <=> ok to give sig for
+                             --          class method or record selctor
   | LocalBindCtxt NameSet    -- In a local binding, binding these names
   | ClsDeclCtxt   Name	     -- Class decl for this class
   | InstDeclCtxt  Name	     -- Intsance decl for this class
+  | HsBootCtxt		     -- Top level of a hs-boot file
 
 lookupSigOccRn :: HsSigCtxt
 	       -> Sig RdrName
@@ -875,11 +898,11 @@ lookupBindGroupOcc ctxt what rdr_name
 
   | otherwise
   = case ctxt of 
-      HsBootCtxt       -> lookup_top		    
-      TopSigCtxt       -> lookup_top
-      LocalBindCtxt ns -> lookup_group ns
-      ClsDeclCtxt  cls -> lookup_cls_op cls
-      InstDeclCtxt cls -> lookup_cls_op cls
+      HsBootCtxt            -> lookup_top (const True)       True
+      TopSigCtxt ns meth_ok -> lookup_top (`elemNameSet` ns) meth_ok
+      LocalBindCtxt ns 	    -> lookup_group ns
+      ClsDeclCtxt  cls 	    -> lookup_cls_op cls
+      InstDeclCtxt cls 	    -> lookup_cls_op cls
   where
     lookup_cls_op cls
       = do { env <- getGlobalRdrEnv 
@@ -893,21 +916,22 @@ lookupBindGroupOcc ctxt what rdr_name
       where
         doc = ptext (sLit "method of class") <+> quotes (ppr cls)
 
-    lookup_top
+    lookup_top keep_me meth_ok
       = do { env <- getGlobalRdrEnv 
-           ; let gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)
-           ; case filter isLocalGRE gres of
-               [] | null gres -> bale_out_with empty
-                  | otherwise -> bale_out_with (bad_msg (ptext (sLit "an imported value")))
+           ; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)
+           ; case filter (keep_me . gre_name) all_gres of
+               [] | null all_gres -> bale_out_with empty
+                  | otherwise -> bale_out_with local_msg
                (gre:_) 
-                  | ParentIs {} <- gre_par gre
-		  -> bale_out_with (bad_msg (ptext (sLit "a record selector or class method")))
+                  | ParentIs {} <- gre_par gre 
+                  , not meth_ok
+		  -> bale_out_with sub_msg
 		  | otherwise
                   -> return (Right (gre_name gre)) }
 
-    lookup_group bound_names
-      = do { mb_name <- lookupOccRn_maybe rdr_name
-           ; case mb_name of
+    lookup_group bound_names  -- Look in the local envt (not top level)
+      = do { local_env <- getLocalRdrEnv
+           ; case lookupLocalRdrEnv local_env rdr_name of
                Just n  
                  | n `elemNameSet` bound_names -> return (Right n)
                  | otherwise                   -> bale_out_with local_msg
@@ -922,31 +946,31 @@ lookupBindGroupOcc ctxt what rdr_name
     local_msg = parens $ ptext (sLit "The")  <+> what <+> ptext (sLit "must be given where")
   			   <+> quotes (ppr rdr_name) <+> ptext (sLit "is declared")
 
-    bad_msg thing = parens $ ptext (sLit "You cannot give a") <+> what
-    			  <+> ptext (sLit "for") <+> thing
+    sub_msg = parens $ ptext (sLit "You cannot give a") <+> what
+     	               <+> ptext (sLit "for a record selector or class method")
 
 
 ---------------
-lookupLocalTcNames :: NameSet -> SDoc -> RdrName -> RnM [Name]
+lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [Name]
 -- GHC extension: look up both the tycon and data con or variable.
--- Used for top-level fixity signatures. Complain if neither is in scope.
+-- Used for top-level fixity signatures and deprecations. 
+-- Complain if neither is in scope.
 -- See Note [Fixity signature lookup]
-lookupLocalTcNames bndr_set what rdr_name
-  | Just n <- isExact_maybe rdr_name	
-	-- Special case for (:), which doesn't get into the GlobalRdrEnv
-  = do { n' <- lookupExactOcc n; return [n'] }	-- For this we don't need to try the tycon too
-  | otherwise
+lookupLocalTcNames ctxt what rdr_name
   = do { mb_gres <- mapM lookup (dataTcOccs rdr_name)
        ; let (errs, names) = splitEithers mb_gres
        ; when (null names) $ addErr (head errs) -- Bleat about one only
        ; return names }
   where
-    lookup = lookupBindGroupOcc (LocalBindCtxt bndr_set) what
+    lookup = lookupBindGroupOcc ctxt what
 
 dataTcOccs :: RdrName -> [RdrName]
 -- Return both the given name and the same name promoted to the TcClsName
 -- namespace.  This is useful when we aren't sure which we are looking at.
 dataTcOccs rdr_name
+  | Just n <- isExact_maybe rdr_name	
+  , not (isBuiltInSyntax n)   -- See Note [dataTcOccs and Exact Names]
+  = [rdr_name] 
   | isDataOcc occ || isVarOcc occ
   = [rdr_name, rdr_name_tc]
   | otherwise
@@ -956,6 +980,17 @@ dataTcOccs rdr_name
     rdr_name_tc = setRdrNameSpace rdr_name tcName
 \end{code}
 
+Note [dataTcOccs and Exact Names]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Exact RdrNames can occur in code generated by Template Haskell, and generally
+those references are, well, exact, so it's wrong to return the TyClsName too.
+But there is an awkward exception for built-in syntax. Example in GHCi
+   :info []
+This parses as the Exact RdrName for nilDataCon, but we also want
+the list type constructor.
+
+Note that setRdrNameSpace on an Exact name requires the Name to be External,
+which it always is for built in syntax.
 
 %*********************************************************
 %*							*
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 9509b0a4b2..595f4653d3 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -114,9 +114,9 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds   = val_decls,
    --     It uses the fixity env from (A) to bind fixities for view patterns.
    new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
    -- bind the LHSes (and their fixities) in the global rdr environment
-   let { val_binders  = collectHsValBinders new_lhs ;
-         all_bndr_set = addListToNameSet tc_bndrs val_binders ;
-         val_avails   = map Avail val_binders  } ;
+   let { val_binders = collectHsValBinders new_lhs ;
+         all_bndrs   = addListToNameSet tc_bndrs val_binders ;
+         val_avails  = map Avail val_binders  } ;
    (tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ;
    traceRn (ptext (sLit "Val binders") <+> (ppr val_binders)) ;
    setEnvs (tcg_env, tcl_env) $ do {
@@ -138,19 +138,19 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds   = val_decls,
 
    -- (F) Rename Value declarations right-hand sides
    traceRn (text "Start rnmono") ;
-   (rn_val_decls, bind_dus) <- rnTopBindsRHS new_lhs ;
+   (rn_val_decls, bind_dus) <- rnTopBindsRHS all_bndrs new_lhs ;
    traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
 
    -- (G) Rename Fixity and deprecations
    
    -- Rename fixity declarations and error if we try to
    -- fix something from another module (duplicates were checked in (A))
-   rn_fix_decls <- rnSrcFixityDecls all_bndr_set fix_decls ;
+   rn_fix_decls <- rnSrcFixityDecls all_bndrs fix_decls ;
 
    -- Rename deprec decls;
    -- check for duplicates and ensure that deprecated things are defined locally
    -- at the moment, we don't keep these around past renaming
-   rn_warns <- rnSrcWarnDecls all_bndr_set warn_decls ;
+   rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ;
 
    -- (H) Rename Everything else
 
@@ -260,6 +260,9 @@ rnSrcFixityDecls bndr_set fix_decls
   = do fix_decls <- mapM rn_decl fix_decls
        return (concat fix_decls)
   where
+    sig_ctxt = TopSigCtxt bndr_set True  
+       -- True <=> can give fixity for class decls and record selectors
+
     rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name]
         -- GHC extension: look up both the tycon and data con 
 	-- for con-like things; hence returning a list
@@ -268,7 +271,7 @@ rnSrcFixityDecls bndr_set fix_decls
     rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity))
       = setSrcSpan name_loc $
                     -- this lookup will fail if the definition isn't local
-        do names <- lookupLocalTcNames bndr_set what rdr_name
+        do names <- lookupLocalTcNames sig_ctxt what rdr_name
            return [ L loc (FixitySig (L name_loc name) fixity)
                   | name <- names ]
     what = ptext (sLit "fixity signature")
@@ -301,9 +304,12 @@ rnSrcWarnDecls bndr_set decls
        ; pairs_s <- mapM (addLocM rn_deprec) decls
        ; return (WarnSome ((concat pairs_s))) }
  where
+   sig_ctxt = TopSigCtxt bndr_set True
+      -- True <=> Can give deprecations for class ops and record sels
+
    rn_deprec (Warning rdr_name txt)
        -- ensures that the names are defined locally
-     = do { names <- lookupLocalTcNames bndr_set what rdr_name
+     = do { names <- lookupLocalTcNames sig_ctxt what rdr_name
           ; return [(nameOccName name, txt) | name <- names] }
    
    what = ptext (sLit "deprecation")
@@ -436,13 +442,14 @@ rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds
            Just (inst_tyvars, _, L _ cls,_) ->
 
     do { let (spec_inst_prags, other_sigs) = partition isSpecInstLSig uprags
-             tv_names = hsLTyVarNames inst_tyvars
+             ktv_names = hsLKiTyVarNames inst_tyvars
 
        -- Rename the associated types, and type signatures
        -- Both need to have the instance type variables in scope
+       ; traceRn (text "rnSrcInstDecl"  <+> ppr inst_ty' $$ ppr inst_tyvars $$ ppr ktv_names)
        ; ((ats', other_sigs'), more_fvs) 
-             <- extendTyVarEnvFVRn tv_names $
-                do { (ats', at_fvs) <- rnATInstDecls cls tv_names ats
+             <- extendTyVarEnvFVRn ktv_names $
+                do { (ats', at_fvs) <- rnATInstDecls cls inst_tyvars ats
                    ; (other_sigs', sig_fvs) <- renameSigs (InstDeclCtxt cls) other_sigs
                    ; return ( (ats', other_sigs')
                             , at_fvs `plusFV` sig_fvs) }
@@ -452,7 +459,7 @@ rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds
 	-- the bindings are for the right class
 	-- (Slightly strangely) when scoped type variables are on, the 
         -- forall-d tyvars scope over the method bindings too
-       ; (mbinds', meth_fvs) <- extendTyVarEnvForMethodBinds inst_tyvars $
+       ; (mbinds', meth_fvs) <- extendTyVarEnvForMethodBinds ktv_names $
                                 rnMethodBinds cls (mkSigTvFn other_sigs')
 					          mbinds    
 
@@ -527,9 +534,19 @@ rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon
 Renaming of the associated types in instances.  
 
 \begin{code}
-rnATInstDecls :: Name        -- Class
-              -> [Name]      -- Type variable binders (but NOT kind variables)
-                         -- See Note [Renaming associated types] in RnTypes
+rnATDecls :: Name      -- Class
+          -> LHsTyVarBndrs Name
+          -> [LTyClDecl RdrName] 
+          -> RnM ([LTyClDecl Name], FreeVars)
+rnATDecls cls hs_tvs at_decls
+  = rnList (rnTyClDecl (Just (cls, tv_ns))) at_decls
+  where
+    tv_ns = hsLTyVarNames hs_tvs
+    -- Type variable binders (but NOT kind variables)
+    -- See Note [Renaming associated types] in RnTypes
+
+rnATInstDecls :: Name      -- Class
+              -> LHsTyVarBndrs Name
               -> [LFamInstDecl RdrName] 
               -> RnM ([LFamInstDecl Name], FreeVars)
 -- Used for the family declarations and defaults in a class decl
@@ -537,21 +554,25 @@ rnATInstDecls :: Name        -- Class
 -- 
 -- NB: We allow duplicate associated-type decls; 
 --     See Note [Associated type instances] in TcInstDcls
-rnATInstDecls cls tvs atDecls 
-  = rnList (rnFamInstDecl (Just (cls, tvs))) atDecls
+rnATInstDecls cls hs_tvs at_insts
+  = rnList (rnFamInstDecl (Just (cls, tv_ns))) at_insts
+  where
+    tv_ns = hsLTyVarNames hs_tvs
+    -- Type variable binders (but NOT kind variables)
+    -- See Note [Renaming associated types] in RnTypes
 \end{code}
 
 For the method bindings in class and instance decls, we extend the 
 type variable environment iff -fglasgow-exts
 
 \begin{code}
-extendTyVarEnvForMethodBinds :: LHsTyVarBndrs Name
+extendTyVarEnvForMethodBinds :: [Name]
                              -> RnM (Bag (LHsBind Name), FreeVars)
                              -> RnM (Bag (LHsBind Name), FreeVars)
-extendTyVarEnvForMethodBinds tyvars thing_inside
+extendTyVarEnvForMethodBinds ktv_names thing_inside
   = do	{ scoped_tvs <- xoptM Opt_ScopedTypeVariables
 	; if scoped_tvs then
-		extendTyVarEnvFVRn (hsLTyVarNames tyvars) thing_inside
+		extendTyVarEnvFVRn ktv_names thing_inside
 	  else
 		thing_inside }
 \end{code}
@@ -882,9 +903,8 @@ rnTyClDecl mb_cls (ClassDecl {tcdCtxt = context, tcdLName = lcls,
 	     { (context', cxt_fvs) <- rnContext cls_doc context
 	     ; fds'  <- rnFds (docOfHsDocContext cls_doc) fds
 			 -- The fundeps have no free variables
-             ; let tv_ns = hsLTyVarNames tyvars'
-             ; (ats',     fv_ats)     <- rnList (rnTyClDecl (Just (cls', tv_ns))) ats
-             ; (at_defs', fv_at_defs) <- rnATInstDecls cls' tv_ns at_defs
+             ; (ats',     fv_ats)     <- rnATDecls cls' tyvars' ats
+             ; (at_defs', fv_at_defs) <- rnATInstDecls cls' tyvars' at_defs
 	     ; (sigs', sig_fvs) <- renameSigs (ClsDeclCtxt cls') sigs
 	     ; let fvs = cxt_fvs     `plusFV`
 	                 sig_fvs     `plusFV`
@@ -913,7 +933,7 @@ rnTyClDecl mb_cls (ClassDecl {tcdCtxt = context, tcdLName = lcls,
 	-- we want to name both "x" tyvars with the same unique, so that they are
 	-- easy to group together in the typechecker.  
 	; (mbinds', meth_fvs) 
-	    <- extendTyVarEnvForMethodBinds tyvars' $
+	    <- extendTyVarEnvForMethodBinds (hsLKiTyVarNames tyvars') $
 		-- No need to check for duplicate method signatures
 		-- since that is done by RnNames.extendGlobalRdrEnvRn
 		-- and the methods are already in scope
diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index c7b69a9654..49431ae977 100644
--- a/compiler/typecheck/TcCanonical.lhs
+++ b/compiler/typecheck/TcCanonical.lhs
@@ -7,7 +7,7 @@
 -- for details
 
 module TcCanonical(
-    canonicalize, flatten, flattenMany, 
+    canonicalize, flatten, flattenMany, occurCheckExpand,
     FlattenMode (..),
     StopOrContinue (..)
  ) where
@@ -1244,8 +1244,8 @@ canEqLeafTyVarLeft d fl tv s2       -- eqv : tv ~ s2
            return Stop
          else do
        -- Not reflexivity but maybe an occurs error
-       { occ_check_result <- canOccursCheck fl tv xi2
-       ; let xi2' = fromMaybe xi2 occ_check_result
+       { let occ_check_result = occurCheckExpand tv xi2
+             xi2' = fromMaybe xi2 occ_check_result
              
              not_occ_err = isJust occ_check_result
                   -- Delicate: don't want to cache as solved a constraint with occurs error!
@@ -1261,28 +1261,20 @@ canEqLeafTyVarLeft d fl tv s2       -- eqv : tv ~ s2
                             canEqFailure d new_fl
            Nothing -> return Stop
         } }
-
--- See Note [Type synonyms and canonicalization].
--- Check whether the given variable occurs in the given type.  We may
--- have needed to do some type synonym unfolding in order to get rid
--- of the variable, so we also return the unfolded version of the
--- type, which is guaranteed to be syntactically free of the given
--- type variable.  If the type is already syntactically free of the
--- variable, then the same type is returned.
---
--- Precondition: the two types are not equal (looking though synonyms)
-canOccursCheck :: CtEvidence -> TcTyVar -> Xi -> TcS (Maybe Xi)
-canOccursCheck _gw tv xi = return (expandAway tv xi)
 \end{code}
 
-@expandAway tv xi@ expands synonyms in xi just enough to get rid of
-occurrences of tv, if that is possible; otherwise, it returns Nothing.
+Note [Occurs check expansion]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+@occurCheckExpand tv xi@ expands synonyms in xi just enough to get rid
+of occurrences of tv outside type function arguments, if that is
+possible; otherwise, it returns Nothing.
+
 For example, suppose we have
   type F a b = [a]
 Then
-  expandAway b (F Int b) = Just [Int]
+  occurCheckExpand b (F Int b) = Just [Int]
 but
-  expandAway a (F a Int) = Nothing
+  occurCheckExpand a (F a Int) = Nothing
 
 We don't promise to do the absolute minimum amount of expanding
 necessary, but we try not to do expansions we don't need to.  We
@@ -1290,49 +1282,61 @@ prefer doing inner expansions first.  For example,
   type F a b = (a, Int, a, [a])
   type G b   = Char
 We have
-  expandAway b (F (G b)) = F Char
+  occurCheckExpand b (F (G b)) = F Char
 even though we could also expand F to get rid of b.
 
+See also Note [Type synonyms and canonicalization].
+
 \begin{code}
-expandAway :: TcTyVar -> Xi -> Maybe Xi
-expandAway tv t@(TyVarTy tv')
-  | tv == tv' = Nothing
-  | otherwise = Just t
-expandAway tv xi
-  | not (tv `elemVarSet` tyVarsOfType xi) = Just xi
-expandAway tv (AppTy ty1 ty2) 
-  = do { ty1' <- expandAway tv ty1
-       ; ty2' <- expandAway tv ty2 
-       ; return (mkAppTy ty1' ty2') }
--- mkAppTy <$> expandAway tv ty1 <*> expandAway tv ty2
-expandAway tv (FunTy ty1 ty2)
-  = do { ty1' <- expandAway tv ty1 
-       ; ty2' <- expandAway tv ty2 
-       ; return (mkFunTy ty1' ty2') } 
--- mkFunTy <$> expandAway tv ty1 <*> expandAway tv ty2
-expandAway tv ty@(ForAllTy {}) 
-  = let (tvs,rho) = splitForAllTys ty
-        tvs_knds  = map tyVarKind tvs 
-    in if tv `elemVarSet` tyVarsOfTypes tvs_knds then
-       -- Can't expand away the kinds unless we create 
-       -- fresh variables which we don't want to do at this point.
-           Nothing 
-       else do { rho' <- expandAway tv rho
-               ; return (mkForAllTys tvs rho') }
--- For a type constructor application, first try expanding away the
--- offending variable from the arguments.  If that doesn't work, next
--- see if the type constructor is a type synonym, and if so, expand
--- it and try again.
-expandAway tv ty@(TyConApp tc tys)
-  = (mkTyConApp tc <$> mapM (expandAway tv) tys) <|> (tcView ty >>= expandAway tv)
-
-expandAway _ xi@(LitTy {}) = return xi
+occurCheckExpand :: TcTyVar -> Type -> Maybe Type
+-- Check whether the given variable occurs in the given type.  We may
+-- have needed to do some type synonym unfolding in order to get rid
+-- of the variable, so we also return the unfolded version of the
+-- type, which is guaranteed to be syntactically free of the given
+-- type variable.  If the type is already syntactically free of the
+-- variable, then the same type is returned.
 
+occurCheckExpand tv ty
+  | not (tv `elemVarSet` tyVarsOfType ty) = Just ty
+  | otherwise                             = go ty
+  where
+    go t@(TyVarTy tv') | tv == tv' = Nothing
+                       | otherwise = Just t
+    go ty@(LitTy {}) = return ty
+    go (AppTy ty1 ty2) = do { ty1' <- go ty1
+           		    ; ty2' <- go ty2  
+           		    ; return (mkAppTy ty1' ty2') }
+    -- mkAppTy <$> go ty1 <*> go ty2
+    go (FunTy ty1 ty2) = do { ty1' <- go ty1 
+           		    ; ty2' <- go ty2 
+           		    ; return (mkFunTy ty1' ty2') } 
+    -- mkFunTy <$> go ty1 <*> go ty2
+    go ty@(ForAllTy {})
+       | tv `elemVarSet` tyVarsOfTypes tvs_knds = Nothing
+           -- Can't expand away the kinds unless we create 
+           -- fresh variables which we don't want to do at this point.
+       | otherwise = do { rho' <- go rho
+                        ; return (mkForAllTys tvs rho') }
+       where
+         (tvs,rho) = splitForAllTys ty
+         tvs_knds  = map tyVarKind tvs 
+
+    -- For a type constructor application, first try expanding away the
+    -- offending variable from the arguments.  If that doesn't work, next
+    -- see if the type constructor is a type synonym, and if so, expand
+    -- it and try again.
+    go ty@(TyConApp tc tys)
+      | isSynFamilyTyCon tc    -- It's ok for tv to occur under a type family application
+       = return ty             -- Eg.  (a ~ F a) is not an occur-check error
+                               -- NB This case can't occur during canonicalisation,
+                               --    because the arg is a Xi-type, but can occur in the
+                               --    call from TcErrors
+      | otherwise
+      = (mkTyConApp tc <$> mapM go tys) <|> (tcView ty >>= go)
 \end{code}
 
 Note [Type synonyms and canonicalization]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
 We treat type synonym applications as xi types, that is, they do not
 count as type function applications.  However, we do need to be a bit
 careful with type synonyms: like type functions they may not be
diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index 08926ea745..3c6598efb1 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -17,6 +17,7 @@ module TcErrors(
 
 #include "HsVersions.h"
 
+import TcCanonical( occurCheckExpand )
 import TcRnMonad
 import TcMType
 import TcType
@@ -457,17 +458,20 @@ mkEqErr1 ctxt ct
         msg   = mkExpectedActualMsg exp act
     mk_err ctxt1 _ = mkEqErr_help ctxt1 ct False ty1 ty2
 
-mkEqErr_help :: ReportErrCtxt
-             -> Ct
-             -> Bool     -- True  <=> Types are correct way round;
-                         --           report "expected ty1, actual ty2"
-                         -- False <=> Just report a mismatch without orientation
-                         --           The ReportErrCtxt has expected/actual 
-             -> TcType -> TcType -> TcM ErrMsg
+mkEqErr_help, reportEqErr 
+   :: ReportErrCtxt
+   -> Ct
+   -> Bool     -- True  <=> Types are correct way round;
+               --           report "expected ty1, actual ty2"
+               -- False <=> Just report a mismatch without orientation
+               --           The ReportErrCtxt has expected/actual 
+   -> TcType -> TcType -> TcM ErrMsg
 mkEqErr_help ctxt ct oriented ty1 ty2
   | Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr ctxt ct oriented tv1 ty2
   | Just tv2 <- tcGetTyVar_maybe ty2 = mkTyVarEqErr ctxt ct oriented tv2 ty1
-  | otherwise   -- Neither side is a type variable
+  | otherwise                        = reportEqErr ctxt ct oriented ty1 ty2
+
+reportEqErr ctxt ct oriented ty1 ty2
   = do { ctxt' <- mkEqInfoMsg ctxt ct ty1 ty2
        ; mkErrorReport ctxt' (misMatchOrCND ctxt' ct oriented ty1 ty2) }
 
@@ -486,7 +490,7 @@ mkTyVarEqErr ctxt ct oriented tv1 ty2
   = mkErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)
 
   -- Occurs check
-  | tv1 `elemVarSet` tyVarsOfType ty2
+  | isNothing (occurCheckExpand tv1 ty2)
   = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2
                            (sep [ppr ty1, char '=', ppr ty2])
     in mkErrorReport ctxt occCheckMsg
@@ -526,21 +530,10 @@ mkTyVarEqErr ctxt ct oriented tv1 ty2
        ; mkErrorReport (addExtraTyVarInfo ctxt ty1 ty2) (msg $$ nest 2 extra) }
 
   | otherwise
-  = pprTrace "mkTyVarEqErr" (ppr tv1 $$ ppr ty2 $$ ppr (cec_encl ctxt)) $
-    panic "mkTyVarEqErr"
-    	-- I don't think this should happen, and if it does I want to know
-	-- Trac #5130 happened because an actual type error was not
-	-- reported at all!  So not reporting is pretty dangerous.
-	-- 
-	-- OLD, OUT OF DATE COMMENT
-        -- This can happen, by a recursive decomposition of frozen
-        -- occurs check constraints
-        -- Example: alpha ~ T Int alpha has frozen.
-        --          Then alpha gets unified to T beta gamma
-        -- So now we have  T beta gamma ~ T Int (T beta gamma)
-        -- Decompose to (beta ~ Int, gamma ~ T beta gamma)
-        -- The (gamma ~ T beta gamma) is the occurs check, but
-        -- the (beta ~ Int) isn't an error at all.  So return ()
+  = reportEqErr ctxt ct oriented (mkTyVarTy tv1) ty2
+        -- This *can* happen (Trac #6123, and test T2627b)
+        -- Consider an ambiguous top-level constraint (a ~ F a)
+        -- Not an occurs check, becuase F is a type function.
   where         
     k1 	= tyVarKind tv1
     k2 	= typeKind ty2
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 8439088904..3bf5003525 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -833,15 +833,24 @@ kindGeneralize tkvs
   = do { gbl_tvs  <- tcGetGlobalTyVars -- Already zonked
        ; tidy_env <- tcInitTidyEnv
        ; tkvs     <- zonkTyVarsAndFV tkvs
-       ; let kvs_to_quantify = varSetElems (tkvs `minusVarSet` gbl_tvs)
+       ; let kvs_to_quantify = filter isKindVar (varSetElems (tkvs `minusVarSet` gbl_tvs))
                 -- Any type varaibles in tkvs will be in scope,
                 -- and hence in gbl_tvs, so after removing gbl_tvs
                 -- we should only have kind variables left
+		--
+ 		-- BUT there is a smelly case (to be fixed when TH is reorganised)
+		--     f t = [| e :: $t |]
+                -- When typechecking the body of the bracket, we typecheck $t to a
+                -- unification variable 'alpha', with no biding forall.  We don't
+                -- want to kind-quantify it!
 
              (_, tidy_kvs_to_quantify) = tidyTyVarBndrs tidy_env kvs_to_quantify
                            -- We do not get a later chance to tidy!
 
        ; ASSERT2 (all isKindVar kvs_to_quantify, ppr kvs_to_quantify $$ ppr tkvs)
+             -- This assertion is obviosy true because of the filter isKindVar
+             -- but we'll remove that when reorganising TH, and then the assertion
+             -- will mean something
          zonkQuantifiedTyVars tidy_kvs_to_quantify }
 \end{code}
 
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index 25bbf622ab..d987e0f75a 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -592,6 +592,11 @@ solveWithIdentity :: SubGoalDepth
 --     must work for Derived as well as Wanted
 -- Returns: workItem where 
 --        workItem = the new Given constraint
+--
+-- NB: No need for an occurs check here, because solveWithIdentity always 
+--     arises from a CTyEqCan, a *canonical* constraint.  Its invariants
+--     say that in (a ~ xi), the type variable a does not appear in xi.
+--     See TcRnTypes.Ct invariants.
 solveWithIdentity d wd tv xi 
   = do { let tv_ty = mkTyVarTy tv
        ; traceTcS "Sneaky unification:" $ 
diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index c87a521b19..d05b1dd25b 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -1624,7 +1624,7 @@ checkValidFamInst typats rhs
 	   mapM_ addErrTc (checkFamInstRhs typats (tcTyFamInsts rhs))
        }
 
--- Make sure that each type family instance is 
+-- Make sure that each type family application is 
 --   (1) strictly smaller than the lhs,
 --   (2) mentions no type variable more often than the lhs, and
 --   (3) does not contain any further type family instances.
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 0864e5de33..18f2dfa6a2 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -609,8 +609,8 @@ tidyCos env = map (tidyCo env)
 %************************************************************************
 
 \begin{code}
-
--- | Finds type family instances occuring in a type after expanding synonyms.
+-- | Finds outermost type-family applications occuring in a type,
+-- after expanding synonyms.
 tcTyFamInsts :: Type -> [(TyCon, [Type])]
 tcTyFamInsts ty 
   | Just exp_ty <- tcView ty    = tcTyFamInsts exp_ty
diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs
index fff5ca15aa..3dc69eeab2 100644
--- a/ghc/GhciMonad.hs
+++ b/ghc/GhciMonad.hs
@@ -217,18 +217,22 @@ instance ExceptionMonad GHCi where
 instance MonadIO GHCi where
   liftIO = MonadUtils.liftIO
 
+instance Haskeline.MonadException Ghc where
+  controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
+                    run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s)
+                    in fmap (flip unGhc s) $ f run'
+
 instance Haskeline.MonadException GHCi where
-  catch = gcatch
-  block = gblock
-  unblock = gunblock
-  -- XXX when Haskeline's MonadException changes, we can drop our
-  -- deprecated block/unblock methods
+  controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
+                    run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s)
+                    in fmap (flip unGHCi s) $ f run'
 
 instance ExceptionMonad (InputT GHCi) where
   gcatch = Haskeline.catch
-  gmask f = Haskeline.block (f Haskeline.unblock) -- slightly wrong
-  gblock = Haskeline.block
-  gunblock = Haskeline.unblock
+  gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_)
+
+  gblock = Haskeline.liftIOOp_ gblock
+  gunblock = Haskeline.liftIOOp_ gunblock
 
 isOptionSet :: GHCiOption -> GHCi Bool
 isOptionSet opt
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index 0688f2b6b7..f29fa06f2b 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -69,7 +69,7 @@ import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,
                    partition, sort, sortBy )
 import Data.Maybe
 
-import Exception hiding (catch, block, unblock)
+import Exception hiding (catch)
 
 import Foreign.C
 import Foreign.Safe
@@ -2889,8 +2889,8 @@ showException se =
 -- in an exception loop (eg. let a = error a in a) the ^C exception
 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
 
-ghciHandle :: MonadException m => (SomeException -> m a) -> m a -> m a
-ghciHandle h m = Haskeline.catch m $ \e -> unblock (h e)
+ghciHandle :: ExceptionMonad m => (SomeException -> m a) -> m a -> m a
+ghciHandle h m = gcatch m $ \e -> gunblock (h e)
 
 ghciTry :: GHCi a -> GHCi (Either SomeException a)
 ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
diff --git a/libffi/ghc.mk b/libffi/ghc.mk
index fc474d2010..07d6d3d74c 100644
--- a/libffi/ghc.mk
+++ b/libffi/ghc.mk
@@ -70,8 +70,11 @@ $(libffi_STAMP_CONFIGURE): $(TOUCH_DEP)
 	mv libffi/build/ltmain.sh libffi/build/ltmain.sh.orig
 	sed 's#cmd //c echo "\$$1"#cmd /c "echo $$1"#' < libffi/build/ltmain.sh.orig > libffi/build/ltmain.sh
 
-# Because -Werror may be in SRC_CC_OPTS/SRC_LD_OPTS, we need to turn
-# warnings off or the compilation of libffi might fail due to warnings
+# * Because -Werror may be in SRC_CC_OPTS/SRC_LD_OPTS, we need to turn
+#   warnings off or the compilation of libffi might fail due to warnings;
+#   hence the -w flags.
+# * We specify --libdir, as we need to know the path to libffi.a, but on
+#   some platforms it defaults to .../lib64/ rather than .../lib/.
 	cd libffi && \
 	    $(LIBFFI_PATH_MANGLE) \
 	    cd build && \
@@ -83,6 +86,7 @@ $(libffi_STAMP_CONFIGURE): $(TOUCH_DEP)
         LDFLAGS="$(SRC_LD_OPTS) $(CONF_GCC_LINKER_OPTS_STAGE1) -w" \
         "$(SHELL)" configure \
 	          --prefix=$(TOP)/libffi/build/inst \
+	          --libdir=$(TOP)/libffi/build/inst/lib \
 	          --enable-static=yes \
 	          --enable-shared=$(libffi_EnableShared) \
 	          --host=$(TargetPlatformFull)
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 2ab26f7ba4..9cedabdca8 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -35,7 +35,7 @@ import base_ControlziExceptionziBase_nestedAtomically_closure;
 import EnterCriticalSection;
 import LeaveCriticalSection;
 import ghczmprim_GHCziTypes_False_closure;
-#if defined(GhcUnregisterised) || !defined(mingw32_HOST_OS)
+#if defined(USE_MINIINTERPRETER) || !defined(mingw32_HOST_OS)
 import sm_mutex;
 #endif
 
diff --git a/rts/Schedule.c b/rts/Schedule.c
index fe346afe19..755f306e58 100644
--- a/rts/Schedule.c
+++ b/rts/Schedule.c
@@ -611,7 +611,7 @@ schedulePreLoop(void)
 {
   // initialisation for scheduler - what cannot go into initScheduler()  
 
-#if defined(mingw32_HOST_OS) && !defined(GhcUnregisterised)
+#if defined(mingw32_HOST_OS) && !defined(USE_MINIINTERPRETER)
     win32AllocStack();
 #endif
 }
diff --git a/rts/ghc.mk b/rts/ghc.mk
index 5ae6b1ac3b..9fdf6bebb5 100644
--- a/rts/ghc.mk
+++ b/rts/ghc.mk
@@ -316,11 +316,6 @@ rts/RtsUtils_CC_OPTS += -DTargetVendor=\"$(TargetVendor_CPP)\"
 rts/RtsUtils_CC_OPTS += -DGhcUnregisterised=\"$(GhcUnregisterised)\"
 rts/RtsUtils_CC_OPTS += -DGhcEnableTablesNextToCode=\"$(GhcEnableTablesNextToCode)\"
 
-ifeq "$(GhcUnregisterised)" "YES"
-rts/PrimOps_HC_OPTS += -DGhcUnregisterised=1
-rts/Schedule_CC_OPTS += -DGhcUnregisterised=1
-endif
-
 # Compile various performance-critical pieces *without* -fPIC -dynamic
 # even when building a shared library.  If we don't do this, then the
 # GC runs about 50% slower on x86 due to the overheads of PIC.  The
diff --git a/rts/posix/GetTime.c b/rts/posix/GetTime.c
index da8d0fa629..fabc40431d 100644
--- a/rts/posix/GetTime.c
+++ b/rts/posix/GetTime.c
@@ -34,7 +34,8 @@
 // separately, using getrusage() and gettimeofday() respectively
 
 #ifdef darwin_HOST_OS
-static double timer_scaling_factor_ns = 0.0;
+static uint64_t timer_scaling_factor_numer = 0;
+static uint64_t timer_scaling_factor_denom = 0;
 #endif
 
 void initializeTimer()
@@ -42,7 +43,8 @@ void initializeTimer()
 #ifdef darwin_HOST_OS
     mach_timebase_info_data_t info;
     (void) mach_timebase_info(&info);
-    timer_scaling_factor_ns = (double)info.numer / (double)info.denom * 1e9;
+    timer_scaling_factor_numer = (uint64_t)info.numer;
+    timer_scaling_factor_denom = (uint64_t)info.denom;
 #endif
 }
 
@@ -87,7 +89,7 @@ StgWord64 getMonotonicNSec(void)
            (StgWord64)ts.tv_nsec;
 #elif defined(darwin_HOST_OS)
     uint64_t time = mach_absolute_time();
-    return (double)time * timer_scaling_factor_ns;
+    return (time * timer_scaling_factor_numer) / timer_scaling_factor_denom;
 #else
     struct timeval tv;