ANNOUNCE

 
-   ==============================================================
-    The (Interactive) Glasgow Haskell Compiler -- version 6.10.1
-   ==============================================================
+   =============================================================
+    The (Interactive) Glasgow Haskell Compiler -- version 7.6.1
+   =============================================================
 
-The GHC Team is pleased to announce a new major release of GHC. There
-have been a number of significant changes since the last major release,
-including:
+The GHC Team is pleased to announce a new major release of GHC, 7.6.1.
 
- * Some new language features have been implemented:
-   * Record syntax: wild-card patterns, punning, and field disambiguation
-   * Generalised quasi-quotes
-   * Generalised list comprehensions
-   * View patterns
+Here are some of the highlights of the 7.6 branch since 7.4:
 
- * Type families have been completely re-implemented
+  * Polymorphic kinds and data promotion are now fully implemented and
+    supported features.
 
- * Now comes with Haddock 2, which supports all GHC extensions
+  * Windows 64bit is now a supported platform.
 
- * Parallel garbage collection
+  * It is now possible to defer type errors until runtime using the
+    -fdefer-type-errors flag.
 
- * Base provides extensible exceptions
+  * The RTS now supports changing the number of capabilities at runtime
+    with Control.Concurrent.setNumCapabilities.
 
- * The GHC API is easier to use
+Full release notes are here:
 
- * External core (output only) now works again
-
- * Data Parallel Haskell (DPH) comes as part of GHC
-
-The full release notes are here:
-
-  http://haskell.org/ghc/docs/6.10.1/html/users_guide/release-6-10-1.html
+  http://www.haskell.org/ghc/docs/7.6.1/html/users_guide/release-7-6-1.html
 
 How to get it
 ~~~~~~~~~~~~~

compiler/basicTypes/BasicTypes.lhs

@@ -71,7 +71,7 @@ module BasicTypes(
         Activation(..), isActive, isActiveIn,
         isNeverActive, isAlwaysActive, isEarlyActive,
         RuleMatchInfo(..), isConLike, isFunLike, 
-        InlineSpec(..), 
+        InlineSpec(..), isEmptyInlineSpec,
         InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, 
         neverInlinePragma, dfunInlinePragma, 
 	isDefaultInlinePragma, 

compiler/basicTypes/DataCon.lhs

@@ -45,8 +45,8 @@ module DataCon (
         deepSplitProductType_maybe,
 
         -- ** Promotion related functions
-        promoteType, isPromotableType, isPromotableTyCon,
-        buildPromotedTyCon, buildPromotedDataCon,
+        isPromotableTyCon, promoteTyCon, 
+        promoteDataCon, promoteDataCon_maybe
     ) where
 
 #include "HsVersions.h"
@@ -386,9 +386,12 @@ data DataCon
 	-- An entirely separate wrapper function is built in TcTyDecls
 	dcIds :: DataConIds,
 
-	dcInfix :: Bool		-- True <=> declared infix
+	dcInfix :: Bool,	-- True <=> declared infix
 				-- Used for Template Haskell and 'deriving' only
 				-- The actual fixity is stored elsewhere
+
+        dcPromoted :: Maybe TyCon    -- The promoted TyCon if this DataCon is promotable
+                                     -- See Note [Promoted data constructors] in TyCon
   }
   deriving Data.Typeable.Typeable
 
@@ -519,10 +522,7 @@ mkDataCon name declared_infix
 -- so the error is detected properly... it's just that asaertions here
 -- are a little dodgy.
 
-  = -- ASSERT( not (any isEqPred theta) )
-	-- We don't currently allow any equality predicates on
-	-- a data constructor (apart from the GADT ones in eq_spec)
-    con
+  = con
   where
     is_vanilla = null ex_tvs && null eq_spec && null theta
     con = MkData {dcName = name, dcUnique = nameUnique name, 
@@ -537,7 +537,8 @@ mkDataCon name declared_infix
 		  dcStrictMarks = arg_stricts, 
 		  dcRepStrictness = rep_arg_stricts,
 		  dcFields = fields, dcTag = tag, dcRepType = ty,
-		  dcIds = ids }
+		  dcIds = ids,
+                  dcPromoted = mb_promoted }
 
 	-- Strictness marks for source-args
 	--	*after unboxing choices*, 
@@ -559,6 +560,17 @@ mkDataCon name declared_infix
 	  mkFunTys rep_arg_tys $
 	  mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
 
+    mb_promoted   -- See Note [Promoted data constructors] in TyCon
+      | all (isLiftedTypeKind . tyVarKind) (univ_tvs ++ ex_tvs)
+                          -- No kind polymorphism, and all of kind *
+      , null full_theta   -- No constraints
+      , all isPromotableType orig_arg_tys
+      = Just (mkPromotedDataCon con name (getUnique name) prom_kind arity)
+      | otherwise 
+      = Nothing          
+    prom_kind = promoteType (dataConUserType con)
+    arity     = dataConSourceArity con
+
 eqSpecPreds :: [(TyVar,Type)] -> ThetaType
 eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ]
 
@@ -978,24 +990,22 @@ computeRep stricts tys
 %*                                                                      *
 %************************************************************************
 
-These two 'buildPromoted..' functions are here because
+These two 'promoted..' functions are here because
  * They belong together
- * 'buildPromotedTyCon' is used by promoteType
- * 'buildPromotedTyCon' depends on DataCon stuff
+ * 'promoteTyCon'  is used by promoteType
+ * 'prmoteDataCon' depends on DataCon stuff
 
 \begin{code}
-buildPromotedTyCon :: TyCon -> TyCon
-buildPromotedTyCon tc
-  = mkPromotedTyCon tc (promoteKind (tyConKind tc))
+promoteDataCon :: DataCon -> TyCon
+promoteDataCon (MkData { dcPromoted = Just tc }) = tc
+promoteDataCon dc = pprPanic "promoteDataCon" (ppr dc)
+
+promoteDataCon_maybe :: DataCon -> Maybe TyCon
+promoteDataCon_maybe (MkData { dcPromoted = mb_tc }) = mb_tc
 
-buildPromotedDataCon :: DataCon -> TyCon
-buildPromotedDataCon dc 
-  = ASSERT ( isPromotableType ty )
-    mkPromotedDataCon dc (getName dc) (getUnique dc) kind arity
-  where 
-    ty    = dataConUserType dc
-    kind  = promoteType ty
-    arity = dataConSourceArity dc
+promoteTyCon :: TyCon -> TyCon
+promoteTyCon tc
+  = mkPromotedTyCon tc (promoteKind (tyConKind tc))
 \end{code}
 
 Note [Promoting a Type to a Kind]
@@ -1017,16 +1027,11 @@ The transformation from type to kind is done by promoteType
 
 \begin{code}
 isPromotableType :: Type -> Bool
-isPromotableType ty
-  = all (isLiftedTypeKind . tyVarKind) tvs
-    && go rho
-  where
-    (tvs, rho) = splitForAllTys ty
-    go (TyConApp tc tys) | Just n <- isPromotableTyCon tc
-                         = tys `lengthIs` n && all go tys
-    go (FunTy arg res)   = go arg && go res
-    go (TyVarTy tvar)    = tvar `elem` tvs
-    go _                 = False
+isPromotableType (TyConApp tc tys) 
+  | Just n <- isPromotableTyCon tc = tys `lengthIs` n && all isPromotableType tys
+isPromotableType (FunTy arg res)   = isPromotableType arg && isPromotableType res
+isPromotableType (TyVarTy {})      = True
+isPromotableType _                 = False
 
 -- If tc's kind is [ *^n -> * ] returns [ Just n ], else returns [ Nothing ]
 isPromotableTyCon :: TyCon -> Maybe Int
@@ -1048,7 +1053,7 @@ promoteType ty
     kvs = [ mkKindVar (tyVarName tv) superKind | tv <- tvs ]
     env = zipVarEnv tvs kvs
 
-    go (TyConApp tc tys) = mkTyConApp (buildPromotedTyCon tc) (map go tys)
+    go (TyConApp tc tys) = mkTyConApp (promoteTyCon tc) (map go tys)
     go (FunTy arg res)   = mkArrowKind (go arg) (go res)
     go (TyVarTy tv)      | Just kv <- lookupVarEnv env tv 
                          = TyVarTy kv

compiler/basicTypes/MkId.lhs

@@ -749,9 +749,14 @@ mkPrimOpId prim_op
     id   = mkGlobalId (PrimOpId prim_op) name ty info
                 
     info = noCafIdInfo
-           `setSpecInfo`          mkSpecInfo (primOpRules prim_op name)
-           `setArityInfo`         arity
+           `setSpecInfo`       mkSpecInfo (primOpRules prim_op name)
+           `setArityInfo`      arity
            `setStrictnessInfo` Just strict_sig
+           `setInlinePragInfo` neverInlinePragma
+               -- We give PrimOps a NOINLINE pragma so that we don't
+               -- get silly warnings from Desugar.dsRule (the inline_shadows_rule
+               -- test) about a RULE conflicting with a possible inlining
+               -- cf Trac #7287
 
 -- For each ccall we manufacture a separate CCallOpId, giving it
 -- a fresh unique, a type that is correct for this particular ccall,

compiler/basicTypes/RdrName.lhs

@@ -585,26 +585,25 @@ mkGlobalRdrEnv gres
 				   (nameOccName (gre_name gre)) 
 				   gre
 
-findLocalDupsRdrEnv :: GlobalRdrEnv -> [OccName] -> (GlobalRdrEnv, [[Name]])
+findLocalDupsRdrEnv :: GlobalRdrEnv -> [OccName] -> [[Name]]
 -- ^ For each 'OccName', see if there are multiple local definitions
--- for it.  If so, remove all but one (to suppress subsequent error messages)
+-- for it; return a list of all such
 -- and return a list of the duplicate bindings
 findLocalDupsRdrEnv rdr_env occs 
   = go rdr_env [] occs
   where
-    go rdr_env dups [] = (rdr_env, dups)
+    go _       dups [] = dups
     go rdr_env dups (occ:occs)
       = case filter isLocalGRE gres of
-	  []       -> WARN( True, ppr occ <+> ppr rdr_env ) 
-		      go rdr_env dups occs	-- Weird!  No binding for occ
-	  [_]      -> go rdr_env dups occs	-- The common case
-	  dup_gres -> go (extendOccEnv rdr_env occ (head dup_gres : nonlocal_gres))
-   		         (map gre_name dup_gres : dups)
-			 occs
+	  []       -> go rdr_env  dups  			 occs
+	  [_]      -> go rdr_env  dups  			 occs	-- The common case
+	  dup_gres -> go rdr_env' (map gre_name dup_gres : dups) occs
       where
         gres = lookupOccEnv rdr_env occ `orElse` []
-	nonlocal_gres = filterOut isLocalGRE gres
-
+        rdr_env' = delFromOccEnv rdr_env occ    
+            -- The delFromOccEnv avoids repeating the same
+            -- complaint twice, when occs itself has a duplicate
+            -- which is a common case
 
 insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt]
 insertGRE new_g [] = [new_g]

compiler/cmm/CmmUtils.hs

@@ -43,7 +43,7 @@ module CmmUtils(
 	cmmNegate, 
   	cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord,
   	cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord,
-  	cmmUShrWord, cmmAddWord, cmmMulWord,
+  	cmmUShrWord, cmmAddWord, cmmMulWord, cmmQuotWord,
 
 	isTrivialCmmExpr, hasNoGlobalRegs,
 	
@@ -290,7 +290,7 @@ cmmLoadIndexW base off ty = CmmLoad (cmmOffsetW base off) ty
 -----------------------
 cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord,
   cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord,
-  cmmUShrWord, cmmAddWord, cmmMulWord
+  cmmUShrWord, cmmAddWord, cmmMulWord, cmmQuotWord
   :: CmmExpr -> CmmExpr -> CmmExpr
 cmmOrWord  e1 e2 = CmmMachOp mo_wordOr  [e1, e2]
 cmmAndWord e1 e2 = CmmMachOp mo_wordAnd [e1, e2]
@@ -304,6 +304,7 @@ cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2]
 cmmAddWord e1 e2 = CmmMachOp mo_wordAdd [e1, e2]
 cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2]
 cmmMulWord e1 e2 = CmmMachOp mo_wordMul [e1, e2]
+cmmQuotWord e1 e2 = CmmMachOp mo_wordUQuot [e1, e2]
 
 cmmNegate :: CmmExpr -> CmmExpr
 cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)

compiler/codeGen/CgPrimOp.hs

@@ -34,6 +34,7 @@ import FastString
 import StaticFlags
 
 import Control.Monad
+import Data.Bits
 
 -- ---------------------------------------------------------------------------
 -- Code generation for PrimOps
@@ -829,8 +830,7 @@ doWritePtrArrayOp addr idx val
           cmmOffsetExpr
            (cmmOffsetExprW (cmmOffsetB addr arrPtrsHdrSize)
                           (loadArrPtrsSize addr))
-           (CmmMachOp mo_wordUShr [idx,
-                                   CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)])
+           (card idx)
           ) (CmmLit (CmmInt 1 W8))
 
 loadArrPtrsSize :: CmmExpr -> CmmExpr
@@ -1002,10 +1002,8 @@ emitCloneArray info_p res_r src0 src_off0 n0 live = do
     src_off <- assignTemp_ src_off0
     n <- assignTemp_ n0
 
-    card_words <- assignTemp $ (n `cmmUShrWord`
-                                (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)))
-                  `cmmAddWord` CmmLit (mkIntCLit 1)
-    size <- assignTemp $ n `cmmAddWord` card_words
+    card_bytes <- assignTemp $ cardRoundUp n
+    size <- assignTemp $ n `cmmAddWord` bytesToWordsRoundUp card_bytes
     words <- assignTemp $ arrPtrsHdrSizeW `cmmAddWord` size
 
     arr_r <- newTemp bWord
@@ -1029,14 +1027,13 @@ emitCloneArray info_p res_r src0 src_off0 n0 live = do
 
     emitMemsetCall (cmmOffsetExprW dst_p n)
         (CmmLit (mkIntCLit 1))
-        (card_words `cmmMulWord` wordSize)
+        card_bytes
         (CmmLit (mkIntCLit wORD_SIZE))
         live
     stmtC $ CmmAssign (CmmLocal res_r) arr
   where
     arrPtrsHdrSizeW = CmmLit $ mkIntCLit $ fixedHdrSize +
                       (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE)
-    wordSize = CmmLit (mkIntCLit wORD_SIZE)
     myCapability = CmmReg baseReg `cmmSubWord`
                    CmmLit (mkIntCLit oFFSET_Capability_r)
 
@@ -1048,13 +1045,24 @@ emitSetCards dst_start dst_cards_start n live = do
     start_card <- assignTemp $ card dst_start
     emitMemsetCall (dst_cards_start `cmmAddWord` start_card)
         (CmmLit (mkIntCLit 1))
-        ((card (dst_start `cmmAddWord` n) `cmmSubWord` start_card)
-         `cmmAddWord` CmmLit (mkIntCLit 1))
-        (CmmLit (mkIntCLit wORD_SIZE))
+        (cardRoundUp n)
+        (CmmLit (mkIntCLit 1)) -- no alignment (1 byte)
         live
-  where
-    -- Convert an element index to a card index
-    card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))
+
+-- Convert an element index to a card index
+card :: CmmExpr -> CmmExpr
+card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))
+
+-- Convert a number of elements to a number of cards, rounding up
+cardRoundUp :: CmmExpr -> CmmExpr
+cardRoundUp i = card (i `cmmAddWord` (CmmLit (mkIntCLit ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS) - 1))))
+
+bytesToWordsRoundUp :: CmmExpr -> CmmExpr
+bytesToWordsRoundUp e = (e `cmmAddWord` CmmLit (mkIntCLit (wORD_SIZE - 1)))
+                        `cmmQuotWord` wordSize
+
+wordSize :: CmmExpr
+wordSize = CmmLit (mkIntCLit wORD_SIZE)
 
 -- | Emit a call to @memcpy@.
 emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars

compiler/codeGen/StgCmmPrim.hs

@@ -50,6 +50,7 @@ import StaticFlags
 import Util
 
 import Control.Monad (liftM)
+import Data.Bits
 
 ------------------------------------------------------------------------
 --	Primitive operations and foreign calls
@@ -1080,10 +1081,8 @@ emitCloneArray info_p res_r src0 src_off0 n0 = do
     src_off <- assignTempE src_off0
     n       <- assignTempE n0
 
-    card_words <- assignTempE $ (n `cmmUShrWord`
-                                (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)))
-                  `cmmAddWord` CmmLit (mkIntCLit 1)
-    size <- assignTempE $ n `cmmAddWord` card_words
+    card_bytes <- assignTempE $ cardRoundUp n
+    size <- assignTempE $ n `cmmAddWord` bytesToWordsRoundUp card_bytes
     words <- assignTempE $ arrPtrsHdrSizeW `cmmAddWord` size
 
     arr_r <- newTemp bWord
@@ -1106,13 +1105,12 @@ emitCloneArray info_p res_r src0 src_off0 n0 = do
 
     emitMemsetCall (cmmOffsetExprW dst_p n)
         (CmmLit (mkIntCLit 1))
-        (card_words `cmmMulWord` wordSize)
+        card_bytes
         (CmmLit (mkIntCLit wORD_SIZE))
     emit $ mkAssign (CmmLocal res_r) arr
   where
     arrPtrsHdrSizeW = CmmLit $ mkIntCLit $ fixedHdrSize +
                       (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE)
-    wordSize = CmmLit (mkIntCLit wORD_SIZE)
     myCapability = CmmReg baseReg `cmmSubWord`
                    CmmLit (mkIntCLit oFFSET_Capability_r)
 
@@ -1124,12 +1122,23 @@ emitSetCards dst_start dst_cards_start n = do
     start_card <- assignTempE $ card dst_start
     emitMemsetCall (dst_cards_start `cmmAddWord` start_card)
         (CmmLit (mkIntCLit 1))
-        ((card (dst_start `cmmAddWord` n) `cmmSubWord` start_card)
-         `cmmAddWord` CmmLit (mkIntCLit 1))
-         (CmmLit (mkIntCLit wORD_SIZE))
-  where
-    -- Convert an element index to a card index
-    card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))
+        (cardRoundUp n)
+        (CmmLit (mkIntCLit 1)) -- no alignment (1 byte)
+
+-- Convert an element index to a card index
+card :: CmmExpr -> CmmExpr
+card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))
+
+-- Convert a number of elements to a number of cards, rounding up
+cardRoundUp :: CmmExpr -> CmmExpr
+cardRoundUp i = card (i `cmmAddWord` (CmmLit (mkIntCLit ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS) - 1))))
+
+bytesToWordsRoundUp :: CmmExpr -> CmmExpr
+bytesToWordsRoundUp e = (e `cmmAddWord` CmmLit (mkIntCLit (wORD_SIZE - 1)))
+                        `cmmQuotWord` wordSize
+
+wordSize :: CmmExpr
+wordSize = CmmLit (mkIntCLit wORD_SIZE)
 
 -- | Emit a call to @memcpy@.
 emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()

compiler/coreSyn/CoreUnfold.lhs

@@ -163,7 +163,7 @@ mkUnfolding src top_lvl is_bottoming expr
   , not (exprIsTrivial expr)
   = NoUnfolding    -- See Note [Do not inline top-level bottoming functions]
   | otherwise
-  = CoreUnfolding { uf_tmpl   	    = occ_anald_expr,
+  = CoreUnfolding { uf_tmpl   	    = occurAnalyseExpr expr,
     		    uf_src          = src,
     		    uf_arity        = arity,
 		    uf_is_top 	    = top_lvl,
@@ -173,19 +173,35 @@ mkUnfolding src top_lvl is_bottoming expr
 		    uf_is_work_free = exprIsWorkFree   expr,
 		    uf_guidance     = guidance }
   where
-    occ_anald_expr    = occurAnalyseExpr expr
-    (arity, guidance) = calcUnfoldingGuidance occ_anald_expr
-	-- Sometimes during simplification, there's a large let-bound thing	
-	-- which has been substituted, and so is now dead; so 'expr' contains
-	-- two copies of the thing while the occurrence-analysed expression doesn't
-	-- Nevertheless, we *don't* occ-analyse before computing the size because the
-	-- size computation bales out after a while, whereas occurrence analysis does not.
-	--
-	-- This can occasionally mean that the guidance is very pessimistic;
-	-- it gets fixed up next round.  And it should be rare, because large
-	-- let-bound things that are dead are usually caught by preInlineUnconditionally
+    (arity, guidance) = calcUnfoldingGuidance expr
+        -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))!
+	-- See Note [Calculate unfolding guidance on the non-occ-anal'd expression]
 \end{code}
 
+Note [Calculate unfolding guidance on the non-occ-anal'd expression]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Notice that we give the non-occur-analysed expression to
+calcUnfoldingGuidance.  In some ways it'd be better to occur-analyse
+first; for example, sometimes during simplification, there's a large
+let-bound thing which has been substituted, and so is now dead; so
+'expr' contains two copies of the thing while the occurrence-analysed
+expression doesn't.
+
+Nevertheless, we *don't* and *must not* occ-analyse before computing
+the size because 
+
+a) The size computation bales out after a while, whereas occurrence
+   analysis does not.
+
+b) Residency increases sharply if you occ-anal first.  I'm not 
+   100% sure why, but it's a large effect.  Compiling Cabal went 
+   from residency of 534M to over 800M with this one change.
+
+This can occasionally mean that the guidance is very pessimistic;
+it gets fixed up next round.  And it should be rare, because large
+let-bound things that are dead are usually caught by preInlineUnconditionally
+
+
 %************************************************************************
 %*									*
 \subsection{The UnfoldingGuidance type}
@@ -237,9 +253,17 @@ calcUnfoldingGuidance expr
       	                         , ug_size  = iBox size
       	        	  	 , ug_res   = iBox scrut_discount }
 
-        discount cbs bndr
-           = foldlBag (\acc (b',n) -> if bndr==b' then acc+n else acc) 
-		      0 cbs
+        discount :: Bag (Id,Int) -> Id -> Int
+        discount cbs bndr = foldlBag combine 0 cbs
+           where
+             combine acc (bndr', disc) 
+               | bndr == bndr' = acc `plus_disc` disc
+               | otherwise     = acc
+   
+             plus_disc :: Int -> Int -> Int
+             plus_disc | isFunTy (idType bndr) = max
+                       | otherwise             = (+)
+             -- See Note [Function and non-function discounts]
     in
     (n_val_bndrs, guidance) }
 \end{code}
@@ -549,8 +573,8 @@ funSize top_args fun n_val_args
 	-- the allocation cost, as in let(rec)
   
         --                  DISCOUNTS
-        --  See Note [Function application discounts]
-    arg_discount | some_val_args && one_call fun top_args
+        --  See Note [Function and non-function discounts]
+    arg_discount | some_val_args && fun `elem` top_args
     		 = unitBag (fun, opt_UF_FunAppDiscount)
 		 | otherwise = emptyBag
 	-- If the function is an argument and is applied
@@ -560,12 +584,6 @@ funSize top_args fun n_val_args
     		 | otherwise   	 	    = 0
         -- If the function is partially applied, show a result discount
 
-    one_call _   []                     = False
-    one_call fun (arg:args) | fun==arg  = case idOccInfo arg of
-                                           OneOcc _ one_branch _ -> one_branch
-                                           _                     -> False
-                            | otherwise = one_call fun args
-
 conSize :: DataCon -> Int -> ExprSize
 conSize dc n_val_args
   | n_val_args == 0 = SizeIs (_ILIT(0)) emptyBag (_ILIT(10))    -- Like variables
@@ -615,8 +633,8 @@ shrank binary sizes by 0.5% it also made spectral/boyer allocate 5%
 more. All other changes were very small. So it's not a big deal but I
 didn't adopt the idea.
 
-Note [Function application discount]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Function and non-function discounts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We want a discount if the function is applied. A good example is
 monadic combinators with continuation arguments, where inlining is
 quite important.
@@ -627,8 +645,15 @@ big it won't be inlined at its many call sites and no benefit results.
 Indeed, we can get exponentially big inlinings this way; that is what
 Trac #6048 is about.
 
-So, we only give a function-application discount when the function appears
-textually once, albeit possibly inside a lambda.
+On the other hand, for data-valued arguments, if there are lots of
+case expressions in the body, each one will get smaller if we apply
+the function to a constructor application, so we *want* a big discount
+if the argument is scrutinised by many case expressions.
+
+Conclusion:
+  - For functions, take the max of the discounts
+  - For data values, take the sum of the discounts
+
 
 Note [Literal integer size]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~

compiler/coreSyn/MkCore.lhs

@@ -102,14 +102,14 @@ infixl 4 `mkCoreApp`, `mkCoreApps`
 \begin{code}
 sortQuantVars :: [Var] -> [Var]
 -- Sort the variables (KindVars, TypeVars, and Ids) 
--- into order: Type, then Kind, then Id
+-- into order: Kind, then Type, then Id
 sortQuantVars = sortBy (comparing withCategory)
   where
     withCategory v = (category v, v)
     category :: Var -> Int
     category v
-     | isTyVar   v = 1
-     | isKindVar v = 2
+     | isKindVar v = 1
+     | isTyVar   v = 2
      | otherwise   = 3
 
 -- | Bind a binding group over an expression, using a @let@ or @case@ as

compiler/coreSyn/MkExternalCore.lhs

@@ -229,7 +229,8 @@ make_lit dflags l =
     MachWord64 i -> C.Lint i t
     MachFloat r -> C.Lrational r t
     MachDouble r -> C.Lrational r t
-    _ -> error "MkExternalCore died: make_lit"
+    LitInteger i _ -> C.Lint i t
+    _ -> pprPanic "MkExternalCore died: make_lit" (ppr l)
   where 
     t = make_ty dflags (literalType l)
 

compiler/deSugar/DsBinds.lhs

@@ -844,13 +844,14 @@ ds_tc_coercion subst tc_co
 
     ds_scc :: CvSubst -> SCC EvBind -> CvSubst
     ds_scc subst (AcyclicSCC (EvBind v ev_term))
-      = extendCvSubstAndInScope subst v (ds_ev_term subst ev_term)
+      = extendCvSubstAndInScope subst v (ds_co_term subst ev_term)
     ds_scc _ (CyclicSCC other) = pprPanic "ds_scc:cyclic" (ppr other $$ ppr tc_co)
 
-    ds_ev_term :: CvSubst -> EvTerm -> Coercion
-    ds_ev_term subst (EvCoercion tc_co) = ds_tc_coercion subst tc_co
-    ds_ev_term subst (EvId v)           = ds_ev_id subst v
-    ds_ev_term _ other = pprPanic "ds_ev_term" (ppr other $$ ppr tc_co)
+    ds_co_term :: CvSubst -> EvTerm -> Coercion
+    ds_co_term subst (EvCoercion tc_co) = ds_tc_coercion subst tc_co
+    ds_co_term subst (EvId v)           = ds_ev_id subst v
+    ds_co_term subst (EvCast tm co)     = mkCoCast (ds_co_term subst tm) (ds_tc_coercion subst co)
+    ds_co_term _ other = pprPanic "ds_co_term" (ppr other $$ ppr tc_co)
 
     ds_ev_id :: CvSubst -> EqVar -> Coercion
     ds_ev_id subst v

compiler/deSugar/DsMeta.hs

@@ -131,11 +131,12 @@ repTopDs group
 			val_ds  <- rep_val_binds (hs_valds group) ;
 			tycl_ds <- mapM repTyClD (concat (hs_tyclds group)) ;
 			inst_ds <- mapM repInstD (hs_instds group) ;
-			for_ds <- mapM repForD (hs_fords group) ;
+			rule_ds <- mapM repRuleD (hs_ruleds group) ;
+			for_ds  <- mapM repForD  (hs_fords group) ;
 			-- more needed
 			return (de_loc $ sort_by_loc $
                                 val_ds ++ catMaybes tycl_ds ++ fix_ds
-                                       ++ inst_ds ++ for_ds) }) ;
+                                       ++ inst_ds ++ rule_ds ++ for_ds) }) ;
 
 	decl_ty <- lookupType decQTyConName ;
 	let { core_list = coreList' decl_ty decls } ;
@@ -411,6 +412,25 @@ repFixD (L loc (FixitySig name (Fixity prec dir)))
        ; dec <- rep2 rep_fn [prec', name']
        ; return (loc, dec) }
 
+repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ)
+repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
+  = do { n'     <- coreStringLit $ unpackFS n
+       ; phases <- repPhases act
+       ; bndrs' <- mapM repRuleBndr bndrs >>= coreList ruleBndrQTyConName
+       ; lhs'   <- repLE lhs
+       ; rhs'   <- repLE rhs
+       ; pragma <- repPragRule n' bndrs' lhs' rhs' phases
+       ; return (loc, pragma) }
+
+repRuleBndr :: RuleBndr Name -> DsM (Core TH.RuleBndrQ)
+repRuleBndr (RuleBndr n)
+  = do { MkC n' <- lookupLOcc n
+       ; rep2 ruleVarName [n'] }
+repRuleBndr (RuleBndrSig n (HsWB { hswb_cts = ty }))
+  = do { MkC n'  <- lookupLOcc n
+       ; MkC ty' <- repLTy ty
+       ; rep2 typedRuleVarName [n', ty'] }
+
 ds_msg :: SDoc
 ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
 
@@ -541,6 +561,7 @@ rep_sig (L _   (GenericSig nm _))     = failWithDs msg
 
 rep_sig (L loc (InlineSig nm ispec))  = rep_inline nm ispec loc
 rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc
+rep_sig (L loc (SpecInstSig ty))      = rep_specialiseInst ty loc
 rep_sig _                             = return []
 
 rep_ty_sig :: SrcSpan -> LHsType Name -> Located Name
@@ -570,9 +591,11 @@ rep_inline :: Located Name
            -> SrcSpan
            -> DsM [(SrcSpan, Core TH.DecQ)]
 rep_inline nm ispec loc
-  = do { nm1 <- lookupLOcc nm
-       ; ispec1 <- rep_InlinePrag ispec
-       ; pragma <- repPragInl nm1 ispec1
+  = do { nm1    <- lookupLOcc nm
+       ; inline <- repInline $ inl_inline ispec
+       ; rm     <- repRuleMatch $ inl_rule ispec
+       ; phases <- repPhases $ inl_act ispec
+       ; pragma <- repPragInl nm1 inline rm phases
        ; return [(loc, pragma)]
        }
 
@@ -581,43 +604,39 @@ rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan
 rep_specialise nm ty ispec loc
   = do { nm1 <- lookupLOcc nm
        ; ty1 <- repLTy ty
-       ; pragma <- if isDefaultInlinePragma ispec
-                   then repPragSpec nm1 ty1                  -- SPECIALISE
-                   else do { ispec1 <- rep_InlinePrag ispec  -- SPECIALISE INLINE
-                           ; repPragSpecInl nm1 ty1 ispec1 }
+       ; phases <- repPhases $ inl_act ispec
+       ; let inline = inl_inline ispec
+       ; pragma <- if isEmptyInlineSpec inline
+                   then -- SPECIALISE
+                     repPragSpec nm1 ty1 phases
+                   else -- SPECIALISE INLINE
+                     do { inline1 <- repInline inline
+                        ; repPragSpecInl nm1 ty1 inline1 phases }
        ; return [(loc, pragma)]
        }
 
+rep_specialiseInst :: LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
+rep_specialiseInst ty loc
+  = do { ty1    <- repLTy ty
+       ; pragma <- repPragSpecInst ty1
+       ; return [(loc, pragma)] }
+
 repInline :: InlineSpec -> DsM (Core TH.Inline)
 repInline NoInline  = dataCon noInlineDataConName
 repInline Inline    = dataCon inlineDataConName
 repInline Inlinable = dataCon inlinableDataConName
 repInline spec      = notHandled "repInline" (ppr spec)
 
--- Extract all the information needed to build a TH.InlinePrag
---
-rep_InlinePrag :: InlinePragma	-- Never defaultInlinePragma
-               -> DsM (Core TH.InlineSpecQ)
-rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inline = inline })
-  | Just (flag, phase) <- activation1
-  = do { inline1 <- repInline inline
-       ; repInlineSpecPhase inline1 match1 flag phase }
-  | otherwise
-  = do { inline1 <- repInline inline
-       ; repInlineSpecNoPhase inline1 match1 }
-  where
-      match1      = coreBool (rep_RuleMatchInfo match)
-      activation1 = rep_Activation activation
-      rep_RuleMatchInfo FunLike = False
-      rep_RuleMatchInfo ConLike = True
-
-      rep_Activation NeverActive          = Nothing	-- We never have NOINLINE/AlwaysActive
-      rep_Activation AlwaysActive         = Nothing	-- or            INLINE/NeverActive
-      rep_Activation (ActiveBefore phase) = Just (coreBool False,
-                                                  MkC $ mkIntExprInt phase)
-      rep_Activation (ActiveAfter phase)  = Just (coreBool True,
-                                                  MkC $ mkIntExprInt phase)
+repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
+repRuleMatch ConLike = dataCon conLikeDataConName
+repRuleMatch FunLike = dataCon funLikeDataConName
 
+repPhases :: Activation -> DsM (Core TH.Phases)
+repPhases (ActiveBefore i) = do { MkC arg <- coreIntLit i
+                                ; dataCon' beforePhaseDataConName [arg] }
+repPhases (ActiveAfter i)  = do { MkC arg <- coreIntLit i
+                                ; dataCon' fromPhaseDataConName [arg] }
+repPhases _                = dataCon allPhasesDataConName
 
 -------------------------------------------------------
 -- 			Types
@@ -1389,9 +1408,12 @@ rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
 rep2 n xs = do { id <- dsLookupGlobalId n
                ; return (MkC (foldl App (Var id) xs)) }
 
+dataCon' :: Name -> [CoreExpr] -> DsM (Core a)
+dataCon' n args = do { id <- dsLookupDataCon n
+                     ; return $ MkC $ mkConApp id args }
+
 dataCon :: Name -> DsM (Core a)
-dataCon n = do { id <- dsLookupDataCon n
-               ; return $ MkC $ mkConApp id [] }
+dataCon n = dataCon' n []
 
 -- Then we make "repConstructors" which use the phantom types for each of the
 -- smart constructors of the Meta.Meta datatypes.
@@ -1603,16 +1625,28 @@ repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
   = rep2 classDName [cxt, cls, tvs, fds, ds]
 
-repPragInl :: Core TH.Name -> Core TH.InlineSpecQ -> DsM (Core TH.DecQ)
-repPragInl (MkC nm) (MkC ispec) = rep2 pragInlDName [nm, ispec]
+repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch
+           -> Core TH.Phases -> DsM (Core TH.DecQ)
+repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)
+  = rep2 pragInlDName [nm, inline, rm, phases]
+
+repPragSpec :: Core TH.Name -> Core TH.TypeQ -> Core TH.Phases
+            -> DsM (Core TH.DecQ)
+repPragSpec (MkC nm) (MkC ty) (MkC phases)
+  = rep2 pragSpecDName [nm, ty, phases]
 
-repPragSpec :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
-repPragSpec (MkC nm) (MkC ty) = rep2 pragSpecDName [nm, ty]
+repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.Inline
+               -> Core TH.Phases -> DsM (Core TH.DecQ)
+repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)
+  = rep2 pragSpecInlDName [nm, ty, inline, phases]
 
-repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.InlineSpecQ
-               -> DsM (Core TH.DecQ)
-repPragSpecInl (MkC nm) (MkC ty) (MkC ispec)
-  = rep2 pragSpecInlDName [nm, ty, ispec]
+repPragSpecInst :: Core TH.TypeQ -> DsM (Core TH.DecQ)
+repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
+
+repPragRule :: Core String -> Core [TH.RuleBndrQ] -> Core TH.ExpQ
+            -> Core TH.ExpQ -> Core TH.Phases -> DsM (Core TH.DecQ)
+repPragRule (MkC nm) (MkC bndrs) (MkC lhs) (MkC rhs) (MkC phases)
+  = rep2 pragRuleDName [nm, bndrs, lhs, rhs, phases]
 
 repFamilyNoKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
                 -> DsM (Core TH.DecQ)
@@ -1625,16 +1659,6 @@ repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
 repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki)
     = rep2 familyKindDName [flav, nm, tvs, ki]
 
-repInlineSpecNoPhase :: Core TH.Inline -> Core Bool
-                     -> DsM (Core TH.InlineSpecQ)
-repInlineSpecNoPhase (MkC inline) (MkC conlike)
-  = rep2 inlineSpecNoPhaseName [inline, conlike]
-
-repInlineSpecPhase :: Core TH.Inline -> Core Bool -> Core Bool -> Core Int
-                   -> DsM (Core TH.InlineSpecQ)
-repInlineSpecPhase (MkC inline) (MkC conlike) (MkC beforeFrom) (MkC phase)
-  = rep2 inlineSpecPhaseName [inline, conlike, beforeFrom, phase]
-
 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
 
@@ -1851,11 +1875,7 @@ nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
 coreStringLit :: String -> DsM (Core String)
 coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
 
------------- Bool, Literals & Variables -------------------
-
-coreBool :: Bool -> Core Bool
-coreBool False = MkC $ mkConApp falseDataCon []
-coreBool True  = MkC $ mkConApp trueDataCon  []
+------------ Literals & Variables -------------------
 
 coreIntLit :: Int -> DsM (Core Int)
 coreIntLit i = return (MkC (mkIntExprInt i))
@@ -1923,7 +1943,8 @@ templateHaskellNames = [
     -- Dec
     funDName, valDName, dataDName, newtypeDName, tySynDName,
     classDName, instanceDName, sigDName, forImpDName,
-    pragInlDName, pragSpecDName, pragSpecInlDName,
+    pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
+    pragRuleDName,
     familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName,
     tySynInstDName, infixLDName, infixRDName, infixNDName,
     -- Cxt
@@ -1957,8 +1978,12 @@ templateHaskellNames = [
     interruptibleName,
     -- Inline
     noInlineDataConName, inlineDataConName, inlinableDataConName,
-    -- InlineSpec
-    inlineSpecNoPhaseName, inlineSpecPhaseName,
+    -- RuleMatch
+    conLikeDataConName, funLikeDataConName,
+    -- Phases
+    allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName,
+    -- RuleBndr
+    ruleVarName, typedRuleVarName,
     -- FunDep
     funDepName,
     -- FamFlavour
@@ -1971,7 +1996,7 @@ templateHaskellNames = [
     varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
     typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,
     patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
-    predQTyConName, decsQTyConName,
+    predQTyConName, decsQTyConName, ruleBndrQTyConName,
 
     -- Quasiquoting
     quoteDecName, quoteTypeName, quoteExpName, quotePatName]
@@ -2130,29 +2155,31 @@ parSName    = libFun (fsLit "parS")    parSIdKey
 -- data Dec = ...
 funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
     instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
-    pragSpecInlDName, familyNoKindDName, familyKindDName, dataInstDName,
-    newtypeInstDName, tySynInstDName,
+    pragSpecInlDName, pragSpecInstDName, pragRuleDName, familyNoKindDName,
+    familyKindDName, dataInstDName, newtypeInstDName, tySynInstDName,
     infixLDName, infixRDName, infixNDName :: Name
-funDName         = libFun (fsLit "funD")         funDIdKey
-valDName         = libFun (fsLit "valD")         valDIdKey
-dataDName        = libFun (fsLit "dataD")        dataDIdKey
-newtypeDName     = libFun (fsLit "newtypeD")     newtypeDIdKey
-tySynDName       = libFun (fsLit "tySynD")       tySynDIdKey
-classDName       = libFun (fsLit "classD")       classDIdKey
-instanceDName    = libFun (fsLit "instanceD")    instanceDIdKey
-sigDName         = libFun (fsLit "sigD")         sigDIdKey
-forImpDName      = libFun (fsLit "forImpD")      forImpDIdKey
-pragInlDName     = libFun (fsLit "pragInlD")     pragInlDIdKey
-pragSpecDName    = libFun (fsLit "pragSpecD")    pragSpecDIdKey
-pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey
-familyNoKindDName= libFun (fsLit "familyNoKindD")familyNoKindDIdKey
-familyKindDName  = libFun (fsLit "familyKindD")  familyKindDIdKey
-dataInstDName    = libFun (fsLit "dataInstD")    dataInstDIdKey
-newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
-tySynInstDName   = libFun (fsLit "tySynInstD")   tySynInstDIdKey
-infixLDName      = libFun (fsLit "infixLD")      infixLDIdKey
-infixRDName      = libFun (fsLit "infixRD")      infixRDIdKey
-infixNDName      = libFun (fsLit "infixND")      infixNDIdKey
+funDName          = libFun (fsLit "funD")          funDIdKey
+valDName          = libFun (fsLit "valD")          valDIdKey
+dataDName         = libFun (fsLit "dataD")         dataDIdKey
+newtypeDName      = libFun (fsLit "newtypeD")      newtypeDIdKey
+tySynDName        = libFun (fsLit "tySynD")        tySynDIdKey
+classDName        = libFun (fsLit "classD")        classDIdKey
+instanceDName     = libFun (fsLit "instanceD")     instanceDIdKey
+sigDName          = libFun (fsLit "sigD")          sigDIdKey
+forImpDName       = libFun (fsLit "forImpD")       forImpDIdKey
+pragInlDName      = libFun (fsLit "pragInlD")      pragInlDIdKey
+pragSpecDName     = libFun (fsLit "pragSpecD")     pragSpecDIdKey
+pragSpecInlDName  = libFun (fsLit "pragSpecInlD")  pragSpecInlDIdKey
+pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey
+pragRuleDName     = libFun (fsLit "pragRuleD")     pragRuleDIdKey
+familyNoKindDName = libFun (fsLit "familyNoKindD") familyNoKindDIdKey
+familyKindDName   = libFun (fsLit "familyKindD")   familyKindDIdKey
+dataInstDName     = libFun (fsLit "dataInstD")     dataInstDIdKey
+newtypeInstDName  = libFun (fsLit "newtypeInstD")  newtypeInstDIdKey
+tySynInstDName    = libFun (fsLit "tySynInstD")    tySynInstDIdKey
+infixLDName       = libFun (fsLit "infixLD")       infixLDIdKey
+infixRDName       = libFun (fsLit "infixRD")       infixRDIdKey
+infixNDName       = libFun (fsLit "infixND")       infixNDIdKey
 
 -- type Ctxt = ...
 cxtName :: Name
@@ -2243,10 +2270,21 @@ noInlineDataConName  = thCon (fsLit "NoInline")  noInlineDataConKey
 inlineDataConName    = thCon (fsLit "Inline")    inlineDataConKey
 inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey
 
--- data InlineSpec = ...
-inlineSpecNoPhaseName, inlineSpecPhaseName :: Name
-inlineSpecNoPhaseName = libFun (fsLit "inlineSpecNoPhase") inlineSpecNoPhaseIdKey
-inlineSpecPhaseName   = libFun (fsLit "inlineSpecPhase")   inlineSpecPhaseIdKey
+-- data RuleMatch = ...
+conLikeDataConName, funLikeDataConName :: Name
+conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey
+funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey
+
+-- data Phases = ...
+allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name
+allPhasesDataConName   = thCon (fsLit "AllPhases")   allPhasesDataConKey
+fromPhaseDataConName   = thCon (fsLit "FromPhase")   fromPhaseDataConKey
+beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey
+
+-- data RuleBndr = ...
+ruleVarName, typedRuleVarName :: Name
+ruleVarName      = libFun (fsLit ("ruleVar"))      ruleVarIdKey
+typedRuleVarName = libFun (fsLit ("typedRuleVar")) typedRuleVarIdKey
 
 -- data FunDep = ...
 funDepName :: Name
@@ -2260,12 +2298,13 @@ dataFamName = libFun (fsLit "dataFam") dataFamIdKey
 matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
     decQTyConName, conQTyConName, strictTypeQTyConName,
     varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName,
-    patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName :: Name
-matchQTyConName         = libTc (fsLit "MatchQ")        matchQTyConKey
-clauseQTyConName        = libTc (fsLit "ClauseQ")       clauseQTyConKey
-expQTyConName           = libTc (fsLit "ExpQ")          expQTyConKey
-stmtQTyConName          = libTc (fsLit "StmtQ")         stmtQTyConKey
-decQTyConName           = libTc (fsLit "DecQ")          decQTyConKey
+    patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName,
+    ruleBndrQTyConName :: Name
+matchQTyConName         = libTc (fsLit "MatchQ")         matchQTyConKey
+clauseQTyConName        = libTc (fsLit "ClauseQ")        clauseQTyConKey
+expQTyConName           = libTc (fsLit "ExpQ")           expQTyConKey
+stmtQTyConName          = libTc (fsLit "StmtQ")          stmtQTyConKey
+decQTyConName           = libTc (fsLit "DecQ")           decQTyConKey
 decsQTyConName          = libTc (fsLit "DecsQ")          decsQTyConKey  -- Q [Dec]
 conQTyConName           = libTc (fsLit "ConQ")           conQTyConKey
 strictTypeQTyConName    = libTc (fsLit "StrictTypeQ")    strictTypeQTyConKey
@@ -2275,6 +2314,7 @@ fieldExpQTyConName      = libTc (fsLit "FieldExpQ")      fieldExpQTyConKey
 patQTyConName           = libTc (fsLit "PatQ")           patQTyConKey
 fieldPatQTyConName      = libTc (fsLit "FieldPatQ")      fieldPatQTyConKey
 predQTyConName          = libTc (fsLit "PredQ")          predQTyConKey
+ruleBndrQTyConName      = libTc (fsLit "RuleBndrQ")      ruleBndrQTyConKey
 
 -- quasiquoting
 quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name
@@ -2292,7 +2332,7 @@ expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
     decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,
     fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
     fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
-    predQTyConKey, decsQTyConKey :: Unique
+    predQTyConKey, decsQTyConKey, ruleBndrQTyConKey :: Unique
 expTyConKey             = mkPreludeTyConUnique 200
 matchTyConKey           = mkPreludeTyConUnique 201
 clauseTyConKey          = mkPreludeTyConUnique 202
@@ -2320,6 +2360,7 @@ predTyConKey            = mkPreludeTyConUnique 223
 predQTyConKey           = mkPreludeTyConUnique 224
 tyVarBndrTyConKey       = mkPreludeTyConUnique 225
 decsQTyConKey           = mkPreludeTyConUnique 226
+ruleBndrQTyConKey       = mkPreludeTyConUnique 227
 
 -- IdUniques available: 200-499
 -- If you want to change this, make sure you check in PrelNames
@@ -2443,7 +2484,8 @@ parSIdKey        = mkPreludeMiscIdUnique 323
 -- data Dec = ...
 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
     classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey,
-    pragSpecDIdKey, pragSpecInlDIdKey, familyNoKindDIdKey, familyKindDIdKey,
+    pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, pragRuleDIdKey,
+    familyNoKindDIdKey, familyKindDIdKey,
     dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey,
     infixLDIdKey, infixRDIdKey, infixNDIdKey :: Unique
 funDIdKey          = mkPreludeMiscIdUnique 330
@@ -2458,6 +2500,8 @@ forImpDIdKey       = mkPreludeMiscIdUnique 338
 pragInlDIdKey      = mkPreludeMiscIdUnique 339
 pragSpecDIdKey     = mkPreludeMiscIdUnique 340
 pragSpecInlDIdKey  = mkPreludeMiscIdUnique 341
+pragSpecInstDIdKey = mkPreludeMiscIdUnique 412
+pragRuleDIdKey     = mkPreludeMiscIdUnique 413
 familyNoKindDIdKey = mkPreludeMiscIdUnique 342
 familyKindDIdKey   = mkPreludeMiscIdUnique 343
 dataInstDIdKey     = mkPreludeMiscIdUnique 344
@@ -2556,10 +2600,16 @@ noInlineDataConKey  = mkPreludeDataConUnique 40
 inlineDataConKey    = mkPreludeDataConUnique 41
 inlinableDataConKey = mkPreludeDataConUnique 42
 
--- data InlineSpec =
-inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique
-inlineSpecNoPhaseIdKey = mkPreludeMiscIdUnique 412
-inlineSpecPhaseIdKey   = mkPreludeMiscIdUnique 413
+-- data RuleMatch = ...
+conLikeDataConKey, funLikeDataConKey :: Unique
+conLikeDataConKey = mkPreludeDataConUnique 43
+funLikeDataConKey = mkPreludeDataConUnique 44
+
+-- data Phases = ...
+allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique
+allPhasesDataConKey   = mkPreludeDataConUnique 45
+fromPhaseDataConKey   = mkPreludeDataConUnique 46
+beforePhaseDataConKey = mkPreludeDataConUnique 47
 
 -- data FunDep = ...
 funDepIdKey :: Unique
@@ -2576,3 +2626,8 @@ quoteExpKey  = mkPreludeMiscIdUnique 418
 quotePatKey  = mkPreludeMiscIdUnique 419
 quoteDecKey  = mkPreludeMiscIdUnique 420
 quoteTypeKey = mkPreludeMiscIdUnique 421
+
+-- data RuleBndr = ...
+ruleVarIdKey, typedRuleVarIdKey :: Unique
+ruleVarIdKey      = mkPreludeMiscIdUnique 422
+typedRuleVarIdKey = mkPreludeMiscIdUnique 423

compiler/ghc.cabal.in

@@ -49,7 +49,7 @@ Library
     Exposed: False
 
     Build-Depends: base       >= 4   && < 5,
-                   directory  >= 1   && < 1.2,
+                   directory  >= 1   && < 1.3,
                    process    >= 1   && < 1.2,
                    bytestring >= 0.9 && < 0.11,
                    time                 < 1.5,

compiler/ghci/RtClosureInspect.hs

@@ -749,7 +749,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
                         -- In such case, we return a best approximation:
                         --  ignore the unpointed args, and recover the pointeds
                         -- This preserves laziness, and should be safe.
-		       traceTR (text "Nothing" <+> ppr dcname)
+		       traceTR (text "Not constructor" <+> ppr dcname)
                        let dflags = hsc_dflags hsc_env
                            tag = showPpr dflags dcname
                        vars     <- replicateM (length$ elems$ ptrs clos) 
@@ -758,7 +758,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
                                               | (i, tv) <- zip [0..] vars]
                        return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
           Just dc -> do
-            traceTR (text "Just" <+> ppr dc)
+            traceTR (text "Is constructor" <+> (ppr dc $$ ppr my_ty))
             subTtypes <- getDataConArgTys dc my_ty
             subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) clos subTtypes
             return (Term my_ty (Right dc) a subTerms)
@@ -936,14 +936,16 @@ getDataConArgTys :: DataCon -> Type -> TR [Type]
 -- not be fully known.  Moreover, the arg types might involve existentials;
 -- if so, make up fresh RTTI type variables for them
 getDataConArgTys dc con_app_ty
-  = do { (_, ex_tys, _) <- instTyVars ex_tvs
+  = do { (_, ex_tys, ex_subst) <- instTyVars ex_tvs
        ; let UnaryRep rep_con_app_ty = repType con_app_ty
+       ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty))
        ; ty_args <- case tcSplitTyConApp_maybe rep_con_app_ty of
                        Just (tc, ty_args) | dataConTyCon dc == tc
 		       	   -> ASSERT( univ_tvs `equalLength` ty_args) 
                               return ty_args
- 		       _   -> do { (_, ty_args, subst) <- instTyVars univ_tvs
-		       	         ; let res_ty = substTy subst (dataConOrigResTy dc)
+ 		       _   -> do { (_, ty_args, univ_subst) <- instTyVars univ_tvs
+		       	         ; let res_ty = substTy ex_subst (substTy univ_subst (dataConOrigResTy dc))
+                                   -- See Note [Constructor arg types]
                                  ; addConstraint rep_con_app_ty res_ty
                                  ; return ty_args }
 		-- It is necessary to check dataConTyCon dc == tc
@@ -951,11 +953,38 @@ getDataConArgTys dc con_app_ty
       		-- newtype and tcSplitTyConApp has not removed it. In
       		-- that case, we happily give up and don't match
        ; let subst = zipTopTvSubst (univ_tvs ++ ex_tvs) (ty_args ++ ex_tys)
+       ; traceTR (text "getDataConArgTys 2" <+> (ppr rep_con_app_ty $$ ppr ty_args $$ ppr subst))
        ; return (substTys subst (dataConRepArgTys dc)) }
   where
     univ_tvs = dataConUnivTyVars dc
     ex_tvs   = dataConExTyVars dc
 
+{- Note [Constructor arg types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider a GADT (cf Trac #7386)
+   data family D a b
+   data instance D [a] b where
+     MkT :: b -> D [a] (Maybe b)
+
+In getDataConArgTys
+* con_app_ty is the known type (from outside) of the constructor application, 
+  say D [Int] Bool
+
+* The data constructor MkT has a (representation) dataConTyCon = DList,
+  say where
+    data DList a b where
+      MkT :: b -> DList a (Maybe b)
+
+So the dataConTyCon of the data constructor, DList, differs from 
+the "outside" type, D. So we can't straightforwardly decompose the
+"outside" type, and we end up in the "_" branch of the case.
+
+Then we match the dataConOrigResTy of the data constructor against the
+outside type, hoping to get a substituion that tells how to instantiate
+the *representation* type constructor.   This looks a bit delicate to
+me, but it seems to work.
+-}
+
 -- Soundness checks
 --------------------
 {-

compiler/hsSyn/Convert.lhs

@@ -157,8 +157,7 @@ cvtDec (TH.InfixD fx nm)
        ; returnL (Hs.SigD (FixSig (FixitySig nm' (cvtFixity fx)))) }
 
 cvtDec (PragmaD prag)
-  = do { prag' <- cvtPragmaD prag
-       ; returnL $ Hs.SigD prag' }
+  = cvtPragmaD prag
 
 cvtDec (TySynD tc tvs rhs)
   = do	{ (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
@@ -410,38 +409,69 @@ cvt_conv TH.StdCall = StdCallConv
 --              Pragmas
 ------------------------------------------
 
-cvtPragmaD :: Pragma -> CvtM (Sig RdrName)
-cvtPragmaD (InlineP nm ispec)
-  = do { nm'    <- vNameL nm
-       ; return $ InlineSig nm' (cvtInlineSpec (Just ispec)) }
-
-cvtPragmaD (SpecialiseP nm ty opt_ispec)
+cvtPragmaD :: Pragma -> CvtM (LHsDecl RdrName)
+cvtPragmaD (InlineP nm inline rm phases)
+  = do { nm' <- vNameL nm
+       ; let dflt = dfltActivation inline
+       ; let ip   = InlinePragma { inl_inline = cvtInline inline
+                                 , inl_rule   = cvtRuleMatch rm
+                                 , inl_act    = cvtPhases phases dflt
+                                 , inl_sat    = Nothing }
+       ; returnL $ Hs.SigD $ InlineSig nm' ip }
+
+cvtPragmaD (SpecialiseP nm ty inline phases)
   = do { nm' <- vNameL nm
        ; ty' <- cvtType ty
-       ; return $ SpecSig nm' ty' (cvtInlineSpec opt_ispec) }
-
-cvtInlineSpec :: Maybe TH.InlineSpec -> Hs.InlinePragma
-cvtInlineSpec Nothing
-  = defaultInlinePragma
-cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation))
-  = InlinePragma { inl_act = opt_activation', inl_rule = matchinfo
-                 , inl_inline = inl_spec, inl_sat = Nothing }
-  where
-    matchinfo       = cvtRuleMatchInfo conlike
-    opt_activation' = cvtActivation opt_activation
-
-    cvtRuleMatchInfo False = FunLike
-    cvtRuleMatchInfo True  = ConLike
-
-    inl_spec = case inline of
-                 TH.NoInline  -> Hs.NoInline
-                 TH.Inline    -> Hs.Inline
-                 TH.Inlinable -> Hs.Inlinable
+       ; let (inline', dflt) = case inline of
+               Just inline1 -> (cvtInline inline1, dfltActivation inline1)
+               Nothing      -> (EmptyInlineSpec,   AlwaysActive)
+       ; let ip = InlinePragma { inl_inline = inline'
+                               , inl_rule   = Hs.FunLike
+                               , inl_act    = cvtPhases phases dflt
+                               , inl_sat    = Nothing }
+       ; returnL $ Hs.SigD $ SpecSig nm' ty' ip }
+
+cvtPragmaD (SpecialiseInstP ty)
+  = do { ty' <- cvtType ty
+       ; returnL $ Hs.SigD $ SpecInstSig ty' }
+
+cvtPragmaD (RuleP nm bndrs lhs rhs phases)
+  = do { let nm' = mkFastString nm
+       ; let act = cvtPhases phases AlwaysActive
+       ; bndrs' <- mapM cvtRuleBndr bndrs
+       ; lhs'   <- cvtl lhs
+       ; rhs'   <- cvtl rhs
+       ; returnL $ Hs.RuleD $ HsRule nm' act bndrs'
+                                     lhs' placeHolderNames
+                                     rhs' placeHolderNames
+       }
 
-    cvtActivation Nothing | inline == TH.NoInline = NeverActive
-                          | otherwise             = AlwaysActive
-    cvtActivation (Just (False, phase)) = ActiveBefore phase
-    cvtActivation (Just (True , phase)) = ActiveAfter  phase
+dfltActivation :: TH.Inline -> Activation
+dfltActivation TH.NoInline = NeverActive
+dfltActivation _           = AlwaysActive
+
+cvtInline :: TH.Inline -> Hs.InlineSpec
+cvtInline TH.NoInline  = Hs.NoInline
+cvtInline TH.Inline    = Hs.Inline
+cvtInline TH.Inlinable = Hs.Inlinable
+
+cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo
+cvtRuleMatch TH.ConLike = Hs.ConLike
+cvtRuleMatch TH.FunLike = Hs.FunLike
+
+cvtPhases :: TH.Phases -> Activation -> Activation
+cvtPhases AllPhases       dflt = dflt
+cvtPhases (FromPhase i)   _    = ActiveAfter i
+cvtPhases (BeforePhase i) _    = ActiveBefore i
+
+cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.RuleBndr RdrName)
+cvtRuleBndr (RuleVar n)
+  = do { n' <- vNameL n
+       ; return $ Hs.RuleBndr n' }
+cvtRuleBndr (TypedRuleVar n ty)
+  = do { n'  <- vNameL n
+       ; ty' <- cvtType ty
+       ; return $ Hs.RuleBndrSig n' $ mkHsWithBndrs ty' }
 
 ---------------------------------------------------
 --		Declarations

compiler/hsSyn/HsBinds.lhs

@@ -573,22 +573,6 @@ Check if signatures overlap; this is used when checking for duplicate
 signatures. Since some of the signatures contain a list of names, testing for
 equality is not enough -- we have to check if they overlap.
 
-\begin{code}
-overlapHsSig :: Eq a => LSig a -> LSig a -> Bool
-overlapHsSig sig1 sig2 = case (unLoc sig1, unLoc sig2) of
-  (FixSig (FixitySig n1 _), FixSig (FixitySig n2 _)) -> unLoc n1 == unLoc n2
-  (IdSig n1,                IdSig n2)                -> n1 == n2
-  (TypeSig ns1 _,           TypeSig ns2 _)           -> ns1 `overlaps_with` ns2
-  (GenericSig ns1 _,        GenericSig ns2 _)        -> ns1 `overlaps_with` ns2
-  (InlineSig n1 _,          InlineSig n2 _)          -> unLoc n1 == unLoc n2
-  -- For specialisations, we don't have equality over HsType, so it's not
-  -- convenient to spot duplicate specialisations here.  Check for this later,
-  -- when we're in Type land
-  (_other1,                 _other2)                 -> False
-  where
-    ns1 `overlaps_with` ns2 = not (null (intersect (map unLoc ns1) (map unLoc ns2)))
-\end{code}
-
 \begin{code}
 instance (OutputableBndr name) => Outputable (Sig name) where
     ppr sig = ppr_sig sig

compiler/iface/IfaceSyn.lhs

@@ -24,6 +24,7 @@ module IfaceSyn (
 
         -- Misc
         ifaceDeclImplicitBndrs, visibleIfConDecls,
+        ifaceDeclFingerprints,
 
         -- Free Names
         freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst,
@@ -51,6 +52,10 @@ import Outputable
 import FastString
 import Module
 import TysWiredIn ( eqTyConName )
+import Fingerprint
+import Binary
+
+import GHC.IO (unsafeDupablePerformIO)
 
 infixl 3 &&&
 \end{code}
@@ -448,6 +453,23 @@ ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ,
 
 ifaceDeclImplicitBndrs _ = []
 
+-- -----------------------------------------------------------------------------
+-- The fingerprints of an IfaceDecl
+
+       -- We better give each name bound by the declaration a
+       -- different fingerprint!  So we calculate the fingerprint of
+       -- each binder by combining the fingerprint of the whole
+       -- declaration with the name of the binder. (#5614, #7215)
+ifaceDeclFingerprints :: Fingerprint -> IfaceDecl -> [(OccName,Fingerprint)]
+ifaceDeclFingerprints hash decl
+  = (ifName decl, hash) :
+    [ (occ, computeFingerprint' (hash,occ))
+    | occ <- ifaceDeclImplicitBndrs decl ]
+  where
+     computeFingerprint' =
+       unsafeDupablePerformIO
+        . computeFingerprint (panic "ifaceDeclFingerprints")
+
 ----------------------------- Printing IfaceDecl ------------------------------
 
 instance Outputable IfaceDecl where

compiler/iface/IfaceType.lhs

@@ -195,7 +195,7 @@ pprParendIfaceType = ppr_ty tYCON_PREC
 isIfacePredTy :: IfaceType -> Bool
 isIfacePredTy _  = False
 -- FIXME: fix this to print iface pred tys correctly
--- isIfacePredTy ty = ifaceTypeKind ty `eqKind` constraintKind
+-- isIfacePredTy ty = isConstraintKind (ifaceTypeKind ty)
 
 ppr_ty :: Int -> IfaceType -> SDoc
 ppr_ty _         (IfaceTyVar tyvar)     = ppr tyvar

compiler/iface/MkIface.lhs

@@ -530,25 +530,12 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
        -- to assign fingerprints to all the OccNames that it binds, to
        -- use when referencing those OccNames in later declarations.
        --
-       -- We better give each name bound by the declaration a
-       -- different fingerprint!  So we calculate the fingerprint of
-       -- each binder by combining the fingerprint of the whole
-       -- declaration with the name of the binder. (#5614)
        extend_hash_env :: OccEnv (OccName,Fingerprint)
                        -> (Fingerprint,IfaceDecl)
                        -> IO (OccEnv (OccName,Fingerprint))
        extend_hash_env env0 (hash,d) = do
-          let
-            sub_bndrs = ifaceDeclImplicitBndrs d
-            fp_sub_bndr occ = computeFingerprint putNameLiterally (hash,occ)
-          --
-          sub_fps <- mapM fp_sub_bndr sub_bndrs
-          return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env1
-                        (zip sub_bndrs sub_fps))
-        where
-          decl_name = ifName d
-          item = (decl_name, hash)
-          env1 = extendOccEnv env0 decl_name item
+          return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0
+                 (ifaceDeclFingerprints hash d))
 
    --
    (local_env, decls_w_hashes) <- 
@@ -1498,8 +1485,12 @@ tyConToIfaceDecl env tycon
 
     (syn_rhs, syn_ki) 
        = case synTyConRhs tycon of
-            SynFamilyTyCon  -> (Nothing,               tidyToIfaceType env1 (synTyConResKind tycon))
-            SynonymTyCon ty -> (Just (toIfaceType ty), tidyToIfaceType env1 (typeKind ty))
+            SynFamilyTyCon  ->
+               ( Nothing
+               , tidyToIfaceType env1 (synTyConResKind tycon) )
+            SynonymTyCon ty ->
+               ( Just (tidyToIfaceType env1 ty)
+               , tidyToIfaceType env1 (typeKind ty) )
 
     ifaceConDecls (NewTyCon { data_con = con })     = IfNewTyCon  (ifaceConDecl con)
     ifaceConDecls (DataTyCon { data_cons = cons })  = IfDataTyCon (map ifaceConDecl cons)
@@ -1517,16 +1508,19 @@ tyConToIfaceDecl env tycon
                     ifConUnivTvs = toIfaceTvBndrs univ_tvs',
                     ifConExTvs   = toIfaceTvBndrs ex_tvs',
                     ifConEqSpec  = to_eq_spec eq_spec,
-                    ifConCtxt    = tidyToIfaceContext env3 theta,
-                    ifConArgTys  = map (tidyToIfaceType env3) arg_tys,
+                    ifConCtxt    = tidyToIfaceContext env2 theta,
+                    ifConArgTys  = map (tidyToIfaceType env2) arg_tys,
                     ifConFields  = map getOccName 
                                        (dataConFieldLabels data_con),
                     ifConStricts = dataConStrictMarks data_con }
         where
           (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
-          (env2, univ_tvs') = tidyTyClTyVarBndrs env1 univ_tvs
-          (env3, ex_tvs')   = tidyTyVarBndrs env2 ex_tvs
-          to_eq_spec spec = [ (getOccName (tidyTyVar env3 tv), tidyToIfaceType env3 ty) 
+
+          -- Start with 'emptyTidyEnv' not 'env1', because the type of the
+          -- data constructor is fully standalone
+          (env1, univ_tvs') = tidyTyVarBndrs emptyTidyEnv univ_tvs
+          (env2, ex_tvs')   = tidyTyVarBndrs env1 ex_tvs
+          to_eq_spec spec = [ (getOccName (tidyTyVar env2 tv), tidyToIfaceType env2 ty) 
                             | (tv,ty) <- spec]