Commit 53948f91 authored by Jan Stolarek's avatar Jan Stolarek

Restore old names of comparison primops

In 6579a6c7 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.
parent 6eec7bc5
......@@ -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
......
......@@ -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
......
......@@ -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)))
......
......@@ -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)
......
......@@ -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")
......
......@@ -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#
......
......@@ -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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -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}
......
......@@ -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(..) )
......
......@@ -32,8 +32,7 @@ module Encoding (
import Foreign
import Data.Char
import Numeric
import GHC.Ptr ( Ptr(..) )
import GHC.Base
import ExtsCompat46
-- -----------------------------------------------------------------------------
-- UTF-8
......
{-# 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