Skip to content
This repository has been archived by the owner on Jun 14, 2018. It is now read-only.

Commit

Permalink
Restore old names of comparison primops
Browse files Browse the repository at this point in the history 
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.
  • Loading branch information
Jan Stolarek committed Sep 18, 2013
1 parent 6eec7bc commit 53948f9
Show file tree
Hide file tree
Showing 14 changed files with 420 additions and 129 deletions.
18 changes: 4 additions & 14 deletions aclocal.m4
View file
Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand Down
2 changes: 2 additions & 0 deletions compiler/ghc.cabal.in
View file
Expand Up @@ -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
Expand Down
3 changes: 1 addition & 2 deletions compiler/ghc.mk
View file
Expand Up @@ -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)))
Expand Down
2 changes: 1 addition & 1 deletion compiler/main/BreakArray.hs
View file
Expand Up @@ -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)
Expand Down
3 changes: 1 addition & 2 deletions compiler/prelude/PrelNames.lhs
View file
Expand Up @@ -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,
Expand All @@ -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")
Expand Down
86 changes: 43 additions & 43 deletions compiler/prelude/primops.txt.pp
View file
Expand Up @@ -134,25 +134,25 @@
#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
Expand Down Expand Up @@ -230,35 +230,35 @@

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#
Expand Down Expand Up @@ -345,12 +345,12 @@
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.}
Expand Down Expand Up @@ -435,26 +435,26 @@

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
Expand Down Expand Up @@ -562,37 +562,37 @@
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

Expand Down Expand Up @@ -1303,12 +1303,12 @@
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#
Expand Down
35 changes: 21 additions & 14 deletions compiler/simplCore/Simplify.lhs
View file
Expand Up @@ -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 )
Expand All @@ -23,23 +23,23 @@ 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 )
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
Expand Down Expand Up @@ -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
Expand All @@ -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)
Expand Down Expand Up @@ -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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Expand Down

0 comments on commit 53948f9

Please sign in to comment.