Restore old names of comparison primops
authorJan Stolarek <jan.stolarek@p.lodz.pl>
Mon, 16 Sep 2013 14:04:57 +0000 (15:04 +0100)
committerJan Stolarek <jan.stolarek@p.lodz.pl>
Wed, 18 Sep 2013 13:48:10 +0000 (14:48 +0100)
In 6579a6c we removed existing comparison primops and introduced new ones
returning Int# instead of Bool. This commit (and associated commits in
array, base, dph, ghc-prim, integer-gmp, integer-simple, primitive, testsuite and
template-haskell) restores old names of primops. This allows us to keep
our API cleaner at the price of not having backwards compatibility.

This patch also temporalily disables fix for #8317 (optimization of
tagToEnum# at Core level). We need to fix #8326 first, otherwise
our primops code will be very slow.

14 files changed:
aclocal.m4
compiler/ghc.cabal.in
compiler/ghc.mk
compiler/main/BreakArray.hs
compiler/prelude/PrelNames.lhs
compiler/prelude/primops.txt.pp
compiler/simplCore/Simplify.lhs
compiler/typecheck/TcGenDeriv.lhs
compiler/utils/Binary.hs
compiler/utils/Encoding.hs
compiler/utils/ExtsCompat46.hs [new file with mode: 0644]
compiler/utils/FastString.lhs
compiler/utils/FastTypes.lhs
libraries/primitive

index 1e628b1..8a9fe63 100644 (file)
@@ -866,13 +866,8 @@ changequote([, ])dnl
 ])
 if test ! -f compiler/parser/Parser.hs || test ! -f compiler/cmm/CmmParse.hs || test ! -f compiler/parser/ParserCore.hs
 then
-    FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-lt],[1.16],
-      [AC_MSG_ERROR([Happy version 1.16 or later is required to compile GHC.])])[]
-fi
-if test ! -f compiler/parser/Parser.hs || test ! -f compiler/cmm/CmmParse.hs || test ! -f compiler/parser/ParserCore.hs
-then
-    FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-gt],[1.18.11],
-      [AC_MSG_ERROR([Happy version 1.18.11 or earlier is required to compile GHC.])])[]
+    FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-lt],[1.19],
+      [AC_MSG_ERROR([Happy version 1.19 or later is required to compile GHC.])])[]
 fi
 HappyVersion=$fptools_cv_happy_version;
 AC_SUBST(HappyVersion)
@@ -900,13 +895,8 @@ FP_COMPARE_VERSIONS([$fptools_cv_alex_version],[-ge],[3.0],
   [Alex3=YES],[Alex3=NO])
 if test ! -f compiler/cmm/CmmLex.hs || test ! -f compiler/parser/Lexer.hs
 then
-    FP_COMPARE_VERSIONS([$fptools_cv_alex_version],[-lt],[2.1.0],
-      [AC_MSG_ERROR([Alex version 2.1.0 or later is required to compile GHC.])])[]
-fi
-if test ! -f compiler/cmm/CmmLex.hs || test ! -f compiler/parser/Lexer.hs
-then
-    FP_COMPARE_VERSIONS([$fptools_cv_alex_version],[-gt],[3.0.5],
-      [AC_MSG_ERROR([Alex version 3.0.5 or earlier is required to compile GHC.])])[]
+    FP_COMPARE_VERSIONS([$fptools_cv_alex_version],[-lt],[3.1.0],
+      [AC_MSG_ERROR([Alex version 3.1.0 or later is required to compile GHC.])])[]
 fi
 if test ! -f utils/haddock/src/Haddock/Lex.hs
 then
index f09cf64..a0f3e64 100644 (file)
@@ -428,6 +428,8 @@ Library
         UniqFM
         UniqSet
         Util
+        ExtsCompat46
+--      ^^^  a temporary module necessary to bootstrap with GHC <= 7.6
         Vectorise.Builtins.Base
         Vectorise.Builtins.Initialise
         Vectorise.Builtins
index 15f953c..bf0ecaa 100644 (file)
@@ -445,8 +445,7 @@ compiler_stage3_SplitObjs = NO
 # We therefore need to split some of the modules off into a separate
 # DLL. This clump are the modules reachable from DynFlags:
 compiler_stage2_dll0_START_MODULE = DynFlags
-
-compiler_stage2_dll0_MODULES = Annotations Avail Bag BasicTypes BinIface Binary Bitmap BlockId BooleanFormula BreakArray BufWrite BuildTyCl ByteCodeAsm ByteCodeInstr ByteCodeItbls ByteCodeLink CLabel Class CmdLineParser Cmm CmmCallConv CmmExpr CmmInfo CmmMachOp CmmNode CmmType CmmUtils CoAxiom CodeGen.Platform CodeGen.Platform.ARM CodeGen.Platform.NoRegs CodeGen.Platform.PPC CodeGen.Platform.PPC_Darwin CodeGen.Platform.SPARC CodeGen.Platform.X86 CodeGen.Platform.X86_64 Coercion Config Constants CoreArity CoreFVs CoreLint CoreSubst CoreSyn CoreTidy CoreUnfold CoreUtils CostCentre DataCon Demand Digraph DriverPhases DynFlags Encoding ErrUtils Exception FamInst FamInstEnv FastBool FastFunctions FastMutInt FastString FastTypes Finder Fingerprint FiniteMap ForeignCall Hoopl Hoopl.Dataflow HsBinds HsDecls HsDoc HsExpr HsImpExp HsLit HsPat HsSyn HsTypes HsUtils HscTypes IOEnv Id IdInfo IfaceEnv IfaceSyn IfaceType InstEnv InteractiveEvalTypes Kind ListSetOps Literal LoadIface Maybes MkCore MkGraph MkId Module MonadUtils Name NameEnv NameSet ObjLink OccName OccurAnal OptCoercion OrdList Outputable PackageConfig Packages Pair Panic Platform PlatformConstants PprCmm PprCmmDecl PprCmmExpr PprCore PrelInfo PrelNames PrelRules Pretty PrimOp RdrName Reg RegClass Rules SMRep Serialized SrcLoc StaticFlags StgCmmArgRep StgCmmClosure StgCmmEnv StgCmmLayout StgCmmMonad StgCmmProf StgCmmTicky StgCmmUtils StgSyn Stream StringBuffer TcEvidence TcIface TcMType TcRnMonad TcRnTypes TcType TcTypeNats TrieMap TyCon Type TypeRep TysPrim TysWiredIn Unify UniqFM UniqSet UniqSupply Unique Util Var VarEnv VarSet
+compiler_stage2_dll0_MODULES = Annotations Avail Bag BasicTypes BinIface Binary Bitmap BlockId BooleanFormula BreakArray BufWrite BuildTyCl ByteCodeAsm ByteCodeInstr ByteCodeItbls ByteCodeLink CLabel Class CmdLineParser Cmm CmmCallConv CmmExpr CmmInfo CmmMachOp CmmNode CmmType CmmUtils CoAxiom CodeGen.Platform CodeGen.Platform.ARM CodeGen.Platform.NoRegs CodeGen.Platform.PPC CodeGen.Platform.PPC_Darwin CodeGen.Platform.SPARC CodeGen.Platform.X86 CodeGen.Platform.X86_64 Coercion Config Constants CoreArity CoreFVs CoreLint CoreSubst CoreSyn CoreTidy CoreUnfold CoreUtils CostCentre DataCon Demand Digraph DriverPhases DynFlags Encoding ErrUtils Exception ExtsCompat46 FamInst FamInstEnv FastBool FastFunctions FastMutInt FastString FastTypes Finder Fingerprint FiniteMap ForeignCall Hoopl Hoopl.Dataflow HsBinds HsDecls HsDoc HsExpr HsImpExp HsLit HsPat HsSyn HsTypes HsUtils HscTypes IOEnv Id IdInfo IfaceEnv IfaceSyn IfaceType InstEnv InteractiveEvalTypes Kind ListSetOps Literal LoadIface Maybes MkCore MkGraph MkId Module MonadUtils Name NameEnv NameSet ObjLink OccName OccurAnal OptCoercion OrdList Outputable PackageConfig Packages Pair Panic Platform PlatformConstants PprCmm PprCmmDecl PprCmmExpr PprCore PrelInfo PrelNames PrelRules Pretty PrimOp RdrName Reg RegClass Rules SMRep Serialized SrcLoc StaticFlags StgCmmArgRep StgCmmClosure StgCmmEnv StgCmmLayout StgCmmMonad StgCmmProf StgCmmTicky StgCmmUtils StgSyn Stream StringBuffer TcEvidence TcIface TcMType TcRnMonad TcRnTypes TcType TcTypeNats TrieMap TyCon Type TypeRep TysPrim TysWiredIn Unify UniqFM UniqSet UniqSupply Unique Util Var VarEnv VarSet
 
 compiler_stage2_dll0_HS_OBJS = \
     $(patsubst %,compiler/stage2/build/%.$(dyn_osuf),$(subst .,/,$(compiler_stage2_dll0_MODULES)))
index 4a8612d..d16d6f2 100644 (file)
@@ -30,7 +30,7 @@ import DynFlags
 #ifdef GHCI
 import Control.Monad
 
-import GHC.Exts
+import ExtsCompat46
 import GHC.IO ( IO(..) )
 
 data BreakArray = BA (MutableByteArray# RealWorld)
index dfb3f82..728f4bc 100644 (file)
@@ -352,7 +352,7 @@ genericTyConNames = [
 pRELUDE :: Module
 pRELUDE         = mkBaseModule_ pRELUDE_NAME
 
-gHC_PRIM, gHC_PRIMWRAPPERS, gHC_TYPES, gHC_GENERICS, gHC_MAGIC, gHC_COERCIBLE,
+gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC, gHC_COERCIBLE,
     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,
@@ -365,7 +365,6 @@ gHC_PRIM, gHC_PRIMWRAPPERS, gHC_TYPES, gHC_GENERICS, gHC_MAGIC, gHC_COERCIBLE,
     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")
index f9c4f1b..cfd6afa 100644 (file)
@@ -134,25 +134,25 @@ section "The word size story."
 #endif
 
 ------------------------------------------------------------------------
-section "Char#" 
+section "Char#"
        {Operations on 31-bit characters.}
 ------------------------------------------------------------------------
 
 primtype Char#
 
-primop   CharGtOp  "gtCharI#"   Compare   Char# -> Char# -> Int#
-primop   CharGeOp  "geCharI#"   Compare   Char# -> Char# -> Int#
+primop   CharGtOp  "gtChar#"   Compare   Char# -> Char# -> Int#
+primop   CharGeOp  "geChar#"   Compare   Char# -> Char# -> Int#
 
-primop   CharEqOp  "eqCharI#"   Compare
+primop   CharEqOp  "eqChar#"   Compare
    Char# -> Char# -> Int#
    with commutable = True
 
-primop   CharNeOp  "neCharI#"   Compare
+primop   CharNeOp  "neChar#"   Compare
    Char# -> Char# -> Int#
    with commutable = True
 
-primop   CharLtOp  "ltCharI#"   Compare   Char# -> Char# -> Int#
-primop   CharLeOp  "leCharI#"   Compare   Char# -> Char# -> Int#
+primop   CharLtOp  "ltChar#"   Compare   Char# -> Char# -> Int#
+primop   CharLeOp  "leChar#"   Compare   Char# -> Char# -> Int#
 
 primop   OrdOp   "ord#"  GenPrimOp   Char# -> Int#
    with code_size = 0
@@ -230,35 +230,35 @@ primop   NotIOp   "notI#"   Monadic   Int# -> Int#
 
 primop   IntNegOp    "negateInt#"    Monadic   Int# -> Int#
 primop   IntAddCOp   "addIntC#"    GenPrimOp   Int# -> Int# -> (# Int#, Int# #)
-        {Add with carry.  First member of result is (wrapped) sum; 
+        {Add with carry.  First member of result is (wrapped) sum;
           second member is 0 iff no overflow occured.}
    with code_size = 2
 
 primop   IntSubCOp   "subIntC#"    GenPrimOp   Int# -> Int# -> (# Int#, Int# #)
-        {Subtract with carry.  First member of result is (wrapped) difference; 
+        {Subtract with carry.  First member of result is (wrapped) difference;
           second member is 0 iff no overflow occured.}
    with code_size = 2
 
-primop   IntGtOp  ">$#"   Compare   Int# -> Int# -> Int#
+primop   IntGtOp  ">#"   Compare   Int# -> Int# -> Int#
    with fixity = infix 4
 
-primop   IntGeOp  ">=$#"   Compare   Int# -> Int# -> Int#
+primop   IntGeOp  ">=#"   Compare   Int# -> Int# -> Int#
    with fixity = infix 4
 
-primop   IntEqOp  "==$#"   Compare
+primop   IntEqOp  "==#"   Compare
    Int# -> Int# -> Int#
    with commutable = True
         fixity = infix 4
 
-primop   IntNeOp  "/=$#"   Compare
+primop   IntNeOp  "/=#"   Compare
    Int# -> Int# -> Int#
    with commutable = True
         fixity = infix 4
 
-primop   IntLtOp  "<$#"   Compare   Int# -> Int# -> Int#
+primop   IntLtOp  "<#"   Compare   Int# -> Int# -> Int#
    with fixity = infix 4
 
-primop   IntLeOp  "<=$#"   Compare   Int# -> Int# -> Int#
+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   "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   WordGtOp   "gtWord#"   Compare   Word# -> Word# -> Int#
+primop   WordGeOp   "geWord#"   Compare   Word# -> Word# -> Int#
+primop   WordEqOp   "eqWord#"   Compare   Word# -> Word# -> Int#
+primop   WordNeOp   "neWord#"   Compare   Word# -> Word# -> Int#
+primop   WordLtOp   "ltWord#"   Compare   Word# -> Word# -> Int#
+primop   WordLeOp   "leWord#"   Compare   Word# -> Word# -> Int#
 
 primop   PopCnt8Op   "popCnt8#"   Monadic   Word# -> Word#
     {Count the number of set bits in the lower 8 bits of a word.}
@@ -435,26 +435,26 @@ section "Double#"
 
 primtype Double#
 
-primop   DoubleGtOp ">$##"   Compare   Double# -> Double# -> Int#
+primop   DoubleGtOp ">##"   Compare   Double# -> Double# -> Int#
    with fixity = infix 4
 
-primop   DoubleGeOp ">=$##"   Compare   Double# -> Double# -> Int#
+primop   DoubleGeOp ">=##"   Compare   Double# -> Double# -> Int#
    with fixity = infix 4
 
-primop DoubleEqOp "==$##"   Compare
+primop DoubleEqOp "==##"   Compare
    Double# -> Double# -> Int#
    with commutable = True
         fixity = infix 4
 
-primop DoubleNeOp "/=$##"   Compare
+primop DoubleNeOp "/=##"   Compare
    Double# -> Double# -> Int#
    with commutable = True
         fixity = infix 4
 
-primop   DoubleLtOp "<$##"   Compare   Double# -> Double# -> Int#
+primop   DoubleLtOp "<##"   Compare   Double# -> Double# -> Int#
    with fixity = infix 4
 
-primop   DoubleLeOp "<=$##"   Compare   Double# -> Double# -> Int#
+primop   DoubleLeOp "<=##"   Compare   Double# -> Double# -> Int#
    with fixity = infix 4
 
 primop   DoubleAddOp   "+##"   Dyadic
@@ -562,37 +562,37 @@ primop   DoubleDecode_2IntOp   "decodeDouble_2Int#" GenPrimOp
    with out_of_line = True
 
 ------------------------------------------------------------------------
-section "Float#" 
+section "Float#"
        {Operations on single-precision (32-bit) floating-point numbers.}
 ------------------------------------------------------------------------
 
 primtype Float#
 
-primop   FloatGtOp  "gtFloatI#"   Compare   Float# -> Float# -> Int#
-primop   FloatGeOp  "geFloatI#"   Compare   Float# -> Float# -> Int#
+primop   FloatGtOp  "gtFloat#"   Compare   Float# -> Float# -> Int#
+primop   FloatGeOp  "geFloat#"   Compare   Float# -> Float# -> Int#
 
-primop   FloatEqOp  "eqFloatI#"   Compare
+primop   FloatEqOp  "eqFloat#"   Compare
    Float# -> Float# -> Int#
    with commutable = True
 
-primop   FloatNeOp  "neFloatI#"   Compare
+primop   FloatNeOp  "neFloat#"   Compare
    Float# -> Float# -> Int#
    with commutable = True
 
-primop   FloatLtOp  "ltFloatI#"   Compare   Float# -> Float# -> Int#
-primop   FloatLeOp  "leFloatI#"   Compare   Float# -> Float# -> Int#
+primop   FloatLtOp  "ltFloat#"   Compare   Float# -> Float# -> Int#
+primop   FloatLeOp  "leFloat#"   Compare   Float# -> Float# -> Int#
 
-primop   FloatAddOp   "plusFloat#"      Dyadic            
+primop   FloatAddOp   "plusFloat#"      Dyadic
    Float# -> Float# -> Float#
    with commutable = True
 
 primop   FloatSubOp   "minusFloat#"      Dyadic      Float# -> Float# -> Float#
 
-primop   FloatMulOp   "timesFloat#"      Dyadic    
+primop   FloatMulOp   "timesFloat#"      Dyadic
    Float# -> Float# -> Float#
    with commutable = True
 
-primop   FloatDivOp   "divideFloat#"      Dyadic  
+primop   FloatDivOp   "divideFloat#"      Dyadic
    Float# -> Float# -> Float#
    with can_fail = True
 
@@ -1303,12 +1303,12 @@ primop   Int2AddrOp   "int2Addr#"    GenPrimOp  Int# -> Addr#
    with code_size = 0
 #endif
 
-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   AddrGtOp  "gtAddr#"   Compare   Addr# -> Addr# -> Int#
+primop   AddrGeOp  "geAddr#"   Compare   Addr# -> Addr# -> Int#
+primop   AddrEqOp  "eqAddr#"   Compare   Addr# -> Addr# -> Int#
+primop   AddrNeOp  "neAddr#"   Compare   Addr# -> Addr# -> Int#
+primop   AddrLtOp  "ltAddr#"   Compare   Addr# -> Addr# -> Int#
+primop   AddrLeOp  "leAddr#"   Compare   Addr# -> Addr# -> Int#
 
 primop IndexOffAddrOp_Char "indexCharOffAddr#" GenPrimOp
    Addr# -> Int# -> Char#
index a88d943..a0bd7f8 100644 (file)
@@ -14,7 +14,7 @@ import Type hiding      ( substTy, extendTvSubst, substTyVar )
 import SimplEnv
 import SimplUtils
 import FamInstEnv       ( FamInstEnv )
-import Literal          ( litIsLifted, mkMachInt )
+import Literal          ( litIsLifted ) --, mkMachInt ) -- temporalily commented out. See #8326
 import Id
 import MkId             ( seqId, realWorldPrimId )
 import MkCore           ( mkImpossibleExpr, castBottomExpr )
@@ -23,9 +23,9 @@ import Name             ( mkSystemVarName, isExternalName )
 import Coercion hiding  ( substCo, substTy, substCoVar, extendTvSubst )
 import OptCoercion      ( optCoercion )
 import FamInstEnv       ( topNormaliseType )
-import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness 
-                        , isMarkedStrict, dataConTyCon, dataConTag, fIRST_TAG )
-import TyCon            ( isEnumerationTyCon )
+import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness
+                        , isMarkedStrict ) --, dataConTyCon, dataConTag, fIRST_TAG )
+--import TyCon            ( isEnumerationTyCon ) -- temporalily commented out. See #8326
 import CoreMonad        ( Tick(..), SimplifierMode(..) )
 import CoreSyn
 import Demand           ( StrictSig(..), dmdTypeDepth )
@@ -33,13 +33,13 @@ import PprCore          ( pprParendExpr, pprCoreExpr )
 import CoreUnfold
 import CoreUtils
 import CoreArity
-import PrimOp           ( tagToEnumKey )
+--import PrimOp           ( tagToEnumKey ) -- temporalily commented out. See #8326
 import Rules            ( lookupRule, getRules )
-import TysPrim          ( realWorldStatePrimTy, intPrimTy )
+import TysPrim          ( realWorldStatePrimTy ) --, intPrimTy ) -- temporalily commented out. See #8326
 import BasicTypes       ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
 import MonadUtils       ( foldlM, mapAccumLM, liftIO )
 import Maybes           ( orElse )
-import Unique           ( hasKey )
+--import Unique           ( hasKey ) -- temporalily commented out. See #8326
 import Control.Monad
 import Data.List        ( mapAccumL )
 import Outputable
@@ -1559,13 +1559,13 @@ all this at once is TOO HARD!
 \begin{code}
 tryRules :: SimplEnv -> [CoreRule]
          -> Id -> [OutExpr] -> SimplCont
-         -> SimplM (Maybe (CoreExpr, SimplCont)) 
+         -> SimplM (Maybe (CoreExpr, SimplCont))
 -- The SimplEnv already has zapSubstEnv applied to it
 
 tryRules env rules fn args call_cont
   | null rules
   = return Nothing
-
+{- Disabled until we fix #8326
   | fn `hasKey` tagToEnumKey   -- See Note [Optimising tagToEnum#]
   , [_type_arg, val_arg] <- args
   , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont
@@ -1584,8 +1584,8 @@ tryRules env rules fn args call_cont
              new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts
              new_bndr = setIdType bndr intPrimTy   
                  -- The binder is dead, but should have the right type
-      ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) } 
-
+      ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) }
+-}
   | otherwise
   = do { dflags <- getDynFlags
        ; case lookupRule dflags (getUnfoldingInRuleMatch env) (activeRule env) 
@@ -1621,15 +1621,22 @@ tryRules env rules fn args call_cont
 
 Note [Optimising tagToEnum#]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We want to transform
+If we have an enumeration data type:
+
+  data Foo = A | B | C
+
+Then we want to transform
+
    case tagToEnum# x of   ==>    case x of
-     True -> e1                    DEFAULT -> e1
-     False -> e2                   0#      -> e2
+     A -> e1                       DEFAULT -> e1
+     B -> e2                       1#      -> e2
+     C -> e3                       2#      -> e3
 
 thereby getting rid of the tagToEnum# altogether.  If there was a DEFAULT
 alternative we retain it (remember it comes first).  If not the case must
 be exhaustive, and we reflect that in the transformed version by adding
 a DEFAULT.  Otherwise Lint complains that the new case is not exhaustive.
+See #8317.
 
 Note [Rules for recursive functions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
index 045978f..b7a3f31 100644 (file)
@@ -181,7 +181,7 @@ gen_Eq_binds loc tycon
                   -- extract tags compare for equality
       = [([a_Pat, b_Pat],
          untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
-                    (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
+                    (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
 
     aux_binds | no_tag_match_cons = emptyBag
               | otherwise         = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
@@ -403,14 +403,14 @@ gen_Ord_binds loc tycon
 
       | tag > last_tag `div` 2  -- lower range is larger
       = untag_Expr tycon [(b_RDR, bh_RDR)] $
-        nlHsIf (genOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)
+        nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)
                (gtResult op) $  -- Definitely GT
         nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
                                  , mkSimpleHsAlt nlWildPat (ltResult op) ]
 
       | otherwise               -- upper range is larger
       = untag_Expr tycon [(b_RDR, bh_RDR)] $
-        nlHsIf (genOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)
+        nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)
                (ltResult op) $  -- Definitely LT
         nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
                                  , mkSimpleHsAlt nlWildPat (gtResult op) ]
@@ -477,7 +477,7 @@ unliftedOrdOp tycon ty op a b
        OrdGT      -> wrap gt_op
   where
    (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" tycon ty
-   wrap prim_op = genOpApp a_expr prim_op b_expr
+   wrap prim_op = genPrimOpApp a_expr prim_op b_expr
    a_expr = nlHsVar a
    b_expr = nlHsVar b
 
@@ -487,11 +487,11 @@ unliftedCompare :: RdrName -> RdrName
                 -> LHsExpr RdrName
 -- Return (if a < b then lt else if a == b then eq else gt)
 unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
-  = nlHsIf (genOpApp a_expr lt_op b_expr) lt $
+  = nlHsIf (genPrimOpApp a_expr lt_op b_expr) lt $
                         -- Test (<) first, not (==), because the latter
                         -- is true less often, so putting it first would
                         -- mean more tests (dynamically)
-        nlHsIf (genOpApp a_expr eq_op b_expr) eq gt
+        nlHsIf (genPrimOpApp a_expr eq_op b_expr) eq gt
 
 nlConWildPat :: DataCon -> LPat RdrName
 -- The pattern (K {})
@@ -754,8 +754,8 @@ gen_Ix_binds loc tycon
           untag_Expr tycon [(a_RDR, ah_RDR)] (
           untag_Expr tycon [(b_RDR, bh_RDR)] (
           untag_Expr tycon [(c_RDR, ch_RDR)] (
-          nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
-             (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
+          nlHsIf (genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
+             (genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
           ) {-else-} (
              false_Expr
           ))))
@@ -1465,41 +1465,41 @@ conIndex_RDR   = varQual_RDR  gENERICS (fsLit "constrIndex")
 prefix_RDR     = dataQual_RDR gENERICS (fsLit "Prefix")
 infix_RDR      = dataQual_RDR gENERICS (fsLit "Infix")
 
-eqChar_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "eqChar#")
-ltChar_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "ltChar#")
-leChar_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "leChar#")
-gtChar_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "gtChar#")
-geChar_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "geChar#")
-
-eqInt_RDR      = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "==#")
-ltInt_RDR      = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "<#" )
-leInt_RDR      = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "<=#")
-gtInt_RDR      = varQual_RDR  gHC_PRIMWRAPPERS (fsLit ">#" )
-geInt_RDR      = varQual_RDR  gHC_PRIMWRAPPERS (fsLit ">=#")
-
-eqWord_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "eqWord#")
-ltWord_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "ltWord#")
-leWord_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "leWord#")
-gtWord_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "gtWord#")
-geWord_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "geWord#")
-
-eqAddr_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "eqAddr#")
-ltAddr_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "ltAddr#")
-leAddr_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "leAddr#")
-gtAddr_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "gtAddr#")
-geAddr_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "geAddr#")
-
-eqFloat_RDR    = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "eqFloat#")
-ltFloat_RDR    = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "ltFloat#")
-leFloat_RDR    = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "leFloat#")
-gtFloat_RDR    = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "gtFloat#")
-geFloat_RDR    = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "geFloat#")
-
-eqDouble_RDR   = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "==##")
-ltDouble_RDR   = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "<##" )
-leDouble_RDR   = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "<=##")
-gtDouble_RDR   = varQual_RDR  gHC_PRIMWRAPPERS (fsLit ">##" )
-geDouble_RDR   = varQual_RDR  gHC_PRIMWRAPPERS (fsLit ">=##")
+eqChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqChar#")
+ltChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltChar#")
+leChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "leChar#")
+gtChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtChar#")
+geChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "geChar#")
+
+eqInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "==#")
+ltInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "<#" )
+leInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "<=#")
+gtInt_RDR      = varQual_RDR  gHC_PRIM (fsLit ">#" )
+geInt_RDR      = varQual_RDR  gHC_PRIM (fsLit ">=#")
+
+eqWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqWord#")
+ltWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltWord#")
+leWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "leWord#")
+gtWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtWord#")
+geWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "geWord#")
+
+eqAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqAddr#")
+ltAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltAddr#")
+leAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "leAddr#")
+gtAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtAddr#")
+geAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "geAddr#")
+
+eqFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "eqFloat#")
+ltFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "ltFloat#")
+leFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "leFloat#")
+gtFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "gtFloat#")
+geFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "geFloat#")
+
+eqDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit "==##")
+ltDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit "<##" )
+leDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit "<=##")
+gtDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit ">##" )
+geDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit ">=##")
 \end{code}
 
 
@@ -2089,7 +2089,7 @@ and_Expr a b = genOpApp a and_RDR    b
 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
 eq_Expr tycon ty a b
     | not (isUnLiftedType ty) = genOpApp a eq_RDR b
-    | otherwise               = genOpApp a prim_eq b
+    | otherwise               = genPrimOpApp a prim_eq b
  where
    (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
 \end{code}
@@ -2163,6 +2163,9 @@ parenify e                 = mkHsPar e
 -- renamer won't subsequently try to re-associate it.
 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
+
+genPrimOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
+genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2))
 \end{code}
 
 \begin{code}
index f026245..332bfc8 100644 (file)
@@ -86,7 +86,7 @@ import System.IO as IO
 import System.IO.Unsafe         ( unsafeInterleaveIO )
 import System.IO.Error          ( mkIOError, eofErrorType )
 import GHC.Real                 ( Ratio(..) )
-import GHC.Exts
+import ExtsCompat46
 import GHC.Word                 ( Word8(..) )
 
 import GHC.IO ( IO(..) )
index 6467377..c4a669c 100644 (file)
@@ -32,8 +32,7 @@ module Encoding (
 import Foreign
 import Data.Char
 import Numeric
-import GHC.Ptr ( Ptr(..) )
-import GHC.Base
+import ExtsCompat46
 
 -- -----------------------------------------------------------------------------
 -- UTF-8
diff --git a/compiler/utils/ExtsCompat46.hs b/compiler/utils/ExtsCompat46.hs
new file mode 100644 (file)
index 0000000..38f81aa
--- /dev/null
@@ -0,0 +1,292 @@
+{-# LANGUAGE BangPatterns, CPP #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  ExtsCompat46
+-- Copyright   :  (c) Lodz University of Technology 2013
+-- License     :  see LICENSE
+--
+-- Maintainer  :  ghc-devs@haskell.org
+-- Stability   :  internal
+-- Portability :  non-portable (GHC internal)
+--
+-- Compatibility module to encapsulate primops API change between GHC 7.6
+-- GHC 7.8.
+--
+-- In GHC we use comparison primops in a couple of modules, but that primops
+-- have different type signature in GHC 7.6 (where they return Bool) than
+-- in GHC 7.8 (where they return Int#). As long as we allow bootstrapping
+-- with GHC 7.6 or earlier we need to have this compatibility module, so that
+-- we can compile stage1 compiler using the old API and then continue with
+-- stage2 using the new API. When we set GHC 7.8 as the minimum version
+-- required for bootstrapping, we should remove this module.
+--
+-----------------------------------------------------------------------------
+
+module ExtsCompat46 (
+    module GHC.Exts,
+
+    gtChar#, geChar#, eqChar#,
+    neChar#, ltChar#, leChar#,
+
+    (>#), (>=#), (==#), (/=#), (<#), (<=#),
+
+    gtWord#, geWord#, eqWord#,
+    neWord#, ltWord#, leWord#,
+
+    (>##), (>=##), (==##), (/=##), (<##), (<=##),
+
+    gtFloat#, geFloat#, eqFloat#,
+    neFloat#, ltFloat#, leFloat#,
+
+    gtAddr#, geAddr#, eqAddr#,
+    neAddr#, ltAddr#, leAddr#,
+
+    sameMutableArray#, sameMutableByteArray#, sameMutableArrayArray#,
+    sameMutVar#, sameTVar#, sameMVar#
+
+ ) where
+
+import GHC.Exts hiding (
+    gtChar#, geChar#, eqChar#,
+    neChar#, ltChar#, leChar#,
+
+    (>#), (>=#), (==#), (/=#), (<#), (<=#),
+
+    gtWord#, geWord#, eqWord#,
+    neWord#, ltWord#, leWord#,
+
+    (>##), (>=##), (==##), (/=##), (<##), (<=##),
+
+    gtFloat#, geFloat#, eqFloat#,
+    neFloat#, ltFloat#, leFloat#,
+
+    gtAddr#, geAddr#, eqAddr#,
+    neAddr#, ltAddr#, leAddr#,
+
+    sameMutableArray#, sameMutableByteArray#, sameMutableArrayArray#,
+    sameMutVar#, sameTVar#, sameMVar#
+ )
+
+import qualified GHC.Exts as E (
+    gtChar#, geChar#, eqChar#,
+    neChar#, ltChar#, leChar#,
+
+    (>#), (>=#), (==#), (/=#), (<#), (<=#),
+
+    gtWord#, geWord#, eqWord#,
+    neWord#, ltWord#, leWord#,
+
+    (>##), (>=##), (==##), (/=##), (<##), (<=##),
+
+    gtFloat#, geFloat#, eqFloat#,
+    neFloat#, ltFloat#, leFloat#,
+
+    gtAddr#, geAddr#, eqAddr#,
+    neAddr#, ltAddr#, leAddr#,
+
+    sameMutableArray#, sameMutableByteArray#, sameMutableArrayArray#,
+    sameMutVar#, sameTVar#, sameMVar#
+ )
+
+#if __GLASGOW_HASKELL__ > 710
+#error What is minimal version of GHC required for bootstraping? If it's GHC 7.8 we should remove this module and use GHC.Exts instead.
+#endif
+
+#if __GLASGOW_HASKELL__ > 706
+
+gtChar# :: Char# -> Char# -> Bool
+gtChar# a b = isTrue# (a `E.gtChar#` b)
+geChar# :: Char# -> Char# -> Bool
+geChar# a b = isTrue# (a `E.geChar#` b)
+eqChar# :: Char# -> Char# -> Bool
+eqChar# a b = isTrue# (a `E.eqChar#` b)
+neChar# :: Char# -> Char# -> Bool
+neChar# a b = isTrue# (a `E.neChar#` b)
+ltChar# :: Char# -> Char# -> Bool
+ltChar# a b = isTrue# (a `E.ltChar#` b)
+leChar# :: Char# -> Char# -> Bool
+leChar# a b = isTrue# (a `E.leChar#` b)
+
+infix 4 >#, >=#, ==#, /=#, <#, <=#
+
+(>#) :: Int# -> Int# -> Bool
+(>#) a b = isTrue# (a E.># b)
+(>=#) :: Int# -> Int# -> Bool
+(>=#) a b = isTrue# (a E.>=# b)
+(==#) :: Int# -> Int# -> Bool
+(==#) a b = isTrue# (a E.==# b)
+(/=#) :: Int# -> Int# -> Bool
+(/=#) a b = isTrue# (a E./=# b)
+(<#)  :: Int# -> Int# -> Bool
+(<#) a b = isTrue# (a E.<# b)
+(<=#) :: Int# -> Int# -> Bool
+(<=#) a b = isTrue# (a E.<=# b)
+
+gtWord# :: Word# -> Word# -> Bool
+gtWord# a b = isTrue# (a `E.gtWord#` b)
+geWord# :: Word# -> Word# -> Bool
+geWord# a b = isTrue# (a `E.geWord#` b)
+eqWord# :: Word# -> Word# -> Bool
+eqWord# a b = isTrue# (a `E.eqWord#` b)
+neWord# :: Word# -> Word# -> Bool
+neWord# a b = isTrue# (a `E.neWord#` b)
+ltWord# :: Word# -> Word# -> Bool
+ltWord# a b = isTrue# (a `E.ltWord#` b)
+leWord# :: Word# -> Word# -> Bool
+leWord# a b = isTrue# (a `E.leWord#` b)
+
+infix 4 >##, >=##, ==##, /=##, <##, <=##
+
+(>##)  :: Double# -> Double# -> Bool
+(>##) a b = isTrue# (a E.>## b)
+(>=##) :: Double# -> Double# -> Bool
+(>=##) a b = isTrue# (a E.>=## b)
+(==##) :: Double# -> Double# -> Bool
+(==##) a b = isTrue# (a E.==## b)
+(/=##) :: Double# -> Double# -> Bool
+(/=##) a b = isTrue# (a E./=## b)
+(<##)  :: Double# -> Double# -> Bool
+(<##) a b = isTrue# (a E.<## b)
+(<=##) :: Double# -> Double# -> Bool
+(<=##) a b = isTrue# (a E.<=## b)
+
+gtFloat# :: Float# -> Float# -> Bool
+gtFloat# a b = isTrue# (a `E.gtFloat#` b)
+geFloat# :: Float# -> Float# -> Bool
+geFloat# a b = isTrue# (a `E.geFloat#` b)
+eqFloat# :: Float# -> Float# -> Bool
+eqFloat# a b = isTrue# (a `E.eqFloat#` b)
+neFloat# :: Float# -> Float# -> Bool
+neFloat# a b = isTrue# (a `E.neFloat#` b)
+ltFloat# :: Float# -> Float# -> Bool
+ltFloat# a b = isTrue# (a `E.ltFloat#` b)
+leFloat# :: Float# -> Float# -> Bool
+leFloat# a b = isTrue# (a `E.leFloat#` b)
+
+gtAddr# :: Addr# -> Addr# -> Bool
+gtAddr# a b = isTrue# (a `E.gtAddr#` b)
+geAddr# :: Addr# -> Addr# -> Bool
+geAddr# a b = isTrue# (a `E.geAddr#` b)
+eqAddr# :: Addr# -> Addr# -> Bool
+eqAddr# a b = isTrue# (a `E.eqAddr#` b)
+neAddr# :: Addr# -> Addr# -> Bool
+neAddr# a b = isTrue# (a `E.neAddr#` b)
+ltAddr# :: Addr# -> Addr# -> Bool
+ltAddr# a b = isTrue# (a `E.ltAddr#` b)
+leAddr# :: Addr# -> Addr# -> Bool
+leAddr# a b = isTrue# (a `E.leAddr#` b)
+
+sameMutableArray# :: MutableArray# s a -> MutableArray# s a -> Bool
+sameMutableArray# a b = isTrue# (E.sameMutableArray# a b)
+sameMutableByteArray# :: MutableByteArray# s -> MutableByteArray# s -> Bool
+sameMutableByteArray# a b = isTrue# (E.sameMutableByteArray# a b)
+sameMutableArrayArray# :: MutableArrayArray# s -> MutableArrayArray# s -> Bool
+sameMutableArrayArray# a b = isTrue# (E.sameMutableArrayArray# a b)
+
+sameMutVar# :: MutVar# s a -> MutVar# s a -> Bool
+sameMutVar# a b = isTrue# (E.sameMutVar# a b)
+sameTVar# :: TVar# s a -> TVar# s a -> Bool
+sameTVar# a b = isTrue# (E.sameTVar# a b)
+sameMVar# :: MVar# s a -> MVar# s a -> Bool
+sameMVar# a b = isTrue# (E.sameMVar# a b)
+
+#else
+
+gtChar# :: Char# -> Char# -> Bool
+gtChar# a b = a `E.gtChar#` b
+geChar# :: Char# -> Char# -> Bool
+geChar# a b = a `E.geChar#` b
+eqChar# :: Char# -> Char# -> Bool
+eqChar# a b = a `E.eqChar#` b
+neChar# :: Char# -> Char# -> Bool
+neChar# a b = a `E.neChar#` b
+ltChar# :: Char# -> Char# -> Bool
+ltChar# a b = a `E.ltChar#` b
+leChar# :: Char# -> Char# -> Bool
+leChar# a b = a `E.leChar#` b
+
+infix 4 >#, >=#, ==#, /=#, <#, <=#
+
+(>#)  :: Int# -> Int# -> Bool
+(>#) a b = a E.># b
+(>=#) :: Int# -> Int# -> Bool
+(>=#) a b = a E.>=# b
+(==#) :: Int# -> Int# -> Bool
+(==#) a b = a E.==# b
+(/=#) :: Int# -> Int# -> Bool
+(/=#) a b = a E./=# b
+(<#)  :: Int# -> Int# -> Bool
+(<#) a b = a E.<# b
+(<=#) :: Int# -> Int# -> Bool
+(<=#) a b = a E.<=# b
+
+gtWord# :: Word# -> Word# -> Bool
+gtWord# a b = a `E.gtWord#` b
+geWord# :: Word# -> Word# -> Bool
+geWord# a b = a `E.geWord#` b
+eqWord# :: Word# -> Word# -> Bool
+eqWord# a b = a `E.eqWord#` b
+neWord# :: Word# -> Word# -> Bool
+neWord# a b = a `E.neWord#` b
+ltWord# :: Word# -> Word# -> Bool
+ltWord# a b = a `E.ltWord#` b
+leWord# :: Word# -> Word# -> Bool
+leWord# a b = a `E.leWord#` b
+
+infix 4 >##, >=##, ==##, /=##, <##, <=##
+
+(>##)  :: Double# -> Double# -> Bool
+(>##) a b = a E.>## b
+(>=##) :: Double# -> Double# -> Bool
+(>=##) a b = a E.>=## b
+(==##) :: Double# -> Double# -> Bool
+(==##) a b = a E.==## b
+(/=##) :: Double# -> Double# -> Bool
+(/=##) a b = a E./=## b
+(<##)  :: Double# -> Double# -> Bool
+(<##) a b = a E.<## b
+(<=##) :: Double# -> Double# -> Bool
+(<=##) a b = a E.<=## b
+
+gtFloat# :: Float# -> Float# -> Bool
+gtFloat# a b = a `E.gtFloat#` b
+geFloat# :: Float# -> Float# -> Bool
+geFloat# a b = a `E.geFloat#` b
+eqFloat# :: Float# -> Float# -> Bool
+eqFloat# a b = a `E.eqFloat#` b
+neFloat# :: Float# -> Float# -> Bool
+neFloat# a b = a `E.neFloat#` b
+ltFloat# :: Float# -> Float# -> Bool
+ltFloat# a b = a `E.ltFloat#` b
+leFloat# :: Float# -> Float# -> Bool
+leFloat# a b = a `E.leFloat#` b
+
+gtAddr# :: Addr# -> Addr# -> Bool
+gtAddr# a b = a `E.gtAddr#` b
+geAddr# :: Addr# -> Addr# -> Bool
+geAddr# a b = a `E.geAddr#` b
+eqAddr# :: Addr# -> Addr# -> Bool
+eqAddr# a b = a `E.eqAddr#` b
+neAddr# :: Addr# -> Addr# -> Bool
+neAddr# a b = a `E.neAddr#` b
+ltAddr# :: Addr# -> Addr# -> Bool
+ltAddr# a b = a `E.ltAddr#` b
+leAddr# :: Addr# -> Addr# -> Bool
+leAddr# a b = a `E.leAddr#` b
+
+sameMutableArray# :: MutableArray# s a -> MutableArray# s a -> Bool
+sameMutableArray# a b = E.sameMutableArray# a b
+sameMutableByteArray# :: MutableByteArray# s -> MutableByteArray# s -> Bool
+sameMutableByteArray# a b = E.sameMutableByteArray# a b
+sameMutableArrayArray# :: MutableArrayArray# s -> MutableArrayArray# s -> Bool
+sameMutableArrayArray# a b = E.sameMutableArrayArray# a b
+
+sameMutVar# :: MutVar# s a -> MutVar# s a -> Bool
+sameMutVar# a b = E.sameMutVar# a b
+sameTVar# :: TVar# s a -> TVar# s a -> Bool
+sameTVar# a b = E.sameTVar# a b
+sameMVar# :: MVar# s a -> MVar# s a -> Bool
+sameMVar# a b = E.sameMVar# a b
+
+#endif
\ No newline at end of file
index 9f5ac37..4c03cc7 100644 (file)
@@ -109,7 +109,7 @@ import qualified Data.ByteString.Char8    as BSC
 import qualified Data.ByteString.Internal as BS
 import qualified Data.ByteString.Unsafe   as BS
 import Foreign.C
-import GHC.Exts
+import ExtsCompat46
 import System.IO
 import System.IO.Unsafe ( unsafePerformIO )
 import Data.Data
@@ -455,10 +455,10 @@ hashStr  :: Ptr Word8 -> Int -> Int
  -- use the Addr to produce a hash value between 0 & m (inclusive)
 hashStr (Ptr a#) (I# len#) = loop 0# 0#
    where
-    loop h n | n GHC.Exts.==# len# = I# h
-             | otherwise  = loop h2 (n GHC.Exts.+# 1#)
+    loop h n | n ExtsCompat46.==# len# = I# h
+             | otherwise  = loop h2 (n ExtsCompat46.+# 1#)
           where !c = ord# (indexCharOffAddr# a# n)
-                !h2 = (c GHC.Exts.+# (h GHC.Exts.*# 128#)) `remInt#`
+                !h2 = (c ExtsCompat46.+# (h ExtsCompat46.*# 128#)) `remInt#`
                       hASH_TBL_SIZE#
 
 -- -----------------------------------------------------------------------------
index 1c67d5a..0ef10ad 100644 (file)
@@ -65,7 +65,7 @@ module FastTypes (
 #if defined(__GLASGOW_HASKELL__)
 
 -- Import the beggars
-import GHC.Exts
+import ExtsCompat46
 
 type FastInt = Int#
 
index c6b1e20..27b18d5 160000 (submodule)
@@ -1 +1 @@
-Subproject commit c6b1e204f0f2a1a0d6cb1df35fa60762b2fe3cdc
+Subproject commit 27b18d5bb12827e279f5cca541ae15508da6b6f7