diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/ghc.cabal.in | 2 | ||||
| -rw-r--r-- | compiler/ghc.mk | 3 | ||||
| -rw-r--r-- | compiler/main/BreakArray.hs | 2 | ||||
| -rw-r--r-- | compiler/prelude/PrelNames.lhs | 3 | ||||
| -rw-r--r-- | compiler/prelude/primops.txt.pp | 86 | ||||
| -rw-r--r-- | compiler/simplCore/Simplify.lhs | 35 | ||||
| -rw-r--r-- | compiler/typecheck/TcGenDeriv.lhs | 91 | ||||
| -rw-r--r-- | compiler/utils/Binary.hs | 2 | ||||
| -rw-r--r-- | compiler/utils/Encoding.hs | 3 | ||||
| -rw-r--r-- | compiler/utils/ExtsCompat46.hs | 292 | ||||
| -rw-r--r-- | compiler/utils/FastString.lhs | 8 | ||||
| -rw-r--r-- | compiler/utils/FastTypes.lhs | 2 |
12 files changed, 415 insertions, 114 deletions
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index f09cf640eb..a0f3e642f5 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -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 diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 15f953c66f..bf0ecaa65a 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -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))) diff --git a/compiler/main/BreakArray.hs b/compiler/main/BreakArray.hs index 4a8612da31..d16d6f229d 100644 --- a/compiler/main/BreakArray.hs +++ b/compiler/main/BreakArray.hs @@ -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) diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index dfb3f82b7b..728f4bcccf 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -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") diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index f9c4f1ba3a..cfd6afa4c6 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -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# diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index a88d943032..a0bd7f8edc 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 045978ffb9..b7a3f310be 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -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} diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index f02624533e..332bfc8e0c 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -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(..) ) diff --git a/compiler/utils/Encoding.hs b/compiler/utils/Encoding.hs index 6467377a1a..c4a669c134 100644 --- a/compiler/utils/Encoding.hs +++ b/compiler/utils/Encoding.hs @@ -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 index 0000000000..38f81aaa57 --- /dev/null +++ b/compiler/utils/ExtsCompat46.hs @@ -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 diff --git a/compiler/utils/FastString.lhs b/compiler/utils/FastString.lhs index 9f5ac37875..4c03cc7693 100644 --- a/compiler/utils/FastString.lhs +++ b/compiler/utils/FastString.lhs @@ -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# -- ----------------------------------------------------------------------------- diff --git a/compiler/utils/FastTypes.lhs b/compiler/utils/FastTypes.lhs index 1c67d5a1ef..0ef10ade56 100644 --- a/compiler/utils/FastTypes.lhs +++ b/compiler/utils/FastTypes.lhs @@ -65,7 +65,7 @@ module FastTypes ( #if defined(__GLASGOW_HASKELL__) -- Import the beggars -import GHC.Exts +import ExtsCompat46 type FastInt = Int# |