merged master into late-dmdlate-dmd

6 files changed, 418 insertions, 345 deletions

diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 19acf488e0..3e5384bc5f 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -233,13 +233,13 @@ basicKnownKeyNames
         -- Strings and lists
         unpackCStringName,
         unpackCStringFoldrName, unpackCStringUtf8Name,
-        
+
         -- Overloaded lists
         isListClassName,
         fromListName,
         fromListNName,
         toListName,
-        
+
         -- List operations
         concatName, filterName, mapName,
         zipName, foldrName, buildName, augmentName, appendName,
@@ -265,11 +265,11 @@ basicKnownKeyNames
         plusIntegerName, timesIntegerName, smallIntegerName,
         wordToIntegerName,
         integerToWordName, integerToIntName, minusIntegerName,
-        negateIntegerName, eqIntegerName, neqIntegerName,
+        negateIntegerName, eqIntegerPrimName, neqIntegerPrimName,
         absIntegerName, signumIntegerName,
-        leIntegerName, gtIntegerName, ltIntegerName, geIntegerName,
+        leIntegerPrimName, gtIntegerPrimName, ltIntegerPrimName, geIntegerPrimName,
         compareIntegerName, quotRemIntegerName, divModIntegerName,
-        quotIntegerName, remIntegerName,
+        quotIntegerName, remIntegerName, divIntegerName, modIntegerName,
         floatFromIntegerName, doubleFromIntegerName,
         encodeFloatIntegerName, encodeDoubleIntegerName,
         decodeDoubleIntegerName,
@@ -350,8 +350,7 @@ genericTyConNames = [
 pRELUDE :: Module
 pRELUDE         = mkBaseModule_ pRELUDE_NAME
 
-gHC_PRIM, gHC_TYPES, gHC_GENERICS,
-    gHC_MAGIC,
+gHC_PRIM, gHC_PRIMWRAPPERS, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
     gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING,
     gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER_TYPE, gHC_LIST,
     gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, dATA_MONOID,
@@ -364,6 +363,7 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS,
     cONTROL_EXCEPTION_BASE, gHC_TYPELITS, gHC_IP :: Module
 
 gHC_PRIM        = mkPrimModule (fsLit "GHC.Prim")   -- Primitive types and values
+gHC_PRIMWRAPPERS = mkPrimModule (fsLit "GHC.PrimWrappers")
 gHC_TYPES       = mkPrimModule (fsLit "GHC.Types")
 gHC_MAGIC       = mkPrimModule (fsLit "GHC.Magic")
 gHC_CSTRING     = mkPrimModule (fsLit "GHC.CString")
@@ -558,9 +558,8 @@ unpackCString_RDR       = nameRdrName unpackCStringName
 unpackCStringFoldr_RDR  = nameRdrName unpackCStringFoldrName
 unpackCStringUtf8_RDR   = nameRdrName unpackCStringUtf8Name
 
-newStablePtr_RDR, wordDataCon_RDR :: RdrName
+newStablePtr_RDR :: RdrName
 newStablePtr_RDR        = nameRdrName newStablePtrName
-wordDataCon_RDR         = dataQual_RDR gHC_TYPES (fsLit "W#")
 
 bindIO_RDR, returnIO_RDR :: RdrName
 bindIO_RDR              = nameRdrName bindIOName
@@ -617,11 +616,12 @@ punc_RDR                = dataQual_RDR lEX (fsLit "Punc")
 ident_RDR               = dataQual_RDR lEX (fsLit "Ident")
 symbol_RDR              = dataQual_RDR lEX (fsLit "Symbol")
 
-step_RDR, alt_RDR, reset_RDR, prec_RDR :: RdrName
+step_RDR, alt_RDR, reset_RDR, prec_RDR, pfail_RDR :: RdrName
 step_RDR                = varQual_RDR  rEAD_PREC (fsLit "step")
 alt_RDR                 = varQual_RDR  rEAD_PREC (fsLit "+++")
 reset_RDR               = varQual_RDR  rEAD_PREC (fsLit "reset")
 prec_RDR                = varQual_RDR  rEAD_PREC (fsLit "prec")
+pfail_RDR               = varQual_RDR  rEAD_PREC (fsLit "pfail")
 
 showList_RDR, showList___RDR, showsPrec_RDR, showString_RDR,
     showSpace_RDR, showParen_RDR :: RdrName
@@ -798,10 +798,6 @@ stringTyConName         = tcQual  gHC_BASE (fsLit "String") stringTyConKey
 inlineIdName :: Name
 inlineIdName            = varQual gHC_MAGIC (fsLit "inline") inlineIdKey
 
--- The 'undefined' function. Used by supercompilation.
-undefinedName :: Name
-undefinedName = varQual gHC_ERR (fsLit "undefined") undefinedKey
-
 -- Base classes (Eq, Ord, Functor)
 fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name
 eqClassName       = clsQual  gHC_CLASSES (fsLit "Eq")      eqClassKey
@@ -885,11 +881,11 @@ integerTyConName, mkIntegerName,
     plusIntegerName, timesIntegerName, smallIntegerName,
     wordToIntegerName,
     integerToWordName, integerToIntName, minusIntegerName,
-    negateIntegerName, eqIntegerName, neqIntegerName,
+    negateIntegerName, eqIntegerPrimName, neqIntegerPrimName,
     absIntegerName, signumIntegerName,
-    leIntegerName, gtIntegerName, ltIntegerName, geIntegerName,
+    leIntegerPrimName, gtIntegerPrimName, ltIntegerPrimName, geIntegerPrimName,
     compareIntegerName, quotRemIntegerName, divModIntegerName,
-    quotIntegerName, remIntegerName,
+    quotIntegerName, remIntegerName, divIntegerName, modIntegerName,
     floatFromIntegerName, doubleFromIntegerName,
     encodeFloatIntegerName, encodeDoubleIntegerName,
     decodeDoubleIntegerName,
@@ -910,19 +906,21 @@ integerToWordName     = varQual gHC_INTEGER_TYPE (fsLit "integerToWord")     int
 integerToIntName      = varQual gHC_INTEGER_TYPE (fsLit "integerToInt")      integerToIntIdKey
 minusIntegerName      = varQual gHC_INTEGER_TYPE (fsLit "minusInteger")      minusIntegerIdKey
 negateIntegerName     = varQual gHC_INTEGER_TYPE (fsLit "negateInteger")     negateIntegerIdKey
-eqIntegerName         = varQual gHC_INTEGER_TYPE (fsLit "eqInteger")         eqIntegerIdKey
-neqIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "neqInteger")        neqIntegerIdKey
+eqIntegerPrimName     = varQual gHC_INTEGER_TYPE (fsLit "eqInteger#")        eqIntegerPrimIdKey
+neqIntegerPrimName    = varQual gHC_INTEGER_TYPE (fsLit "neqInteger#")       neqIntegerPrimIdKey
 absIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "absInteger")        absIntegerIdKey
 signumIntegerName     = varQual gHC_INTEGER_TYPE (fsLit "signumInteger")     signumIntegerIdKey
-leIntegerName         = varQual gHC_INTEGER_TYPE (fsLit "leInteger")         leIntegerIdKey
-gtIntegerName         = varQual gHC_INTEGER_TYPE (fsLit "gtInteger")         gtIntegerIdKey
-ltIntegerName         = varQual gHC_INTEGER_TYPE (fsLit "ltInteger")         ltIntegerIdKey
-geIntegerName         = varQual gHC_INTEGER_TYPE (fsLit "geInteger")         geIntegerIdKey
+leIntegerPrimName     = varQual gHC_INTEGER_TYPE (fsLit "leInteger#")        leIntegerPrimIdKey
+gtIntegerPrimName     = varQual gHC_INTEGER_TYPE (fsLit "gtInteger#")        gtIntegerPrimIdKey
+ltIntegerPrimName     = varQual gHC_INTEGER_TYPE (fsLit "ltInteger#")        ltIntegerPrimIdKey
+geIntegerPrimName     = varQual gHC_INTEGER_TYPE (fsLit "geInteger#")        geIntegerPrimIdKey
 compareIntegerName    = varQual gHC_INTEGER_TYPE (fsLit "compareInteger")    compareIntegerIdKey
 quotRemIntegerName    = varQual gHC_INTEGER_TYPE (fsLit "quotRemInteger")    quotRemIntegerIdKey
 divModIntegerName     = varQual gHC_INTEGER_TYPE (fsLit "divModInteger")     divModIntegerIdKey
 quotIntegerName       = varQual gHC_INTEGER_TYPE (fsLit "quotInteger")       quotIntegerIdKey
 remIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "remInteger")        remIntegerIdKey
+divIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "divInteger")        divIntegerIdKey
+modIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "modInteger")        modIntegerIdKey
 floatFromIntegerName  = varQual gHC_INTEGER_TYPE (fsLit "floatFromInteger")      floatFromIntegerIdKey
 doubleFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "doubleFromInteger")     doubleFromIntegerIdKey
 encodeFloatIntegerName  = varQual gHC_INTEGER_TYPE (fsLit "encodeFloatInteger")  encodeFloatIntegerIdKey
@@ -1336,11 +1334,13 @@ statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey,
     word32PrimTyConKey, word32TyConKey, word64PrimTyConKey, word64TyConKey,
     liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey,
     typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey,
-    funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey :: Unique
+    funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey,
+    eqReprPrimTyConKey :: Unique
 statePrimTyConKey                       = mkPreludeTyConUnique 50
 stableNamePrimTyConKey                  = mkPreludeTyConUnique 51
 stableNameTyConKey                      = mkPreludeTyConUnique 52
 eqPrimTyConKey                          = mkPreludeTyConUnique 53
+eqReprPrimTyConKey                      = mkPreludeTyConUnique 54
 mutVarPrimTyConKey                      = mkPreludeTyConUnique 55
 ioTyConKey                              = mkPreludeTyConUnique 56
 wordPrimTyConKey                        = mkPreludeTyConUnique 58
@@ -1594,10 +1594,10 @@ mkIntegerIdKey, smallIntegerIdKey, wordToIntegerIdKey,
     word64ToIntegerIdKey, int64ToIntegerIdKey,
     plusIntegerIdKey, timesIntegerIdKey, minusIntegerIdKey,
     negateIntegerIdKey,
-    eqIntegerIdKey, neqIntegerIdKey, absIntegerIdKey, signumIntegerIdKey,
-    leIntegerIdKey, gtIntegerIdKey, ltIntegerIdKey, geIntegerIdKey,
+    eqIntegerPrimIdKey, neqIntegerPrimIdKey, absIntegerIdKey, signumIntegerIdKey,
+    leIntegerPrimIdKey, gtIntegerPrimIdKey, ltIntegerPrimIdKey, geIntegerPrimIdKey,
     compareIntegerIdKey, quotRemIntegerIdKey, divModIntegerIdKey,
-    quotIntegerIdKey, remIntegerIdKey,
+    quotIntegerIdKey, remIntegerIdKey, divIntegerIdKey, modIntegerIdKey,
     floatFromIntegerIdKey, doubleFromIntegerIdKey,
     encodeFloatIntegerIdKey, encodeDoubleIntegerIdKey,
     decodeDoubleIntegerIdKey,
@@ -1614,44 +1614,46 @@ plusIntegerIdKey              = mkPreludeMiscIdUnique 66
 timesIntegerIdKey             = mkPreludeMiscIdUnique 67
 minusIntegerIdKey             = mkPreludeMiscIdUnique 68
 negateIntegerIdKey            = mkPreludeMiscIdUnique 69
-eqIntegerIdKey                = mkPreludeMiscIdUnique 70
-neqIntegerIdKey               = mkPreludeMiscIdUnique 71
+eqIntegerPrimIdKey            = mkPreludeMiscIdUnique 70
+neqIntegerPrimIdKey           = mkPreludeMiscIdUnique 71
 absIntegerIdKey               = mkPreludeMiscIdUnique 72
 signumIntegerIdKey            = mkPreludeMiscIdUnique 73
-leIntegerIdKey                = mkPreludeMiscIdUnique 74
-gtIntegerIdKey                = mkPreludeMiscIdUnique 75
-ltIntegerIdKey                = mkPreludeMiscIdUnique 76
-geIntegerIdKey                = mkPreludeMiscIdUnique 77
+leIntegerPrimIdKey            = mkPreludeMiscIdUnique 74
+gtIntegerPrimIdKey            = mkPreludeMiscIdUnique 75
+ltIntegerPrimIdKey            = mkPreludeMiscIdUnique 76
+geIntegerPrimIdKey            = mkPreludeMiscIdUnique 77
 compareIntegerIdKey           = mkPreludeMiscIdUnique 78
-quotRemIntegerIdKey           = mkPreludeMiscIdUnique 79
-divModIntegerIdKey            = mkPreludeMiscIdUnique 80
-quotIntegerIdKey              = mkPreludeMiscIdUnique 81
-remIntegerIdKey               = mkPreludeMiscIdUnique 82
-floatFromIntegerIdKey         = mkPreludeMiscIdUnique 83
-doubleFromIntegerIdKey        = mkPreludeMiscIdUnique 84
-encodeFloatIntegerIdKey       = mkPreludeMiscIdUnique 85
-encodeDoubleIntegerIdKey      = mkPreludeMiscIdUnique 86
-gcdIntegerIdKey               = mkPreludeMiscIdUnique 87
-lcmIntegerIdKey               = mkPreludeMiscIdUnique 88
-andIntegerIdKey               = mkPreludeMiscIdUnique 89
-orIntegerIdKey                = mkPreludeMiscIdUnique 90
-xorIntegerIdKey               = mkPreludeMiscIdUnique 91
-complementIntegerIdKey        = mkPreludeMiscIdUnique 92
-shiftLIntegerIdKey            = mkPreludeMiscIdUnique 93
-shiftRIntegerIdKey            = mkPreludeMiscIdUnique 94
-wordToIntegerIdKey            = mkPreludeMiscIdUnique 95
-word64ToIntegerIdKey          = mkPreludeMiscIdUnique 96
-int64ToIntegerIdKey           = mkPreludeMiscIdUnique 97
-decodeDoubleIntegerIdKey      = mkPreludeMiscIdUnique 98
+quotIntegerIdKey              = mkPreludeMiscIdUnique 79
+remIntegerIdKey               = mkPreludeMiscIdUnique 80
+divIntegerIdKey               = mkPreludeMiscIdUnique 81
+modIntegerIdKey               = mkPreludeMiscIdUnique 82
+divModIntegerIdKey            = mkPreludeMiscIdUnique 83
+quotRemIntegerIdKey           = mkPreludeMiscIdUnique 84
+floatFromIntegerIdKey         = mkPreludeMiscIdUnique 85
+doubleFromIntegerIdKey        = mkPreludeMiscIdUnique 86
+encodeFloatIntegerIdKey       = mkPreludeMiscIdUnique 87
+encodeDoubleIntegerIdKey      = mkPreludeMiscIdUnique 88
+gcdIntegerIdKey               = mkPreludeMiscIdUnique 89
+lcmIntegerIdKey               = mkPreludeMiscIdUnique 90
+andIntegerIdKey               = mkPreludeMiscIdUnique 91
+orIntegerIdKey                = mkPreludeMiscIdUnique 92
+xorIntegerIdKey               = mkPreludeMiscIdUnique 93
+complementIntegerIdKey        = mkPreludeMiscIdUnique 94
+shiftLIntegerIdKey            = mkPreludeMiscIdUnique 95
+shiftRIntegerIdKey            = mkPreludeMiscIdUnique 96
+wordToIntegerIdKey            = mkPreludeMiscIdUnique 97
+word64ToIntegerIdKey          = mkPreludeMiscIdUnique 98
+int64ToIntegerIdKey           = mkPreludeMiscIdUnique 99
+decodeDoubleIntegerIdKey      = mkPreludeMiscIdUnique 100
 
 rootMainKey, runMainKey :: Unique
-rootMainKey                   = mkPreludeMiscIdUnique 100
-runMainKey                    = mkPreludeMiscIdUnique 101
+rootMainKey                   = mkPreludeMiscIdUnique 101
+runMainKey                    = mkPreludeMiscIdUnique 102
 
 thenIOIdKey, lazyIdKey, assertErrorIdKey :: Unique
-thenIOIdKey                   = mkPreludeMiscIdUnique 102
-lazyIdKey                     = mkPreludeMiscIdUnique 103
-assertErrorIdKey              = mkPreludeMiscIdUnique 104
+thenIOIdKey                   = mkPreludeMiscIdUnique 103
+lazyIdKey                     = mkPreludeMiscIdUnique 104
+assertErrorIdKey              = mkPreludeMiscIdUnique 105
 
 breakpointIdKey, breakpointCondIdKey, breakpointAutoIdKey,
     breakpointJumpIdKey, breakpointCondJumpIdKey,
@@ -1690,6 +1692,8 @@ checkDotnetResNameIdKey       = mkPreludeMiscIdUnique 154
 undefinedKey :: Unique
 undefinedKey                  = mkPreludeMiscIdUnique 155
 
+magicSingIKey :: Unique
+magicSingIKey              = mkPreludeMiscIdUnique 156
 \end{code}
 
 Certain class operations from Prelude classes.  They get their own
diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index 079ab0cc98..64a9f9b912 100644
--- a/compiler/prelude/PrelRules.lhs
+++ b/compiler/prelude/PrelRules.lhs
@@ -20,17 +20,18 @@ module PrelRules ( primOpRules, builtinRules ) where
 #include "HsVersions.h"
 #include "../includes/MachDeps.h"
 
-import {-# SOURCE #-} MkId ( mkPrimOpId )
+import {-# SOURCE #-} MkId ( mkPrimOpId, magicSingIId )
 
 import CoreSyn
 import MkCore
 import Id
+import Var         (setVarType)
 import Literal
 import CoreSubst   ( exprIsLiteral_maybe )
 import PrimOp      ( PrimOp(..), tagToEnumKey )
 import TysWiredIn
 import TysPrim
-import TyCon       ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
+import TyCon       ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon, unwrapNewTyCon_maybe )
 import DataCon     ( dataConTag, dataConTyCon, dataConWorkId )
 import CoreUtils   ( cheapEqExpr, exprIsHNF )
 import CoreUnfold  ( exprIsConApp_maybe )
@@ -46,6 +47,7 @@ import BasicTypes
 import DynFlags
 import Platform
 import Util
+import Coercion     (mkUnbranchedAxInstCo,mkSymCo,Role(..))
 
 import Control.Monad
 import Data.Bits as Bits
@@ -195,7 +197,8 @@ primOpRules nm FloatAddOp   = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+))
 primOpRules nm FloatSubOp   = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-))
                                                 , rightIdentity zerof ]
 primOpRules nm FloatMulOp   = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*))
-                                                , identity onef ]
+                                                , identity onef
+                                                , strengthReduction twof FloatAddOp  ]
                          -- zeroElem zerof doesn't hold because of NaN
 primOpRules nm FloatDivOp   = mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/))
                                                 , rightIdentity onef ]
@@ -208,7 +211,8 @@ primOpRules nm DoubleAddOp   = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+))
 primOpRules nm DoubleSubOp   = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-))
                                                  , rightIdentity zerod ]
 primOpRules nm DoubleMulOp   = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*))
-                                                 , identity oned ]
+                                                 , identity oned
+                                                 , strengthReduction twod DoubleAddOp  ]
                           -- zeroElem zerod doesn't hold because of NaN
 primOpRules nm DoubleDivOp   = mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/))
                                                  , rightIdentity oned ]
@@ -216,6 +220,7 @@ primOpRules nm DoubleNegOp   = mkPrimOpRule nm 1 [ unaryLit negOp
                                                  , inversePrimOp DoubleNegOp ]
 
 -- Relational operators
+
 primOpRules nm IntEqOp    = mkRelOpRule nm (==) [ litEq True ]
 primOpRules nm IntNeOp    = mkRelOpRule nm (/=) [ litEq False ]
 primOpRules nm CharEqOp   = mkRelOpRule nm (==) [ litEq True ]
@@ -231,19 +236,19 @@ primOpRules nm CharGeOp   = mkRelOpRule nm (>=) [ boundsCmp Ge ]
 primOpRules nm CharLeOp   = mkRelOpRule nm (<=) [ boundsCmp Le ]
 primOpRules nm CharLtOp   = mkRelOpRule nm (<)  [ boundsCmp Lt ]
 
-primOpRules nm FloatGtOp  = mkRelOpRule nm (>)  []
-primOpRules nm FloatGeOp  = mkRelOpRule nm (>=) []
-primOpRules nm FloatLeOp  = mkRelOpRule nm (<=) []
-primOpRules nm FloatLtOp  = mkRelOpRule nm (<)  []
-primOpRules nm FloatEqOp  = mkRelOpRule nm (==) [ litEq True ]
-primOpRules nm FloatNeOp  = mkRelOpRule nm (/=) [ litEq False ]
+primOpRules nm FloatGtOp  = mkFloatingRelOpRule nm (>)  []
+primOpRules nm FloatGeOp  = mkFloatingRelOpRule nm (>=) []
+primOpRules nm FloatLeOp  = mkFloatingRelOpRule nm (<=) []
+primOpRules nm FloatLtOp  = mkFloatingRelOpRule nm (<)  []
+primOpRules nm FloatEqOp  = mkFloatingRelOpRule nm (==) [ litEq True ]
+primOpRules nm FloatNeOp  = mkFloatingRelOpRule nm (/=) [ litEq False ]
 
-primOpRules nm DoubleGtOp = mkRelOpRule nm (>)  []
-primOpRules nm DoubleGeOp = mkRelOpRule nm (>=) []
-primOpRules nm DoubleLeOp = mkRelOpRule nm (<=) []
-primOpRules nm DoubleLtOp = mkRelOpRule nm (<)  []
-primOpRules nm DoubleEqOp = mkRelOpRule nm (==) [ litEq True ]
-primOpRules nm DoubleNeOp = mkRelOpRule nm (/=) [ litEq False ]
+primOpRules nm DoubleGtOp = mkFloatingRelOpRule nm (>)  []
+primOpRules nm DoubleGeOp = mkFloatingRelOpRule nm (>=) []
+primOpRules nm DoubleLeOp = mkFloatingRelOpRule nm (<=) []
+primOpRules nm DoubleLtOp = mkFloatingRelOpRule nm (<)  []
+primOpRules nm DoubleEqOp = mkFloatingRelOpRule nm (==) [ litEq True ]
+primOpRules nm DoubleNeOp = mkFloatingRelOpRule nm (/=) [ litEq False ]
 
 primOpRules nm WordGtOp   = mkRelOpRule nm (>)  [ boundsCmp Gt ]
 primOpRules nm WordGeOp   = mkRelOpRule nm (>=) [ boundsCmp Ge ]
@@ -278,14 +283,27 @@ mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
 mkRelOpRule nm cmp extra
   = mkPrimOpRule nm 2 $ rules ++ extra
   where
-    rules = [ binaryLit (\_ -> cmpOp cmp)
-            , equalArgs >>
+    rules = [ binaryCmpLit cmp
+            , do equalArgs
               -- x `cmp` x does not depend on x, so
               -- compute it for the arbitrary value 'True'
               -- and use that result
-              return (if cmp True True
-                        then trueVal
-                        else falseVal) ]
+                 dflags <- getDynFlags
+                 return (if cmp True True
+                         then trueValInt  dflags
+                         else falseValInt dflags) ]
+
+-- Note [Rules for floating-point comparisons]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- We need different rules for floating-point values because for floats
+-- it is not true that x = x. The special case when this does not occur
+-- are NaNs.
+
+mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
+                    -> [RuleM CoreExpr] -> Maybe CoreRule
+mkFloatingRelOpRule nm cmp extra -- See Note [Rules for floating-point comparisons]
+  = mkPrimOpRule nm 2 $ binaryCmpLit cmp : extra
 
 -- common constants
 zeroi, onei, zerow, onew :: DynFlags -> Literal
@@ -294,18 +312,20 @@ onei  dflags = mkMachInt  dflags 1
 zerow dflags = mkMachWord dflags 0
 onew  dflags = mkMachWord dflags 1
 
-zerof, onef, zerod, oned :: Literal
+zerof, onef, twof, zerod, oned, twod :: Literal
 zerof = mkMachFloat 0.0
 onef  = mkMachFloat 1.0
+twof  = mkMachFloat 2.0
 zerod = mkMachDouble 0.0
 oned  = mkMachDouble 1.0
+twod  = mkMachDouble 2.0
 
-cmpOp :: (forall a . Ord a => a -> a -> Bool)
+cmpOp :: DynFlags -> (forall a . Ord a => a -> a -> Bool)
       -> Literal -> Literal -> Maybe CoreExpr
-cmpOp cmp = go
+cmpOp dflags cmp = go
   where
-    done True  = Just trueVal
-    done False = Just falseVal
+    done True  = Just $ trueValInt  dflags
+    done False = Just $ falseValInt dflags
 
     -- These compares are at different types
     go (MachChar i1)   (MachChar i2)   = done (i1 `cmp` i2)
@@ -402,19 +422,22 @@ litEq :: Bool  -- True <=> equality, False <=> inequality
       -> RuleM CoreExpr
 litEq is_eq = msum
   [ do [Lit lit, expr] <- getArgs
-       do_lit_eq lit expr
+       dflags <- getDynFlags
+       do_lit_eq dflags lit expr
   , do [expr, Lit lit] <- getArgs
-       do_lit_eq lit expr ]
+       dflags <- getDynFlags
+       do_lit_eq dflags lit expr ]
   where
-    do_lit_eq lit expr = do
+    do_lit_eq dflags lit expr = do
       guard (not (litIsLifted lit))
-      return (mkWildCase expr (literalType lit) boolTy
+      return (mkWildCase expr (literalType lit) intPrimTy
                     [(DEFAULT,    [], val_if_neq),
                      (LitAlt lit, [], val_if_eq)])
-    val_if_eq  | is_eq     = trueVal
-               | otherwise = falseVal
-    val_if_neq | is_eq     = falseVal
-               | otherwise = trueVal
+      where
+        val_if_eq  | is_eq     = trueValInt  dflags
+                   | otherwise = falseValInt dflags
+        val_if_neq | is_eq     = falseValInt dflags
+                   | otherwise = trueValInt  dflags
 
 
 -- | Check if there is comparison with minBound or maxBound, that is
@@ -429,14 +452,14 @@ boundsCmp op = do
 data Comparison = Gt | Ge | Lt | Le
 
 mkRuleFn :: DynFlags -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr
-mkRuleFn dflags Gt (Lit lit) _ | isMinBound dflags lit = Just falseVal
-mkRuleFn dflags Le (Lit lit) _ | isMinBound dflags lit = Just trueVal
-mkRuleFn dflags Ge _ (Lit lit) | isMinBound dflags lit = Just trueVal
-mkRuleFn dflags Lt _ (Lit lit) | isMinBound dflags lit = Just falseVal
-mkRuleFn dflags Ge (Lit lit) _ | isMaxBound dflags lit = Just trueVal
-mkRuleFn dflags Lt (Lit lit) _ | isMaxBound dflags lit = Just falseVal
-mkRuleFn dflags Gt _ (Lit lit) | isMaxBound dflags lit = Just falseVal
-mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just trueVal
+mkRuleFn dflags Gt (Lit lit) _ | isMinBound dflags lit = Just $ falseValInt dflags
+mkRuleFn dflags Le (Lit lit) _ | isMinBound dflags lit = Just $ trueValInt  dflags
+mkRuleFn dflags Ge _ (Lit lit) | isMinBound dflags lit = Just $ trueValInt  dflags
+mkRuleFn dflags Lt _ (Lit lit) | isMinBound dflags lit = Just $ falseValInt dflags
+mkRuleFn dflags Ge (Lit lit) _ | isMaxBound dflags lit = Just $ trueValInt  dflags
+mkRuleFn dflags Lt (Lit lit) _ | isMaxBound dflags lit = Just $ falseValInt dflags
+mkRuleFn dflags Gt _ (Lit lit) | isMaxBound dflags lit = Just $ falseValInt dflags
+mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just $ trueValInt  dflags
 mkRuleFn _ _ _ _                                       = Nothing
 
 isMinBound :: DynFlags -> Literal -> Bool
@@ -512,10 +535,10 @@ mkBasicRule op_name n_args rm
   = BuiltinRule { ru_name = occNameFS (nameOccName op_name),
                   ru_fn = op_name,
                   ru_nargs = n_args,
-                  ru_try = \dflags _ -> runRuleM rm dflags }
+                  ru_try = \ dflags in_scope _ -> runRuleM rm dflags in_scope }
 
 newtype RuleM r = RuleM
-  { runRuleM :: DynFlags -> IdUnfoldingFun -> [CoreExpr] -> Maybe r }
+  { runRuleM :: DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r }
 
 instance Monad RuleM where
   return x = RuleM $ \_ _ _ -> Just x
@@ -557,8 +580,8 @@ removeOp32 = mzero
 getArgs :: RuleM [CoreExpr]
 getArgs = RuleM $ \_ _ args -> Just args
 
-getIdUnfoldingFun :: RuleM IdUnfoldingFun
-getIdUnfoldingFun = RuleM $ \_ iu _ -> Just iu
+getInScopeEnv :: RuleM InScopeEnv
+getInScopeEnv = RuleM $ \_ iu _ -> Just iu
 
 -- return the n-th argument of this rule, if it is a literal
 -- argument indices start from 0
@@ -579,6 +602,11 @@ binaryLit op = do
   [Lit l1, Lit l2] <- getArgs
   liftMaybe $ op dflags (convFloating dflags l1) (convFloating dflags l2)
 
+binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr
+binaryCmpLit op = do
+  dflags <- getDynFlags
+  binaryLit (\_ -> cmpOp dflags op)
+
 leftIdentity :: Literal -> RuleM CoreExpr
 leftIdentity id_lit = leftIdentityDynFlags (const id_lit)
 
@@ -656,9 +684,40 @@ guardDoubleDiv = do
 -- is representable in Float/Double but not in (normalised)
 -- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?
 
-trueVal, falseVal :: Expr CoreBndr
-trueVal       = Var trueDataConId
-falseVal      = Var falseDataConId
+strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr
+strengthReduction two_lit add_op = do -- Note [Strength reduction]
+  arg <- msum [ do [arg, Lit mult_lit] <- getArgs
+                   guard (mult_lit == two_lit)
+                   return arg
+              , do [Lit mult_lit, arg] <- getArgs
+                   guard (mult_lit == two_lit)
+                   return arg ]
+  return $ Var (mkPrimOpId add_op) `App` arg `App` arg
+
+-- Note [Strength reduction]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- This rule turns floating point multiplications of the form 2.0 * x and
+-- x * 2.0 into x + x addition, because addition costs less than multiplication.
+-- See #7116
+
+-- Note [What's true and false]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- trueValInt and falseValInt represent true and false values returned by
+-- comparison primops for Char, Int, Word, Integer, Double, Float and Addr.
+-- True is represented as an unboxed 1# literal, while false is represented
+-- as 0# literal.
+-- We still need Bool data constructors (True and False) to use in a rule
+-- for constant folding of equal Strings
+
+trueValInt, falseValInt :: DynFlags -> Expr CoreBndr
+trueValInt  dflags = Lit $ onei  dflags -- see Note [What's true and false]
+falseValInt dflags = Lit $ zeroi dflags
+
+trueValBool, falseValBool :: Expr CoreBndr
+trueValBool   = Var trueDataConId -- see Note [What's true and false]
+falseValBool  = Var falseDataConId
 
 ltVal, eqVal, gtVal :: Expr CoreBndr
 ltVal = Var ltDataConId
@@ -719,7 +778,7 @@ tagToEnumRule = do
       let tag = fromInteger i
           correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
       (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])
-      ASSERT (null rest) return ()
+      ASSERT(null rest) return ()
       return $ mkTyApps (Var (dataConWorkId dc)) tc_args
 
     -- See Note [tagToEnum#]
@@ -745,8 +804,8 @@ dataToTagRule = a `mplus` b
     b = do
       dflags <- getDynFlags
       [_, val_arg] <- getArgs
-      id_unf <- getIdUnfoldingFun
-      (dc,_,_) <- liftMaybe $ exprIsConApp_maybe id_unf val_arg
+      in_scope <- getInScopeEnv
+      (dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg
       ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return ()
       return $ mkIntVal dflags (toInteger (dataConTag dc - fIRST_TAG))
 \end{code}
@@ -812,11 +871,14 @@ builtinRules :: [CoreRule]
 builtinRules
   = [BuiltinRule { ru_name = fsLit "AppendLitString",
                    ru_fn = unpackCStringFoldrName,
-                   ru_nargs = 4, ru_try = \_ _ -> match_append_lit },
+                   ru_nargs = 4, ru_try = \_ _ _ -> match_append_lit },
      BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
-                   ru_nargs = 2, ru_try = \_ _ -> match_eq_string },
+                   ru_nargs = 2, ru_try = \dflags _ _ -> match_eq_string dflags },
      BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
-                   ru_nargs = 2, ru_try = \_ _ -> match_inline }]
+                   ru_nargs = 2, ru_try = \_ _ _ -> match_inline },
+     BuiltinRule { ru_name = fsLit "MagicSingI", ru_fn = idName magicSingIId,
+                   ru_nargs = 3, ru_try = \_ _ _ -> match_magicSingI }
+     ]
  ++ builtinIntegerRules
 
 builtinIntegerRules :: [CoreRule]
@@ -833,19 +895,15 @@ builtinIntegerRules =
   rule_binop          "minusInteger"        minusIntegerName        (-),
   rule_binop          "timesInteger"        timesIntegerName        (*),
   rule_unop           "negateInteger"       negateIntegerName       negate,
-  rule_binop_Bool     "eqInteger"           eqIntegerName           (==),
-  rule_binop_Bool     "neqInteger"          neqIntegerName          (/=),
+  rule_binop_Prim     "eqInteger#"          eqIntegerPrimName       (==),
+  rule_binop_Prim     "neqInteger#"         neqIntegerPrimName      (/=),
   rule_unop           "absInteger"          absIntegerName          abs,
   rule_unop           "signumInteger"       signumIntegerName       signum,
-  rule_binop_Bool     "leInteger"           leIntegerName           (<=),
-  rule_binop_Bool     "gtInteger"           gtIntegerName           (>),
-  rule_binop_Bool     "ltInteger"           ltIntegerName           (<),
-  rule_binop_Bool     "geInteger"           geIntegerName           (>=),
+  rule_binop_Prim     "leInteger#"          leIntegerPrimName       (<=),
+  rule_binop_Prim     "gtInteger#"          gtIntegerPrimName       (>),
+  rule_binop_Prim     "ltInteger#"          ltIntegerPrimName       (<),
+  rule_binop_Prim     "geInteger#"          geIntegerPrimName       (>=),
   rule_binop_Ordering "compareInteger"      compareIntegerName      compare,
-  rule_divop_both     "divModInteger"       divModIntegerName       divMod,
-  rule_divop_both     "quotRemInteger"      quotRemIntegerName      quotRem,
-  rule_divop_one      "quotInteger"         quotIntegerName         quot,
-  rule_divop_one      "remInteger"          remIntegerName          rem,
   rule_encodeFloat    "encodeFloatInteger"  encodeFloatIntegerName  mkFloatLitFloat,
   rule_convert        "floatFromInteger"    floatFromIntegerName    (\_ -> mkFloatLitFloat),
   rule_encodeFloat    "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble,
@@ -861,6 +919,13 @@ builtinIntegerRules =
   rule_unop           "complementInteger"   complementIntegerName   complement,
   rule_Int_binop      "shiftLInteger"       shiftLIntegerName       shiftL,
   rule_Int_binop      "shiftRInteger"       shiftRIntegerName       shiftR,
+  -- See Note [Integer division constant folding] in libraries/base/GHC/Real.lhs
+  rule_divop_one      "quotInteger"         quotIntegerName         quot,
+  rule_divop_one      "remInteger"          remIntegerName          rem,
+  rule_divop_one      "divInteger"          divIntegerName          div,
+  rule_divop_one      "modInteger"          modIntegerName          mod,
+  rule_divop_both     "divModInteger"       divModIntegerName       divMod,
+  rule_divop_both     "quotRemInteger"      quotRemIntegerName      quotRem,
   -- These rules below don't actually have to be built in, but if we
   -- put them in the Haskell source then we'd have to duplicate them
   -- between all Integer implementations
@@ -902,9 +967,9 @@ builtinIntegerRules =
           rule_Int_binop str name op
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
                            ru_try = match_Integer_Int_binop op }
-          rule_binop_Bool str name op
+          rule_binop_Prim str name op
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
-                           ru_try = match_Integer_binop_Bool op }
+                           ru_try = match_Integer_binop_Prim op }
           rule_binop_Ordering str name op
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
                            ru_try = match_Integer_binop_Ordering op }
@@ -929,8 +994,8 @@ builtinIntegerRules =
 --      unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
 --      =  unpackFoldrCString# "foobaz" c n
 
-match_append_lit :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
-match_append_lit _ [Type ty1,
+match_append_lit :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
+match_append_lit [Type ty1,
                     Lit (MachStr s1),
                     c1,
                     Var unpk `App` Type ty2
@@ -946,18 +1011,18 @@ match_append_lit _ [Type ty1,
                    `App` c1
                    `App` n)
 
-match_append_lit _ _ = Nothing
+match_append_lit _ = Nothing
 
 ---------------------------------------------------
 -- The rule is this:
 --      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
 
-match_eq_string :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
+match_eq_string :: DynFlags -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
 match_eq_string _ [Var unpk1 `App` Lit (MachStr s1),
-                   Var unpk2 `App` Lit (MachStr s2)]
+                        Var unpk2 `App` Lit (MachStr s2)]
   | unpk1 `hasKey` unpackCStringIdKey,
     unpk2 `hasKey` unpackCStringIdKey
-  = Just (if s1 == s2 then trueVal else falseVal)
+  = Just (if s1 == s2 then trueValBool else falseValBool)
 
 match_eq_string _ _ = Nothing
 
@@ -975,41 +1040,47 @@ match_eq_string _ _ = Nothing
 --     programmer can't avoid
 --
 -- Also, don't forget about 'inline's type argument!
-match_inline :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
-match_inline _ (Type _ : e : _)
+match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
+match_inline (Type _ : e : _)
   | (Var f, args1) <- collectArgs e,
     Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)
              -- Ignore the IdUnfoldingFun here!
   = Just (mkApps unf args1)
 
-match_inline _ _ = Nothing
+match_inline _ = Nothing
+
+
+-- See Note [magicSingIId magic] in `basicTypes/MkId.lhs`
+-- for a description of what is going on here.
+match_magicSingI :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
+match_magicSingI (Type t : e : Lam b _ : _)
+  | ((_ : _ : fu : _),_)  <- splitFunTys t
+  , (sI_type,_)           <- splitFunTy fu
+  , Just (sI_tc,xs)       <- splitTyConApp_maybe sI_type
+  , Just (_,_,co)         <- unwrapNewTyCon_maybe sI_tc
+  = Just $ let f = setVarType b fu
+           in Lam f $ Var f `App` Cast e (mkSymCo (mkUnbranchedAxInstCo Representational co xs))
+
+match_magicSingI _ = Nothing
 
 -------------------------------------------------
 -- Integer rules
---   smallInteger  (79::Int#)  = 79::Integer   
---   wordToInteger (79::Word#) = 79::Integer   
+--   smallInteger  (79::Int#)  = 79::Integer
+--   wordToInteger (79::Word#) = 79::Integer
 -- Similarly Int64, Word64
 
-match_IntToInteger :: DynFlags
-                   -> Id
-                   -> IdUnfoldingFun
-                   -> [Expr CoreBndr]
-                   -> Maybe (Expr CoreBndr)
-match_IntToInteger _ id id_unf [xl]
+match_IntToInteger :: RuleFun
+match_IntToInteger _ id_unf fn [xl]
   | Just (MachInt x) <- exprIsLiteral_maybe id_unf xl
-  = case idType id of
+  = case idType fn of
     FunTy _ integerTy ->
         Just (Lit (LitInteger x integerTy))
     _ ->
         panic "match_IntToInteger: Id has the wrong type"
 match_IntToInteger _ _ _ _ = Nothing
 
-match_WordToInteger :: DynFlags
-                    -> Id
-                    -> IdUnfoldingFun
-                    -> [Expr CoreBndr]
-                    -> Maybe (Expr CoreBndr)
-match_WordToInteger _ id id_unf [xl]
+match_WordToInteger :: RuleFun
+match_WordToInteger _ id_unf id [xl]
   | Just (MachWord x) <- exprIsLiteral_maybe id_unf xl
   = case idType id of
     FunTy _ integerTy ->
@@ -1018,12 +1089,8 @@ match_WordToInteger _ id id_unf [xl]
         panic "match_WordToInteger: Id has the wrong type"
 match_WordToInteger _ _ _ _ = Nothing
 
-match_Int64ToInteger :: DynFlags
-                     -> Id
-                     -> IdUnfoldingFun
-                     -> [Expr CoreBndr]
-                     -> Maybe (Expr CoreBndr)
-match_Int64ToInteger _ id id_unf [xl]
+match_Int64ToInteger :: RuleFun
+match_Int64ToInteger _ id_unf id [xl]
   | Just (MachInt64 x) <- exprIsLiteral_maybe id_unf xl
   = case idType id of
     FunTy _ integerTy ->
@@ -1032,12 +1099,8 @@ match_Int64ToInteger _ id id_unf [xl]
         panic "match_Int64ToInteger: Id has the wrong type"
 match_Int64ToInteger _ _ _ _ = Nothing
 
-match_Word64ToInteger :: DynFlags
-                      -> Id
-                      -> IdUnfoldingFun
-                      -> [Expr CoreBndr]
-                      -> Maybe (Expr CoreBndr)
-match_Word64ToInteger _ id id_unf [xl]
+match_Word64ToInteger :: RuleFun
+match_Word64ToInteger _ id_unf id [xl]
   | Just (MachWord64 x) <- exprIsLiteral_maybe id_unf xl
   = case idType id of
     FunTy _ integerTy ->
@@ -1049,47 +1112,29 @@ match_Word64ToInteger _ _ _ _ = Nothing
 -------------------------------------------------
 match_Integer_convert :: Num a
                       => (DynFlags -> a -> Expr CoreBndr)
-                      -> DynFlags
-                      -> Id
-                      -> IdUnfoldingFun
-                      -> [Expr CoreBndr]
-                      -> Maybe (Expr CoreBndr)
-match_Integer_convert convert dflags _ id_unf [xl]
+                      -> RuleFun
+match_Integer_convert convert dflags id_unf _ [xl]
   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
   = Just (convert dflags (fromInteger x))
 match_Integer_convert _ _ _ _ _ = Nothing
 
-match_Integer_unop :: (Integer -> Integer)
-                   -> DynFlags
-                   -> Id
-                   -> IdUnfoldingFun
-                   -> [Expr CoreBndr]
-                   -> Maybe (Expr CoreBndr)
-match_Integer_unop unop _ _ id_unf [xl]
+match_Integer_unop :: (Integer -> Integer) -> RuleFun
+match_Integer_unop unop _ id_unf _ [xl]
   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
   = Just (Lit (LitInteger (unop x) i))
 match_Integer_unop _ _ _ _ _ = Nothing
 
-match_Integer_binop :: (Integer -> Integer -> Integer)
-                    -> DynFlags
-                    -> Id
-                    -> IdUnfoldingFun
-                    -> [Expr CoreBndr]
-                    -> Maybe (Expr CoreBndr)
-match_Integer_binop binop _ _ id_unf [xl,yl]
+match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun
+match_Integer_binop binop _ id_unf _ [xl,yl]
   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
   = Just (Lit (LitInteger (x `binop` y) i))
 match_Integer_binop _ _ _ _ _ = Nothing
 
 -- This helper is used for the quotRem and divMod functions
-match_Integer_divop_both :: (Integer -> Integer -> (Integer, Integer))
-                         -> DynFlags
-                         -> Id
-                         -> IdUnfoldingFun
-                         -> [Expr CoreBndr]
-                         -> Maybe (Expr CoreBndr)
-match_Integer_divop_both divop _ _ id_unf [xl,yl]
+match_Integer_divop_both
+   :: (Integer -> Integer -> (Integer, Integer)) -> RuleFun
+match_Integer_divop_both divop _ id_unf _ [xl,yl]
   | Just (LitInteger x t) <- exprIsLiteral_maybe id_unf xl
   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
   , y /= 0
@@ -1101,51 +1146,31 @@ match_Integer_divop_both divop _ _ id_unf [xl,yl]
                      Lit (LitInteger s t)]
 match_Integer_divop_both _ _ _ _ _ = Nothing
 
--- This helper is used for the quotRem and divMod functions
-match_Integer_divop_one :: (Integer -> Integer -> Integer)
-                        -> DynFlags
-                        -> Id
-                        -> IdUnfoldingFun
-                        -> [Expr CoreBndr]
-                        -> Maybe (Expr CoreBndr)
-match_Integer_divop_one divop _ _ id_unf [xl,yl]
+-- This helper is used for the quot and rem functions
+match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun
+match_Integer_divop_one divop _ id_unf _ [xl,yl]
   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
   , y /= 0
   = Just (Lit (LitInteger (x `divop` y) i))
 match_Integer_divop_one _ _ _ _ _ = Nothing
 
-match_Integer_Int_binop :: (Integer -> Int -> Integer)
-                        -> DynFlags
-                        -> Id
-                        -> IdUnfoldingFun
-                        -> [Expr CoreBndr]
-                        -> Maybe (Expr CoreBndr)
-match_Integer_Int_binop binop _ _ id_unf [xl,yl]
+match_Integer_Int_binop :: (Integer -> Int -> Integer) -> RuleFun
+match_Integer_Int_binop binop _ id_unf _ [xl,yl]
   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
   , Just (MachInt y)      <- exprIsLiteral_maybe id_unf yl
   = Just (Lit (LitInteger (x `binop` fromIntegral y) i))
 match_Integer_Int_binop _ _ _ _ _ = Nothing
 
-match_Integer_binop_Bool :: (Integer -> Integer -> Bool)
-                         -> DynFlags
-                         -> Id
-                         -> IdUnfoldingFun
-                         -> [Expr CoreBndr]
-                         -> Maybe (Expr CoreBndr)
-match_Integer_binop_Bool binop _ _ id_unf [xl, yl]
+match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun
+match_Integer_binop_Prim binop dflags id_unf _ [xl, yl]
   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
-  = Just (if x `binop` y then trueVal else falseVal)
-match_Integer_binop_Bool _ _ _ _ _ = Nothing
-
-match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering)
-                             -> DynFlags
-                             -> Id
-                             -> IdUnfoldingFun
-                             -> [Expr CoreBndr]
-                             -> Maybe (Expr CoreBndr)
-match_Integer_binop_Ordering binop _ _ id_unf [xl, yl]
+  = Just (if x `binop` y then trueValInt dflags else falseValInt dflags)
+match_Integer_binop_Prim _ _ _ _ _ = Nothing
+
+match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun
+match_Integer_binop_Ordering binop _ id_unf _ [xl, yl]
   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
   = Just $ case x `binop` y of
@@ -1156,12 +1181,8 @@ match_Integer_binop_Ordering _ _ _ _ _ = Nothing
 
 match_Integer_Int_encodeFloat :: RealFloat a
                               => (a -> Expr CoreBndr)
-                              -> DynFlags
-                              -> Id
-                              -> IdUnfoldingFun
-                              -> [Expr CoreBndr]
-                              -> Maybe (Expr CoreBndr)
-match_Integer_Int_encodeFloat mkLit _ _ id_unf [xl,yl]
+                              -> RuleFun
+match_Integer_Int_encodeFloat mkLit _ id_unf _ [xl,yl]
   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
   , Just (MachInt y)      <- exprIsLiteral_maybe id_unf yl
   = Just (mkLit $ encodeFloat x (fromInteger y))
@@ -1179,24 +1200,16 @@ match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing
 -- NaN or +-Inf
 match_rationalTo :: RealFloat a
                  => (a -> Expr CoreBndr)
-                 -> DynFlags
-                 -> Id
-                 -> IdUnfoldingFun
-                 -> [Expr CoreBndr]
-                 -> Maybe (Expr CoreBndr)
-match_rationalTo mkLit _ _ id_unf [xl, yl]
+                 -> RuleFun
+match_rationalTo mkLit _ id_unf _ [xl, yl]
   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
   , y /= 0
   = Just (mkLit (fromRational (x % y)))
 match_rationalTo _ _ _ _ _ = Nothing
 
-match_decodeDouble :: DynFlags
-                   -> Id
-                   -> IdUnfoldingFun
-                   -> [Expr CoreBndr]
-                   -> Maybe (Expr CoreBndr)
-match_decodeDouble _ fn id_unf [xl]
+match_decodeDouble :: RuleFun
+match_decodeDouble _ id_unf fn [xl]
   | Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl
   = case idType fn of
     FunTy _ (TyConApp _ [integerTy, intHashTy]) ->
@@ -1211,23 +1224,13 @@ match_decodeDouble _ fn id_unf [xl]
         panic "match_decodeDouble: Id has the wrong type"
 match_decodeDouble _ _ _ _ = Nothing
 
-match_XToIntegerToX :: Name
-                    -> DynFlags
-                    -> Id
-                    -> IdUnfoldingFun
-                    -> [Expr CoreBndr]
-                    -> Maybe (Expr CoreBndr)
+match_XToIntegerToX :: Name -> RuleFun
 match_XToIntegerToX n _ _ _ [App (Var x) y]
   | idName x == n
   = Just y
 match_XToIntegerToX _ _ _ _ _ = Nothing
 
-match_smallIntegerTo :: PrimOp
-                     -> DynFlags
-                     -> Id
-                     -> IdUnfoldingFun
-                     -> [Expr CoreBndr]
-                     -> Maybe (Expr CoreBndr)
+match_smallIntegerTo :: PrimOp -> RuleFun
 match_smallIntegerTo primOp _ _ _ [App (Var x) y]
   | idName x == smallIntegerName
   = Just $ App (Var (mkPrimOpId primOp)) y
diff --git a/compiler/prelude/PrimOp.lhs b/compiler/prelude/PrimOp.lhs
index 1aaca36274..8b1970c37f 100644
--- a/compiler/prelude/PrimOp.lhs
+++ b/compiler/prelude/PrimOp.lhs
@@ -118,9 +118,8 @@ data PrimOpInfo
                 Type
   | Monadic     OccName         -- string :: T -> T
                 Type
-  | Compare     OccName         -- string :: T -> T -> Bool
+  | Compare     OccName         -- string :: T -> T -> Int#
                 Type
-
   | GenPrimOp   OccName         -- string :: \/a1..an . T1 -> .. -> Tk -> T
                 [TyVar]
                 [Type]
@@ -513,10 +512,10 @@ primOpSig op
     arity = length arg_tys
     (tyvars, arg_tys, res_ty)
       = case (primOpInfo op) of
-        Monadic   _occ ty                    -> ([],     [ty],    ty    )
-        Dyadic    _occ ty                    -> ([],     [ty,ty], ty    )
-        Compare   _occ ty                    -> ([],     [ty,ty], boolTy)
-        GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty)
+        Monadic   _occ ty                    -> ([],     [ty],    ty       )
+        Dyadic    _occ ty                    -> ([],     [ty,ty], ty       )
+        Compare   _occ ty                    -> ([],     [ty,ty], intPrimTy)
+        GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty   )
 \end{code}
 
 \begin{code}
@@ -533,7 +532,7 @@ getPrimOpResultInfo op
   = case (primOpInfo op) of
       Dyadic  _ ty                        -> ReturnsPrim (typePrimRep ty)
       Monadic _ ty                        -> ReturnsPrim (typePrimRep ty)
-      Compare _ _                         -> ReturnsAlg boolTyCon
+      Compare _ _                         -> ReturnsPrim (tyConPrimRep intPrimTyCon)
       GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep tc)
                          | otherwise      -> ReturnsAlg tc
                          where
@@ -560,7 +559,7 @@ Utils:
 dyadic_fun_ty, monadic_fun_ty, compare_fun_ty :: Type -> Type
 dyadic_fun_ty  ty = mkFunTys [ty, ty] ty
 monadic_fun_ty ty = mkFunTy  ty ty
-compare_fun_ty ty = mkFunTys [ty, ty] boolTy
+compare_fun_ty ty = mkFunTys [ty, ty] intPrimTy
 \end{code}
 
 Output stuff:
diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs
index c59884ba33..f166065b22 100644
--- a/compiler/prelude/TysPrim.lhs
+++ b/compiler/prelude/TysPrim.lhs
@@ -71,6 +71,7 @@ module TysPrim(
         word64PrimTyCon,        word64PrimTy,
 
         eqPrimTyCon,            -- ty1 ~# ty2
+        eqReprPrimTyCon,        -- ty1 ~R# ty2  (at role Representational)
 
 	-- * Any
 	anyTy, anyTyCon, anyTypeOfKind,
@@ -134,6 +135,7 @@ primTyCons
     , word64PrimTyCon
     , anyTyCon
     , eqPrimTyCon
+    , eqReprPrimTyCon
 
     , liftedTypeKindTyCon
     , unliftedTypeKindTyCon
@@ -155,7 +157,7 @@ mkPrimTc fs unique tycon
 		  (ATyCon tycon)	-- Relevant TyCon
 		  UserSyntax		-- None are built-in syntax
 
-charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, floatX4PrimTyConName, doubleX2PrimTyConName, int32X4PrimTyConName, int64X2PrimTyConName :: Name
+charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, floatX4PrimTyConName, doubleX2PrimTyConName, int32X4PrimTyConName, int64X2PrimTyConName :: Name
 charPrimTyConName    	      = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon
 intPrimTyConName     	      = mkPrimTc (fsLit "Int#") intPrimTyConKey  intPrimTyCon
 int32PrimTyConName	      = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon
@@ -168,6 +170,7 @@ floatPrimTyConName   	      = mkPrimTc (fsLit "Float#") floatPrimTyConKey floatP
 doublePrimTyConName  	      = mkPrimTc (fsLit "Double#") doublePrimTyConKey doublePrimTyCon
 statePrimTyConName            = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon
 eqPrimTyConName               = mkPrimTc (fsLit "~#") eqPrimTyConKey eqPrimTyCon
+eqReprPrimTyConName           = mkPrimTc (fsLit "~R#") eqReprPrimTyConKey eqReprPrimTyCon
 realWorldTyConName            = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon
 arrayPrimTyConName   	      = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon
 byteArrayPrimTyConName	      = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon
@@ -346,7 +349,7 @@ mkPrimTyConName occ key tycon = mkWiredInName gHC_PRIM (mkTcOccFS occ)
 
 \begin{code}
 kindTyConType :: TyCon -> Type
-kindTyConType kind = TyConApp kind []
+kindTyConType kind = TyConApp kind []   -- mkTyConApp isn't defined yet
 
 -- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's
 anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind, superKind :: Kind
@@ -375,16 +378,16 @@ mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds
 
 \begin{code}
 -- only used herein
-pcPrimTyCon :: Name -> Int -> PrimRep -> TyCon
-pcPrimTyCon name arity rep
-  = mkPrimTyCon name kind arity rep
+pcPrimTyCon :: Name -> [Role] -> PrimRep -> TyCon
+pcPrimTyCon name roles rep
+  = mkPrimTyCon name kind roles rep
   where
-    kind        = mkArrowKinds (replicate arity liftedTypeKind) result_kind
+    kind        = mkArrowKinds (map (const liftedTypeKind) roles) result_kind
     result_kind = unliftedTypeKind
 
 pcPrimTyCon0 :: Name -> PrimRep -> TyCon
 pcPrimTyCon0 name rep
-  = mkPrimTyCon name result_kind 0 rep
+  = mkPrimTyCon name result_kind [] rep
   where
     result_kind = unliftedTypeKind
 
@@ -469,19 +472,34 @@ or
 where s is a type variable. The only purpose of the type parameter is to
 keep different state threads separate.  It is represented by nothing at all.
 
+The type parameter to State# is intended to keep separate threads separate.
+Even though this parameter is not used in the definition of State#, it is
+given role Nominal to enforce its intended use.
+
 \begin{code}
 mkStatePrimTy :: Type -> Type
-mkStatePrimTy ty = mkNakedTyConApp statePrimTyCon [ty]
+mkStatePrimTy ty = TyConApp statePrimTyCon [ty]
 
 statePrimTyCon :: TyCon   -- See Note [The State# TyCon]
-statePrimTyCon	 = pcPrimTyCon statePrimTyConName 1 VoidRep
+statePrimTyCon	 = pcPrimTyCon statePrimTyConName [Nominal] VoidRep
 
 eqPrimTyCon :: TyCon  -- The representation type for equality predicates
 		      -- See Note [The ~# TyCon]
-eqPrimTyCon  = mkPrimTyCon eqPrimTyConName kind 3 VoidRep
+eqPrimTyCon  = mkPrimTyCon eqPrimTyConName kind [Nominal, Nominal, Nominal] VoidRep
   where kind = ForAllTy kv $ mkArrowKinds [k, k] unliftedTypeKind
         kv = kKiVar
         k = mkTyVarTy kv
+
+-- like eqPrimTyCon, but the type for *Representational* coercions
+-- this should only ever appear as the type of a covar. Its role is
+-- interpreted in coercionRole
+eqReprPrimTyCon :: TyCon
+eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName kind
+                                  -- the roles really should be irrelevant!
+                              [Nominal, Representational, Representational] VoidRep
+  where kind = ForAllTy kv $ mkArrowKinds [k, k] unliftedTypeKind
+        kv = kKiVar
+        k  = mkTyVarTy kv
 \end{code}
 
 RealWorld is deeply magical.  It is *primitive*, but it is not
@@ -490,7 +508,7 @@ RealWorld; it's only used in the type system, to parameterise State#.
 
 \begin{code}
 realWorldTyCon :: TyCon
-realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName liftedTypeKind 0 PtrRep
+realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName liftedTypeKind [] PtrRep
 realWorldTy :: Type
 realWorldTy	     = mkTyConTy realWorldTyCon
 realWorldStatePrimTy :: Type
@@ -509,25 +527,25 @@ defined in \tr{TysWiredIn.lhs}, not here.
 \begin{code}
 arrayPrimTyCon, mutableArrayPrimTyCon, mutableByteArrayPrimTyCon,
     byteArrayPrimTyCon, arrayArrayPrimTyCon, mutableArrayArrayPrimTyCon :: TyCon
-arrayPrimTyCon             = pcPrimTyCon  arrayPrimTyConName             1 PtrRep
-mutableArrayPrimTyCon      = pcPrimTyCon  mutableArrayPrimTyConName      2 PtrRep
-mutableByteArrayPrimTyCon  = pcPrimTyCon  mutableByteArrayPrimTyConName  1 PtrRep
-byteArrayPrimTyCon         = pcPrimTyCon0 byteArrayPrimTyConName           PtrRep
-arrayArrayPrimTyCon        = pcPrimTyCon0 arrayArrayPrimTyConName          PtrRep
-mutableArrayArrayPrimTyCon = pcPrimTyCon  mutableArrayArrayPrimTyConName 1 PtrRep
+arrayPrimTyCon             = pcPrimTyCon arrayPrimTyConName             [Representational] PtrRep
+mutableArrayPrimTyCon      = pcPrimTyCon  mutableArrayPrimTyConName     [Nominal, Representational] PtrRep
+mutableByteArrayPrimTyCon  = pcPrimTyCon mutableByteArrayPrimTyConName  [Nominal] PtrRep
+byteArrayPrimTyCon         = pcPrimTyCon0 byteArrayPrimTyConName        PtrRep
+arrayArrayPrimTyCon        = pcPrimTyCon0 arrayArrayPrimTyConName       PtrRep
+mutableArrayArrayPrimTyCon = pcPrimTyCon mutableArrayArrayPrimTyConName [Nominal] PtrRep
 
 mkArrayPrimTy :: Type -> Type
-mkArrayPrimTy elt    	    = mkNakedTyConApp arrayPrimTyCon [elt]
+mkArrayPrimTy elt    	    = TyConApp arrayPrimTyCon [elt]
 byteArrayPrimTy :: Type
 byteArrayPrimTy	    	    = mkTyConTy byteArrayPrimTyCon
 mkArrayArrayPrimTy :: Type
 mkArrayArrayPrimTy = mkTyConTy arrayArrayPrimTyCon
 mkMutableArrayPrimTy :: Type -> Type -> Type
-mkMutableArrayPrimTy s elt  = mkNakedTyConApp mutableArrayPrimTyCon [s, elt]
+mkMutableArrayPrimTy s elt  = TyConApp mutableArrayPrimTyCon [s, elt]
 mkMutableByteArrayPrimTy :: Type -> Type
-mkMutableByteArrayPrimTy s  = mkNakedTyConApp mutableByteArrayPrimTyCon [s]
+mkMutableByteArrayPrimTy s  = TyConApp mutableByteArrayPrimTyCon [s]
 mkMutableArrayArrayPrimTy :: Type -> Type
-mkMutableArrayArrayPrimTy s = mkNakedTyConApp mutableArrayArrayPrimTyCon [s]
+mkMutableArrayArrayPrimTy s = TyConApp mutableArrayArrayPrimTyCon [s]
 \end{code}
 
 %************************************************************************
@@ -538,10 +556,10 @@ mkMutableArrayArrayPrimTy s = mkNakedTyConApp mutableArrayArrayPrimTyCon [s]
 
 \begin{code}
 mutVarPrimTyCon :: TyCon
-mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName 2 PtrRep
+mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName [Nominal, Representational] PtrRep
 
 mkMutVarPrimTy :: Type -> Type -> Type
-mkMutVarPrimTy s elt 	    = mkNakedTyConApp mutVarPrimTyCon [s, elt]
+mkMutVarPrimTy s elt 	    = TyConApp mutVarPrimTyCon [s, elt]
 \end{code}
 
 %************************************************************************
@@ -552,10 +570,10 @@ mkMutVarPrimTy s elt 	    = mkNakedTyConApp mutVarPrimTyCon [s, elt]
 
 \begin{code}
 mVarPrimTyCon :: TyCon
-mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName 2 PtrRep
+mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName [Nominal, Representational] PtrRep
 
 mkMVarPrimTy :: Type -> Type -> Type
-mkMVarPrimTy s elt 	    = mkNakedTyConApp mVarPrimTyCon [s, elt]
+mkMVarPrimTy s elt 	    = TyConApp mVarPrimTyCon [s, elt]
 \end{code}
 
 %************************************************************************
@@ -566,10 +584,10 @@ mkMVarPrimTy s elt 	    = mkNakedTyConApp mVarPrimTyCon [s, elt]
 
 \begin{code}
 tVarPrimTyCon :: TyCon
-tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName 2 PtrRep
+tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName [Nominal, Representational] PtrRep
 
 mkTVarPrimTy :: Type -> Type -> Type
-mkTVarPrimTy s elt = mkNakedTyConApp tVarPrimTyCon [s, elt]
+mkTVarPrimTy s elt = TyConApp tVarPrimTyCon [s, elt]
 \end{code}
 
 %************************************************************************
@@ -580,10 +598,10 @@ mkTVarPrimTy s elt = mkNakedTyConApp tVarPrimTyCon [s, elt]
 
 \begin{code}
 stablePtrPrimTyCon :: TyCon
-stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName 1 AddrRep
+stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName [Representational] AddrRep
 
 mkStablePtrPrimTy :: Type -> Type
-mkStablePtrPrimTy ty = mkNakedTyConApp stablePtrPrimTyCon [ty]
+mkStablePtrPrimTy ty = TyConApp stablePtrPrimTyCon [ty]
 \end{code}
 
 %************************************************************************
@@ -594,10 +612,10 @@ mkStablePtrPrimTy ty = mkNakedTyConApp stablePtrPrimTyCon [ty]
 
 \begin{code}
 stableNamePrimTyCon :: TyCon
-stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName 1 PtrRep
+stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName [Representational] PtrRep
 
 mkStableNamePrimTy :: Type -> Type
-mkStableNamePrimTy ty = mkNakedTyConApp stableNamePrimTyCon [ty]
+mkStableNamePrimTy ty = TyConApp stableNamePrimTyCon [ty]
 \end{code}
 
 %************************************************************************
@@ -621,10 +639,10 @@ bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName PtrRep
 
 \begin{code}
 weakPrimTyCon :: TyCon
-weakPrimTyCon = pcPrimTyCon weakPrimTyConName 1 PtrRep
+weakPrimTyCon = pcPrimTyCon weakPrimTyConName [Representational] PtrRep
 
 mkWeakPrimTy :: Type -> Type
-mkWeakPrimTy v = mkNakedTyConApp weakPrimTyCon [v]
+mkWeakPrimTy v = TyConApp weakPrimTyCon [v]
 \end{code}
 
 %************************************************************************
@@ -727,10 +745,11 @@ anyTy :: Type
 anyTy = mkTyConTy anyTyCon
 
 anyTyCon :: TyCon
-anyTyCon = mkLiftedPrimTyCon anyTyConName kind 1 PtrRep
+anyTyCon = mkLiftedPrimTyCon anyTyConName kind [Nominal] PtrRep
   where kind = ForAllTy kKiVar (mkTyVarTy kKiVar)
 
 {-   Can't do this yet without messing up kind proxies
+-- RAE: I think you can now.
 anyTyCon :: TyCon
 anyTyCon = mkSynTyCon anyTyConName kind [kKiVar] 
                       syn_rhs
@@ -742,7 +761,7 @@ anyTyCon = mkSynTyCon anyTyConName kind [kKiVar]
 -}
 
 anyTypeOfKind :: Kind -> Type
-anyTypeOfKind kind = mkNakedTyConApp anyTyCon [kind]
+anyTypeOfKind kind = TyConApp anyTyCon [kind]
 \end{code}
 
 %************************************************************************
diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
index b8c0e34174..b563b25cc4 100644
--- a/compiler/prelude/TysWiredIn.lhs
+++ b/compiler/prelude/TysWiredIn.lhs
@@ -236,12 +236,15 @@ pcNonRecDataTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
 -- Not an enumeration, not promotable
 pcNonRecDataTyCon = pcTyCon False NonRecursive False
 
+-- This function assumes that the types it creates have all parameters at
+-- Representational role!
 pcTyCon :: Bool -> RecFlag -> Bool -> Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
 pcTyCon is_enum is_rec is_prom name cType tyvars cons
   = tycon
   where
     tycon = buildAlgTyCon name
                 tyvars
+                (map (const Representational) tyvars)
                 cType
                 []              -- No stupid theta
                 (DataTyCon cons is_enum)
@@ -425,6 +428,7 @@ eqTyCon :: TyCon
 eqTyCon = mkAlgTyCon eqTyConName
             (ForAllTy kv $ mkArrowKinds [k, k] constraintKind)
             [kv, a, b]
+            [Nominal, Nominal, Nominal]
             Nothing
             []      -- No stupid theta
             (DataTyCon [eqBoxDataCon] False)
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index 45472816c0..e275b23778 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -140,19 +140,19 @@ section "Char#"
 
 primtype Char#
 
-primop   CharGtOp  "gtChar#"   Compare   Char# -> Char# -> Bool
-primop   CharGeOp  "geChar#"   Compare   Char# -> Char# -> Bool
+primop   CharGtOp  "gtCharI#"   Compare   Char# -> Char# -> Int#
+primop   CharGeOp  "geCharI#"   Compare   Char# -> Char# -> Int#
 
-primop   CharEqOp  "eqChar#"   Compare
-   Char# -> Char# -> Bool
+primop   CharEqOp  "eqCharI#"   Compare
+   Char# -> Char# -> Int#
    with commutable = True
 
-primop   CharNeOp  "neChar#"   Compare
-   Char# -> Char# -> Bool
+primop   CharNeOp  "neCharI#"   Compare
+   Char# -> Char# -> Int#
    with commutable = True
 
-primop   CharLtOp  "ltChar#"   Compare   Char# -> Char# -> Bool
-primop   CharLeOp  "leChar#"   Compare   Char# -> Char# -> Bool
+primop   CharLtOp  "ltCharI#"   Compare   Char# -> Char# -> Int#
+primop   CharLeOp  "leCharI#"   Compare   Char# -> Char# -> Int#
 
 primop   OrdOp   "ord#"  GenPrimOp   Char# -> Int#
    with code_size = 0
@@ -239,26 +239,26 @@ primop   IntSubCOp   "subIntC#"    GenPrimOp   Int# -> Int# -> (# Int#, Int# #)
           second member is 0 iff no overflow occured.}
    with code_size = 2
 
-primop   IntGtOp  ">#"   Compare   Int# -> Int# -> Bool
+primop   IntGtOp  ">$#"   Compare   Int# -> Int# -> Int#
    with fixity = infix 4
 
-primop   IntGeOp  ">=#"   Compare   Int# -> Int# -> Bool
+primop   IntGeOp  ">=$#"   Compare   Int# -> Int# -> Int#
    with fixity = infix 4
 
-primop   IntEqOp  "==#"   Compare
-   Int# -> Int# -> Bool
+primop   IntEqOp  "==$#"   Compare
+   Int# -> Int# -> Int#
    with commutable = True
         fixity = infix 4
 
-primop   IntNeOp  "/=#"   Compare
-   Int# -> Int# -> Bool
+primop   IntNeOp  "/=$#"   Compare
+   Int# -> Int# -> Int#
    with commutable = True
         fixity = infix 4
 
-primop   IntLtOp  "<#"   Compare   Int# -> Int# -> Bool
+primop   IntLtOp  "<$#"   Compare   Int# -> Int# -> Int#
    with fixity = infix 4
 
-primop   IntLeOp  "<=#"   Compare   Int# -> Int# -> Bool
+primop   IntLeOp  "<=$#"   Compare   Int# -> Int# -> Int#
    with fixity = infix 4
 
 primop   ChrOp   "chr#"   GenPrimOp   Int# -> Char#
@@ -345,12 +345,12 @@ primop   SrlOp   "uncheckedShiftRL#"   GenPrimOp   Word# -> Int# -> Word#
 primop   Word2IntOp   "word2Int#"   GenPrimOp   Word# -> Int#
    with code_size = 0
 
-primop   WordGtOp   "gtWord#"   Compare   Word# -> Word# -> Bool
-primop   WordGeOp   "geWord#"   Compare   Word# -> Word# -> Bool
-primop   WordEqOp   "eqWord#"   Compare   Word# -> Word# -> Bool
-primop   WordNeOp   "neWord#"   Compare   Word# -> Word# -> Bool
-primop   WordLtOp   "ltWord#"   Compare   Word# -> Word# -> Bool
-primop   WordLeOp   "leWord#"   Compare   Word# -> Word# -> Bool
+primop   WordGtOp   "gtWordI#"   Compare   Word# -> Word# -> Int#
+primop   WordGeOp   "geWordI#"   Compare   Word# -> Word# -> Int#
+primop   WordEqOp   "eqWordI#"   Compare   Word# -> Word# -> Int#
+primop   WordNeOp   "neWordI#"   Compare   Word# -> Word# -> Int#
+primop   WordLtOp   "ltWordI#"   Compare   Word# -> Word# -> Int#
+primop   WordLeOp   "leWordI#"   Compare   Word# -> Word# -> Int#
 
 primop   PopCnt8Op   "popCnt8#"   Monadic   Word# -> Word#
     {Count the number of set bits in the lower 8 bits of a word.}
@@ -363,6 +363,15 @@ primop   PopCnt64Op   "popCnt64#"   GenPrimOp   WORD64 -> Word#
 primop   PopCntOp   "popCnt#"   Monadic   Word# -> Word#
     {Count the number of set bits in a word.}
 
+primop   BSwap16Op   "byteSwap16#"   Monadic   Word# -> Word#
+    {Swap bytes in the lower 16 bits of a word. The higher bytes are undefined. }
+primop   BSwap32Op   "byteSwap32#"   Monadic   Word# -> Word#
+    {Swap bytes in the lower 32 bits of a word. The higher bytes are undefined. }
+primop   BSwap64Op   "byteSwap64#"   Monadic   WORD64 -> WORD64
+    {Swap bytes in a 64 bits of a word.}
+primop   BSwapOp     "byteSwap#"     Monadic   Word# -> Word#
+    {Swap bytes in a word.}
+
 ------------------------------------------------------------------------
 section "Narrowings" 
 	{Explicit narrowing of native-sized ints or words.}
@@ -426,26 +435,26 @@ section "Double#"
 
 primtype Double#
 
-primop   DoubleGtOp ">##"   Compare   Double# -> Double# -> Bool
+primop   DoubleGtOp ">$##"   Compare   Double# -> Double# -> Int#
    with fixity = infix 4
 
-primop   DoubleGeOp ">=##"   Compare   Double# -> Double# -> Bool
+primop   DoubleGeOp ">=$##"   Compare   Double# -> Double# -> Int#
    with fixity = infix 4
 
-primop DoubleEqOp "==##"   Compare
-   Double# -> Double# -> Bool
+primop DoubleEqOp "==$##"   Compare
+   Double# -> Double# -> Int#
    with commutable = True
         fixity = infix 4
 
-primop DoubleNeOp "/=##"   Compare
-   Double# -> Double# -> Bool
+primop DoubleNeOp "/=$##"   Compare
+   Double# -> Double# -> Int#
    with commutable = True
         fixity = infix 4
 
-primop   DoubleLtOp "<##"   Compare   Double# -> Double# -> Bool
+primop   DoubleLtOp "<$##"   Compare   Double# -> Double# -> Int#
    with fixity = infix 4
 
-primop   DoubleLeOp "<=##"   Compare   Double# -> Double# -> Bool
+primop   DoubleLeOp "<=$##"   Compare   Double# -> Double# -> Int#
    with fixity = infix 4
 
 primop   DoubleAddOp   "+##"   Dyadic
@@ -559,19 +568,19 @@ section "Float#"
 
 primtype Float#
 
-primop   FloatGtOp  "gtFloat#"   Compare   Float# -> Float# -> Bool
-primop   FloatGeOp  "geFloat#"   Compare   Float# -> Float# -> Bool
+primop   FloatGtOp  "gtFloatI#"   Compare   Float# -> Float# -> Int#
+primop   FloatGeOp  "geFloatI#"   Compare   Float# -> Float# -> Int#
 
-primop   FloatEqOp  "eqFloat#"   Compare
-   Float# -> Float# -> Bool
+primop   FloatEqOp  "eqFloatI#"   Compare
+   Float# -> Float# -> Int#
    with commutable = True
 
-primop   FloatNeOp  "neFloat#"   Compare
-   Float# -> Float# -> Bool
+primop   FloatNeOp  "neFloatI#"   Compare
+   Float# -> Float# -> Int#
    with commutable = True
 
-primop   FloatLtOp  "ltFloat#"   Compare   Float# -> Float# -> Bool
-primop   FloatLeOp  "leFloat#"   Compare   Float# -> Float# -> Bool
+primop   FloatLtOp  "ltFloatI#"   Compare   Float# -> Float# -> Int#
+primop   FloatLeOp  "leFloatI#"   Compare   Float# -> Float# -> Int#
 
 primop   FloatAddOp   "plusFloat#"      Dyadic            
    Float# -> Float# -> Float#
@@ -689,7 +698,7 @@ primop  NewArrayOp "newArray#" GenPrimOp
    has_side_effects = True
 
 primop  SameMutableArrayOp "sameMutableArray#" GenPrimOp
-   MutableArray# s a -> MutableArray# s a -> Bool
+   MutableArray# s a -> MutableArray# s a -> Int#
 
 primop  ReadArrayOp "readArray#" GenPrimOp
    MutableArray# s a -> Int# -> State# s -> (# State# s, a #)
@@ -828,7 +837,7 @@ primop  ByteArrayContents_Char "byteArrayContents#" GenPrimOp
    {Intended for use with pinned arrays; otherwise very unsafe!}
 
 primop  SameMutableByteArrayOp "sameMutableByteArray#" GenPrimOp
-   MutableByteArray# s -> MutableByteArray# s -> Bool
+   MutableByteArray# s -> MutableByteArray# s -> Int#
 
 primop  UnsafeFreezeByteArrayOp "unsafeFreezeByteArray#" GenPrimOp
    MutableByteArray# s -> State# s -> (# State# s, ByteArray# #)
@@ -1124,7 +1133,7 @@ primop  NewArrayArrayOp "newArrayArray#" GenPrimOp
    has_side_effects = True
 
 primop  SameMutableArrayArrayOp "sameMutableArrayArray#" GenPrimOp
-   MutableArrayArray# s -> MutableArrayArray# s -> Bool
+   MutableArrayArray# s -> MutableArrayArray# s -> Int#
 
 primop  UnsafeFreezeArrayArrayOp "unsafeFreezeArrayArray#" GenPrimOp
    MutableArrayArray# s -> State# s -> (# State# s, ArrayArray# #)
@@ -1235,12 +1244,12 @@ primop   Int2AddrOp   "int2Addr#"    GenPrimOp  Int# -> Addr#
    with code_size = 0
 #endif
 
-primop   AddrGtOp  "gtAddr#"   Compare   Addr# -> Addr# -> Bool
-primop   AddrGeOp  "geAddr#"   Compare   Addr# -> Addr# -> Bool
-primop   AddrEqOp  "eqAddr#"   Compare   Addr# -> Addr# -> Bool
-primop   AddrNeOp  "neAddr#"   Compare   Addr# -> Addr# -> Bool
-primop   AddrLtOp  "ltAddr#"   Compare   Addr# -> Addr# -> Bool
-primop   AddrLeOp  "leAddr#"   Compare   Addr# -> Addr# -> Bool
+primop   AddrGtOp  "gtAddrI#"   Compare   Addr# -> Addr# -> Int#
+primop   AddrGeOp  "geAddrI#"   Compare   Addr# -> Addr# -> Int#
+primop   AddrEqOp  "eqAddrI#"   Compare   Addr# -> Addr# -> Int#
+primop   AddrNeOp  "neAddrI#"   Compare   Addr# -> Addr# -> Int#
+primop   AddrLtOp  "ltAddrI#"   Compare   Addr# -> Addr# -> Int#
+primop   AddrLeOp  "leAddrI#"   Compare   Addr# -> Addr# -> Int#
 
 primop IndexOffAddrOp_Char "indexCharOffAddr#" GenPrimOp
    Addr# -> Int# -> Char#
@@ -1501,7 +1510,7 @@ primop  WriteMutVarOp "writeMutVar#"  GenPrimOp
    can_fail         = True
 
 primop  SameMutVarOp "sameMutVar#" GenPrimOp
-   MutVar# s a -> MutVar# s a -> Bool
+   MutVar# s a -> MutVar# s a -> Int#
 
 -- not really the right type, but we don't know about pairs here.  The
 -- correct type is
@@ -1602,9 +1611,20 @@ primop	AtomicallyOp "atomically#" GenPrimOp
    out_of_line = True
    has_side_effects = True
 
+-- NB: retry#'s strictness information specifies it to return bottom.
+-- This lets the compiler perform some extra simplifications, since retry#
+-- will technically never return.
+--
+-- This allows the simplifier to replace things like:
+--   case retry# s1
+--     (# s2, a #) -> e
+-- with:
+--   retry# s1
+-- where 'e' would be unreachable anyway.  See Trac #8091.
 primop  RetryOp "retry#" GenPrimOp
    State# RealWorld -> (# State# RealWorld, a #)
    with 
+   strictness  = { \ _arity -> mkStrictSig (mkTopDmdType [topDmd] botRes) }
    out_of_line = True
    has_side_effects = True
 
@@ -1665,7 +1685,7 @@ primop	WriteTVarOp "writeTVar#" GenPrimOp
    has_side_effects = True
 
 primop  SameTVarOp "sameTVar#" GenPrimOp
-   TVar# s a -> TVar# s a -> Bool
+   TVar# s a -> TVar# s a -> Int#
 
 
 ------------------------------------------------------------------------
@@ -1717,8 +1737,25 @@ primop  TryPutMVarOp "tryPutMVar#" GenPrimOp
    out_of_line      = True
    has_side_effects = True
 
+primop  ReadMVarOp "readMVar#" GenPrimOp
+   MVar# s a -> State# s -> (# State# s, a #)
+   {If {\tt MVar\#} is empty, block until it becomes full.
+   Then read its contents without modifying the MVar, without possibility
+   of intervention from other threads.}
+   with
+   out_of_line      = True
+   has_side_effects = True
+
+primop  TryReadMVarOp "tryReadMVar#" GenPrimOp
+   MVar# s a -> State# s -> (# State# s, Int#, a #)
+   {If {\tt MVar\#} is empty, immediately return with integer 0 and value undefined.
+   Otherwise, return with integer 1 and contents of {\tt MVar\#}.}
+   with
+   out_of_line      = True
+   has_side_effects = True
+
 primop  SameMVarOp "sameMVar#" GenPrimOp
-   MVar# s a -> MVar# s a -> Bool
+   MVar# s a -> MVar# s a -> Int#
 
 primop  IsEmptyMVarOp "isEmptyMVar#" GenPrimOp
    MVar# s a -> State# s -> (# State# s, Int# #)
@@ -1871,8 +1908,15 @@ primop  MkWeakNoFinalizerOp "mkWeakNoFinalizer#" GenPrimOp
    has_side_effects = True
    out_of_line      = True
 
-primop  MkWeakForeignEnvOp "mkWeakForeignEnv#" GenPrimOp
-   o -> b -> Addr# -> Addr# -> Int# -> Addr# -> State# RealWorld -> (# State# RealWorld, Weak# b #)
+primop  AddCFinalizerToWeakOp "addCFinalizerToWeak#" GenPrimOp
+   Addr# -> Addr# -> Int# -> Addr# -> Weak# b
+          -> State# RealWorld -> (# State# RealWorld, Int# #)
+   { {\tt addCFinalizerToWeak# fptr ptr flag eptr w} attaches a C
+     function pointer {\tt fptr} to a weak pointer {\tt w} as a finalizer. If
+     {\tt flag} is zero, {\tt fptr} will be called with one argument,
+     {\tt ptr}. Otherwise, it will be called with two arguments,
+     {\tt eptr} and {\tt ptr}. {\tt addCFinalizerToWeak#} returns
+     1 on success, or 0 if {\tt w} is already dead. }
    with
    has_side_effects = True
    out_of_line      = True