summaryrefslogtreecommitdiff
path: root/compiler/prelude
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/prelude')
-rw-r--r--compiler/prelude/ForeignCall.hs4
-rw-r--r--compiler/prelude/KnownUniques.hs11
-rw-r--r--compiler/prelude/KnownUniques.hs-boot1
-rw-r--r--compiler/prelude/PrelInfo.hs8
-rw-r--r--compiler/prelude/PrelNames.hs245
-rw-r--r--compiler/prelude/PrelNames.hs-boot3
-rw-r--r--compiler/prelude/PrelRules.hs873
-rw-r--r--compiler/prelude/PrimOp.hs4
-rw-r--r--compiler/prelude/PrimOp.hs-boot2
-rw-r--r--compiler/prelude/THNames.hs462
-rw-r--r--compiler/prelude/TysPrim.hs89
-rw-r--r--compiler/prelude/TysWiredIn.hs332
-rw-r--r--compiler/prelude/TysWiredIn.hs-boot2
-rw-r--r--compiler/prelude/primops.txt.pp505
14 files changed, 1709 insertions, 832 deletions
diff --git a/compiler/prelude/ForeignCall.hs b/compiler/prelude/ForeignCall.hs
index ff893ede02..c143b1ed1e 100644
--- a/compiler/prelude/ForeignCall.hs
+++ b/compiler/prelude/ForeignCall.hs
@@ -18,6 +18,8 @@ module ForeignCall (
Header(..), CType(..),
) where
+import GhcPrelude
+
import FastString
import Binary
import Outputable
@@ -196,7 +198,7 @@ instance Outputable CExportSpec where
instance Outputable CCallSpec where
ppr (CCallSpec fun cconv safety)
- = hcat [ ifPprDebug callconv, ppr_fun fun ]
+ = hcat [ whenPprDebug callconv, ppr_fun fun ]
where
callconv = text "{-" <> ppr cconv <> text "-}"
diff --git a/compiler/prelude/KnownUniques.hs b/compiler/prelude/KnownUniques.hs
index 8f1b0b6347..00085cad0b 100644
--- a/compiler/prelude/KnownUniques.hs
+++ b/compiler/prelude/KnownUniques.hs
@@ -26,6 +26,8 @@ module KnownUniques
#include "HsVersions.h"
+import GhcPrelude
+
import TysWiredIn
import TyCon
import DataCon
@@ -79,7 +81,8 @@ knownUniqueName u =
mkSumTyConUnique :: Arity -> Unique
mkSumTyConUnique arity =
- ASSERT(arity < 0xff)
+ ASSERT(arity < 0x3f) -- 0x3f since we only have 6 bits to encode the
+ -- alternative
mkUnique 'z' (arity `shiftL` 8 .|. 0xfc)
mkSumDataConUnique :: ConTagZ -> Arity -> Unique
@@ -98,16 +101,18 @@ getUnboxedSumName n
_ -> pprPanic "getUnboxedSumName: invalid tag" (ppr tag)
| tag == 0x0
= dataConName $ sumDataCon (alt + 1) arity
+ | tag == 0x1
+ = getName $ dataConWrapId $ sumDataCon (alt + 1) arity
| tag == 0x2
= getRep $ promoteDataCon $ sumDataCon (alt + 1) arity
| otherwise
= pprPanic "getUnboxedSumName" (ppr n)
where
arity = n `shiftR` 8
- alt = (n .&. 0xff) `shiftR` 2
+ alt = (n .&. 0xfc) `shiftR` 2
tag = 0x3 .&. n
getRep tycon =
- fromMaybe (pprPanic "getUnboxedSumName" (ppr tycon))
+ fromMaybe (pprPanic "getUnboxedSumName(getRep)" (ppr tycon))
$ tyConRepName_maybe tycon
-- Note [Uniques for tuple type and data constructors]
diff --git a/compiler/prelude/KnownUniques.hs-boot b/compiler/prelude/KnownUniques.hs-boot
index eeb478526d..b217c84aca 100644
--- a/compiler/prelude/KnownUniques.hs-boot
+++ b/compiler/prelude/KnownUniques.hs-boot
@@ -1,5 +1,6 @@
module KnownUniques where
+import GhcPrelude
import Unique
import Name
import BasicTypes
diff --git a/compiler/prelude/PrelInfo.hs b/compiler/prelude/PrelInfo.hs
index 47f41fbf73..a76a78adc9 100644
--- a/compiler/prelude/PrelInfo.hs
+++ b/compiler/prelude/PrelInfo.hs
@@ -46,6 +46,8 @@ module PrelInfo (
#include "HsVersions.h"
+import GhcPrelude
+
import KnownUniques
import Unique ( isValidKnownKeyUnique )
@@ -169,8 +171,8 @@ knownKeyNamesOkay all_names
| otherwise
= Just badNamesStr
where
- namesEnv = foldl (\m n -> extendNameEnv_Acc (:) singleton m n n)
- emptyUFM all_names
+ namesEnv = foldl' (\m n -> extendNameEnv_Acc (:) singleton m n n)
+ emptyUFM all_names
badNamesEnv = filterNameEnv (\ns -> ns `lengthExceeds` 1) namesEnv
badNamesPairs = nonDetUFMToList badNamesEnv
-- It's OK to use nonDetUFMToList here because the ordering only affects
@@ -250,7 +252,7 @@ ghcPrimExports
= map (avail . idName) ghcPrimIds ++
map (avail . idName . primOpId) allThePrimOps ++
[ AvailTC n [n] []
- | tc <- funTyCon : primTyCons, let n = tyConName tc ]
+ | tc <- funTyCon : exposedPrimTyCons, let n = tyConName tc ]
{-
************************************************************************
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 1f9f8f33df..d75ad47c6d 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -24,7 +24,7 @@ Nota Bene: all Names defined in here should come from the base package
One of these Names contains
(a) the module and occurrence name of the thing
(b) its Unique
- The may way the compiler "knows about" one of these things is
+ The way the compiler "knows about" one of these things is
where the type checker or desugarer needs to look it up. For
example, when desugaring list comprehensions the desugarer
needs to conjure up 'foldr'. It does this by looking up
@@ -83,7 +83,6 @@ This is accomplished through a combination of mechanisms:
Note [Infinite families of known-key names]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
Infinite families of known-key things (e.g. tuples and sums) pose a tricky
problem: we can't add them to the knownKeyNames finite map which we use to
ensure that, e.g., a reference to (,) gets assigned the right unique (if this
@@ -128,6 +127,8 @@ module PrelNames (
#include "HsVersions.h"
+import GhcPrelude
+
import Module
import OccName
import RdrName
@@ -183,7 +184,7 @@ names with uniques. These ones are the *non* wired-in ones. The
wired in ones are defined in TysWiredIn etc.
-}
-basicKnownKeyNames :: [Name]
+basicKnownKeyNames :: [Name] -- See Note [Known-key names]
basicKnownKeyNames
= genericTyConNames
++ [ -- Classes. *Must* include:
@@ -215,6 +216,7 @@ basicKnownKeyNames
-- See Note [TyConRepNames for non-wired-in TyCons]
ioTyConName, ioDataConName,
runMainIOName,
+ runRWName,
-- Type representation types
trModuleTyConName, trModuleDataConName,
@@ -238,6 +240,7 @@ basicKnownKeyNames
typeLitSymbolDataConName,
typeLitNatDataConName,
typeRepIdName,
+ mkTrTypeName,
mkTrConName,
mkTrAppName,
mkTrFunName,
@@ -330,8 +333,9 @@ basicKnownKeyNames
otherwiseIdName, inlineIdName,
eqStringName, assertName, breakpointName, breakpointCondName,
breakpointAutoName, opaqueTyConName,
- assertErrorName,
+ assertErrorName, traceName,
printName, fstName, sndName,
+ dollarName,
-- Integer
integerTyConName, mkIntegerName,
@@ -354,7 +358,9 @@ basicKnownKeyNames
-- Natural
naturalTyConName,
- naturalFromIntegerName,
+ naturalFromIntegerName, naturalToIntegerName,
+ plusNaturalName, minusNaturalName, timesNaturalName, mkNaturalName,
+ wordToNaturalName,
-- Float/Double
rationalToFloatName,
@@ -387,7 +393,7 @@ basicKnownKeyNames
-- The Ordering type
, orderingTyConName
- , ltDataConName, eqDataConName, gtDataConName
+ , ordLTDataConName, ordEQDataConName, ordGTDataConName
-- The SPEC type for SpecConstr
, specTyConName
@@ -427,11 +433,8 @@ basicKnownKeyNames
, typeErrorVAppendDataConName
, typeErrorShowTypeDataConName
- -- homogeneous equality
- , eqTyConName
-
] ++ case cIntegerLibraryType of
- IntegerGMP -> [integerSDataConName]
+ IntegerGMP -> [integerSDataConName,naturalSDataConName]
IntegerSimple -> []
genericTyConNames :: [Name]
@@ -469,9 +472,9 @@ pRELUDE = mkBaseModule_ pRELUDE_NAME
gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING,
- gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER_TYPE, gHC_NATURAL, gHC_LIST,
- gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING,
- dATA_FOLDABLE, dATA_TRAVERSABLE, dATA_MONOID, dATA_SEMIGROUP,
+ gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE, gHC_INTEGER_TYPE, gHC_NATURAL,
+ gHC_LIST, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING,
+ dATA_FOLDABLE, dATA_TRAVERSABLE,
gHC_CONC, gHC_IO, gHC_IO_Exception,
gHC_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,
gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC,
@@ -479,7 +482,7 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP, mONAD_FAIL,
aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS,
cONTROL_EXCEPTION_BASE, gHC_TYPELITS, gHC_TYPENATS, dATA_TYPE_EQUALITY,
- dATA_COERCE :: Module
+ dATA_COERCE, dEBUG_TRACE :: Module
gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values
gHC_TYPES = mkPrimModule (fsLit "GHC.Types")
@@ -493,6 +496,7 @@ gHC_GHCI = mkBaseModule (fsLit "GHC.GHCi")
gHC_SHOW = mkBaseModule (fsLit "GHC.Show")
gHC_READ = mkBaseModule (fsLit "GHC.Read")
gHC_NUM = mkBaseModule (fsLit "GHC.Num")
+gHC_MAYBE = mkBaseModule (fsLit "GHC.Maybe")
gHC_INTEGER_TYPE= mkIntegerModule (fsLit "GHC.Integer.Type")
gHC_NATURAL = mkBaseModule (fsLit "GHC.Natural")
gHC_LIST = mkBaseModule (fsLit "GHC.List")
@@ -502,8 +506,6 @@ dATA_EITHER = mkBaseModule (fsLit "Data.Either")
dATA_STRING = mkBaseModule (fsLit "Data.String")
dATA_FOLDABLE = mkBaseModule (fsLit "Data.Foldable")
dATA_TRAVERSABLE= mkBaseModule (fsLit "Data.Traversable")
-dATA_SEMIGROUP = mkBaseModule (fsLit "Data.Semigroup")
-dATA_MONOID = mkBaseModule (fsLit "Data.Monoid")
gHC_CONC = mkBaseModule (fsLit "GHC.Conc")
gHC_IO = mkBaseModule (fsLit "GHC.IO")
gHC_IO_Exception = mkBaseModule (fsLit "GHC.IO.Exception")
@@ -539,9 +541,7 @@ gHC_TYPELITS = mkBaseModule (fsLit "GHC.TypeLits")
gHC_TYPENATS = mkBaseModule (fsLit "GHC.TypeNats")
dATA_TYPE_EQUALITY = mkBaseModule (fsLit "Data.Type.Equality")
dATA_COERCE = mkBaseModule (fsLit "Data.Coerce")
-
-gHC_PARR' :: Module
-gHC_PARR' = mkBaseModule (fsLit "GHC.PArr")
+dEBUG_TRACE = mkBaseModule (fsLit "Debug.Trace")
gHC_SRCLOC :: Module
gHC_SRCLOC = mkBaseModule (fsLit "GHC.SrcLoc")
@@ -630,9 +630,9 @@ le_RDR = varQual_RDR gHC_CLASSES (fsLit "<=")
lt_RDR = varQual_RDR gHC_CLASSES (fsLit "<")
gt_RDR = varQual_RDR gHC_CLASSES (fsLit ">")
compare_RDR = varQual_RDR gHC_CLASSES (fsLit "compare")
-ltTag_RDR = dataQual_RDR gHC_TYPES (fsLit "LT")
-eqTag_RDR = dataQual_RDR gHC_TYPES (fsLit "EQ")
-gtTag_RDR = dataQual_RDR gHC_TYPES (fsLit "GT")
+ltTag_RDR = nameRdrName ordLTDataConName
+eqTag_RDR = nameRdrName ordEQDataConName
+gtTag_RDR = nameRdrName ordGTDataConName
eqClass_RDR, numClass_RDR, ordClass_RDR, enumClass_RDR, monadClass_RDR
:: RdrName
@@ -643,10 +643,11 @@ enumClass_RDR = nameRdrName enumClassName
monadClass_RDR = nameRdrName monadClassName
map_RDR, append_RDR :: RdrName
-map_RDR = varQual_RDR gHC_BASE (fsLit "map")
-append_RDR = varQual_RDR gHC_BASE (fsLit "++")
+map_RDR = nameRdrName mapName
+append_RDR = nameRdrName appendName
-foldr_RDR, build_RDR, returnM_RDR, bindM_RDR, failM_RDR_preMFP, failM_RDR:: RdrName
+foldr_RDR, build_RDR, returnM_RDR, bindM_RDR, failM_RDR_preMFP,
+ failM_RDR :: RdrName
foldr_RDR = nameRdrName foldrName
build_RDR = nameRdrName buildName
returnM_RDR = nameRdrName returnMName
@@ -742,6 +743,11 @@ choose_RDR = varQual_RDR gHC_READ (fsLit "choose")
lexP_RDR = varQual_RDR gHC_READ (fsLit "lexP")
expectP_RDR = varQual_RDR gHC_READ (fsLit "expectP")
+readField_RDR, readFieldHash_RDR, readSymField_RDR :: RdrName
+readField_RDR = varQual_RDR gHC_READ (fsLit "readField")
+readFieldHash_RDR = varQual_RDR gHC_READ (fsLit "readFieldHash")
+readSymField_RDR = varQual_RDR gHC_READ (fsLit "readSymField")
+
punc_RDR, ident_RDR, symbol_RDR :: RdrName
punc_RDR = dataQual_RDR lEX (fsLit "Punc")
ident_RDR = dataQual_RDR lEX (fsLit "Ident")
@@ -817,9 +823,9 @@ conIsRecord_RDR = varQual_RDR gHC_GENERICS (fsLit "conIsRecord")
prefixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Prefix")
infixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Infix")
-leftAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "LeftAssociative")
-rightAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "RightAssociative")
-notAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "NotAssociative")
+leftAssocDataCon_RDR = nameRdrName leftAssociativeDataConName
+rightAssocDataCon_RDR = nameRdrName rightAssociativeDataConName
+notAssocDataCon_RDR = nameRdrName notAssociativeDataConName
uAddrDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UAddr")
uCharDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UChar")
@@ -838,7 +844,7 @@ uWordHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uWord#")
fmap_RDR, replace_RDR, pure_RDR, ap_RDR, liftA2_RDR, foldable_foldr_RDR,
foldMap_RDR, null_RDR, all_RDR, traverse_RDR, mempty_RDR,
mappend_RDR :: RdrName
-fmap_RDR = varQual_RDR gHC_BASE (fsLit "fmap")
+fmap_RDR = nameRdrName fmapName
replace_RDR = varQual_RDR gHC_BASE (fsLit "<$")
pure_RDR = nameRdrName pureAName
ap_RDR = nameRdrName apAName
@@ -848,11 +854,8 @@ foldMap_RDR = varQual_RDR dATA_FOLDABLE (fsLit "foldMap")
null_RDR = varQual_RDR dATA_FOLDABLE (fsLit "null")
all_RDR = varQual_RDR dATA_FOLDABLE (fsLit "all")
traverse_RDR = varQual_RDR dATA_TRAVERSABLE (fsLit "traverse")
-mempty_RDR = varQual_RDR gHC_BASE (fsLit "mempty")
-mappend_RDR = varQual_RDR gHC_BASE (fsLit "mappend")
-
-eqTyCon_RDR :: RdrName
-eqTyCon_RDR = tcQual_RDR dATA_TYPE_EQUALITY (fsLit "~")
+mempty_RDR = nameRdrName memptyName
+mappend_RDR = nameRdrName mappendName
----------------------
varQual_RDR, tcQual_RDR, clsQual_RDR, dataQual_RDR
@@ -872,22 +875,20 @@ dataQual_RDR mod str = mkOrig mod (mkOccNameFS dataName str)
Many of these Names are not really "built in", but some parts of the
compiler (notably the deriving mechanism) need to mention their names,
and it's convenient to write them all down in one place.
-
---MetaHaskell Extension add the constrs and the lower case case
--- guys as well (perhaps) e.g. see trueDataConName below
-}
wildCardName :: Name
wildCardName = mkSystemVarName wildCardKey (fsLit "wild")
-runMainIOName :: Name
+runMainIOName, runRWName :: Name
runMainIOName = varQual gHC_TOP_HANDLER (fsLit "runMainIO") runMainKey
+runRWName = varQual gHC_MAGIC (fsLit "runRW#") runRWKey
-orderingTyConName, ltDataConName, eqDataConName, gtDataConName :: Name
+orderingTyConName, ordLTDataConName, ordEQDataConName, ordGTDataConName :: Name
orderingTyConName = tcQual gHC_TYPES (fsLit "Ordering") orderingTyConKey
-ltDataConName = dcQual gHC_TYPES (fsLit "LT") ltDataConKey
-eqDataConName = dcQual gHC_TYPES (fsLit "EQ") eqDataConKey
-gtDataConName = dcQual gHC_TYPES (fsLit "GT") gtDataConKey
+ordLTDataConName = dcQual gHC_TYPES (fsLit "LT") ordLTDataConKey
+ordEQDataConName = dcQual gHC_TYPES (fsLit "EQ") ordEQDataConKey
+ordGTDataConName = dcQual gHC_TYPES (fsLit "GT") ordGTDataConKey
specTyConName :: Name
specTyConName = tcQual gHC_TYPES (fsLit "SPEC") specTyConKey
@@ -1020,8 +1021,8 @@ traversableClassName = clsQual dATA_TRAVERSABLE (fsLit "Traversable") trave
-- Classes (Semigroup, Monoid)
semigroupClassName, sappendName :: Name
-semigroupClassName = clsQual dATA_SEMIGROUP (fsLit "Semigroup") semigroupClassKey
-sappendName = varQual dATA_SEMIGROUP (fsLit "<>") sappendClassOpKey
+semigroupClassName = clsQual gHC_BASE (fsLit "Semigroup") semigroupClassKey
+sappendName = varQual gHC_BASE (fsLit "<>") sappendClassOpKey
monoidClassName, memptyName, mappendName, mconcatName :: Name
monoidClassName = clsQual gHC_BASE (fsLit "Monoid") monoidClassKey
memptyName = varQual gHC_BASE (fsLit "mempty") memptyClassOpKey
@@ -1054,8 +1055,8 @@ groupWithName = varQual gHC_EXTS (fsLit "groupWith") groupWithIdKey
fromStringName, otherwiseIdName, foldrName, buildName, augmentName,
mapName, appendName, assertName,
breakpointName, breakpointCondName, breakpointAutoName,
- opaqueTyConName :: Name
-fromStringName = varQual dATA_STRING (fsLit "fromString") fromStringClassOpKey
+ opaqueTyConName, dollarName :: Name
+dollarName = varQual gHC_BASE (fsLit "$") dollarIdKey
otherwiseIdName = varQual gHC_BASE (fsLit "otherwise") otherwiseIdKey
foldrName = varQual gHC_BASE (fsLit "foldr") foldrIdKey
buildName = varQual gHC_BASE (fsLit "build") buildIdKey
@@ -1067,6 +1068,7 @@ breakpointName = varQual gHC_BASE (fsLit "breakpoint") breakpointIdKey
breakpointCondName= varQual gHC_BASE (fsLit "breakpointCond") breakpointCondIdKey
breakpointAutoName= varQual gHC_BASE (fsLit "breakpointAuto") breakpointAutoIdKey
opaqueTyConName = tcQual gHC_BASE (fsLit "Opaque") opaqueTyConKey
+fromStringName = varQual dATA_STRING (fsLit "fromString") fromStringClassOpKey
breakpointJumpName :: Name
breakpointJumpName
@@ -1117,7 +1119,7 @@ integerTyConName, mkIntegerName, integerSDataConName,
andIntegerName, orIntegerName, xorIntegerName, complementIntegerName,
shiftLIntegerName, shiftRIntegerName, bitIntegerName :: Name
integerTyConName = tcQual gHC_INTEGER_TYPE (fsLit "Integer") integerTyConKey
-integerSDataConName = dcQual gHC_INTEGER_TYPE (fsLit n) integerSDataConKey
+integerSDataConName = dcQual gHC_INTEGER_TYPE (fsLit n) integerSDataConKey
where n = case cIntegerLibraryType of
IntegerGMP -> "S#"
IntegerSimple -> panic "integerSDataConName evaluated for integer-simple"
@@ -1165,12 +1167,25 @@ shiftRIntegerName = varQual gHC_INTEGER_TYPE (fsLit "shiftRInteger") shi
bitIntegerName = varQual gHC_INTEGER_TYPE (fsLit "bitInteger") bitIntegerIdKey
-- GHC.Natural types
-naturalTyConName :: Name
+naturalTyConName, naturalSDataConName :: Name
naturalTyConName = tcQual gHC_NATURAL (fsLit "Natural") naturalTyConKey
+naturalSDataConName = dcQual gHC_NATURAL (fsLit n) naturalSDataConKey
+ where n = case cIntegerLibraryType of
+ IntegerGMP -> "NatS#"
+ IntegerSimple -> panic "naturalSDataConName evaluated for integer-simple"
naturalFromIntegerName :: Name
naturalFromIntegerName = varQual gHC_NATURAL (fsLit "naturalFromInteger") naturalFromIntegerIdKey
+naturalToIntegerName, plusNaturalName, minusNaturalName, timesNaturalName,
+ mkNaturalName, wordToNaturalName :: Name
+naturalToIntegerName = varQual gHC_NATURAL (fsLit "naturalToInteger") naturalToIntegerIdKey
+plusNaturalName = varQual gHC_NATURAL (fsLit "plusNatural") plusNaturalIdKey
+minusNaturalName = varQual gHC_NATURAL (fsLit "minusNatural") minusNaturalIdKey
+timesNaturalName = varQual gHC_NATURAL (fsLit "timesNatural") timesNaturalIdKey
+mkNaturalName = varQual gHC_NATURAL (fsLit "mkNatural") mkNaturalIdKey
+wordToNaturalName = varQual gHC_NATURAL (fsLit "wordToNatural#") wordToNaturalIdKey
+
-- GHC.Real types and classes
rationalTyConName, ratioTyConName, ratioDataConName, realClassName,
integralClassName, realFracClassName, fractionalClassName,
@@ -1251,6 +1266,7 @@ typeableClassName
, typeRepTyConName
, someTypeRepTyConName
, someTypeRepDataConName
+ , mkTrTypeName
, mkTrConName
, mkTrAppName
, mkTrFunName
@@ -1264,6 +1280,7 @@ typeRepTyConName = tcQual tYPEABLE_INTERNAL (fsLit "TypeRep") typeR
someTypeRepTyConName = tcQual tYPEABLE_INTERNAL (fsLit "SomeTypeRep") someTypeRepTyConKey
someTypeRepDataConName = dcQual tYPEABLE_INTERNAL (fsLit "SomeTypeRep") someTypeRepDataConKey
typeRepIdName = varQual tYPEABLE_INTERNAL (fsLit "typeRep#") typeRepIdKey
+mkTrTypeName = varQual tYPEABLE_INTERNAL (fsLit "mkTrType") mkTrTypeKey
mkTrConName = varQual tYPEABLE_INTERNAL (fsLit "mkTrCon") mkTrConKey
mkTrAppName = varQual tYPEABLE_INTERNAL (fsLit "mkTrApp") mkTrAppKey
mkTrFunName = varQual tYPEABLE_INTERNAL (fsLit "mkTrFun") mkTrFunKey
@@ -1316,6 +1333,10 @@ dataClassName = clsQual gENERICS (fsLit "Data") dataClassKey
assertErrorName :: Name
assertErrorName = varQual gHC_IO_Exception (fsLit "assertError") assertErrorIdKey
+-- Debug.Trace
+traceName :: Name
+traceName = varQual dEBUG_TRACE (fsLit "trace") traceKey
+
-- Enum module (Enum, Bounded)
enumClassName, enumFromName, enumFromToName, enumFromThenName,
enumFromThenToName, boundedClassName :: Name
@@ -1505,10 +1526,6 @@ fingerprintDataConName :: Name
fingerprintDataConName =
dcQual gHC_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey
--- homogeneous equality. See Note [The equality types story] in TysPrim
-eqTyConName :: Name
-eqTyConName = tcQual dATA_TYPE_EQUALITY (fsLit "~") eqTyConKey
-
{-
************************************************************************
* *
@@ -1731,10 +1748,6 @@ funPtrTyConKey = mkPreludeTyConUnique 76
tVarPrimTyConKey = mkPreludeTyConUnique 77
compactPrimTyConKey = mkPreludeTyConUnique 78
--- Parallel array type constructor
-parrTyConKey :: Unique
-parrTyConKey = mkPreludeTyConUnique 82
-
-- dotnet interop
objectTyConKey :: Unique
objectTyConKey = mkPreludeTyConUnique 83
@@ -1744,14 +1757,11 @@ eitherTyConKey = mkPreludeTyConUnique 84
-- Kind constructors
liftedTypeKindTyConKey, tYPETyConKey,
- constraintKindTyConKey,
- starKindTyConKey, unicodeStarKindTyConKey, runtimeRepTyConKey,
+ constraintKindTyConKey, runtimeRepTyConKey,
vecCountTyConKey, vecElemTyConKey :: Unique
liftedTypeKindTyConKey = mkPreludeTyConUnique 87
tYPETyConKey = mkPreludeTyConUnique 88
constraintKindTyConKey = mkPreludeTyConUnique 92
-starKindTyConKey = mkPreludeTyConUnique 93
-unicodeStarKindTyConKey = mkPreludeTyConUnique 94
runtimeRepTyConKey = mkPreludeTyConUnique 95
vecCountTyConKey = mkPreludeTyConUnique 96
vecElemTyConKey = mkPreludeTyConUnique 97
@@ -1816,6 +1826,9 @@ typeNatKindConNameKey, typeSymbolKindConNameKey,
typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey,
typeNatLeqTyFamNameKey, typeNatSubTyFamNameKey
, typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey
+ , typeNatDivTyFamNameKey
+ , typeNatModTyFamNameKey
+ , typeNatLogTyFamNameKey
:: Unique
typeNatKindConNameKey = mkPreludeTyConUnique 164
typeSymbolKindConNameKey = mkPreludeTyConUnique 165
@@ -1826,48 +1839,51 @@ typeNatLeqTyFamNameKey = mkPreludeTyConUnique 169
typeNatSubTyFamNameKey = mkPreludeTyConUnique 170
typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 171
typeNatCmpTyFamNameKey = mkPreludeTyConUnique 172
+typeNatDivTyFamNameKey = mkPreludeTyConUnique 173
+typeNatModTyFamNameKey = mkPreludeTyConUnique 174
+typeNatLogTyFamNameKey = mkPreludeTyConUnique 175
-- Custom user type-errors
errorMessageTypeErrorFamKey :: Unique
-errorMessageTypeErrorFamKey = mkPreludeTyConUnique 173
+errorMessageTypeErrorFamKey = mkPreludeTyConUnique 176
ntTyConKey:: Unique
-ntTyConKey = mkPreludeTyConUnique 174
+ntTyConKey = mkPreludeTyConUnique 177
coercibleTyConKey :: Unique
-coercibleTyConKey = mkPreludeTyConUnique 175
+coercibleTyConKey = mkPreludeTyConUnique 178
proxyPrimTyConKey :: Unique
-proxyPrimTyConKey = mkPreludeTyConUnique 176
+proxyPrimTyConKey = mkPreludeTyConUnique 179
specTyConKey :: Unique
-specTyConKey = mkPreludeTyConUnique 177
+specTyConKey = mkPreludeTyConUnique 180
anyTyConKey :: Unique
-anyTyConKey = mkPreludeTyConUnique 178
+anyTyConKey = mkPreludeTyConUnique 181
-smallArrayPrimTyConKey = mkPreludeTyConUnique 179
-smallMutableArrayPrimTyConKey = mkPreludeTyConUnique 180
+smallArrayPrimTyConKey = mkPreludeTyConUnique 182
+smallMutableArrayPrimTyConKey = mkPreludeTyConUnique 183
staticPtrTyConKey :: Unique
-staticPtrTyConKey = mkPreludeTyConUnique 181
+staticPtrTyConKey = mkPreludeTyConUnique 184
staticPtrInfoTyConKey :: Unique
-staticPtrInfoTyConKey = mkPreludeTyConUnique 182
+staticPtrInfoTyConKey = mkPreludeTyConUnique 185
callStackTyConKey :: Unique
-callStackTyConKey = mkPreludeTyConUnique 183
+callStackTyConKey = mkPreludeTyConUnique 186
-- Typeables
typeRepTyConKey, someTypeRepTyConKey, someTypeRepDataConKey :: Unique
-typeRepTyConKey = mkPreludeTyConUnique 184
-someTypeRepTyConKey = mkPreludeTyConUnique 185
-someTypeRepDataConKey = mkPreludeTyConUnique 186
+typeRepTyConKey = mkPreludeTyConUnique 187
+someTypeRepTyConKey = mkPreludeTyConUnique 188
+someTypeRepDataConKey = mkPreludeTyConUnique 189
typeSymbolAppendFamNameKey :: Unique
-typeSymbolAppendFamNameKey = mkPreludeTyConUnique 187
+typeSymbolAppendFamNameKey = mkPreludeTyConUnique 190
---------------- Template Haskell -------------------
-- THNames.hs: USES TyConUniques 200-299
@@ -1891,7 +1907,7 @@ charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey,
floatDataConKey, intDataConKey, integerSDataConKey, nilDataConKey,
ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey,
word8DataConKey, ioDataConKey, integerDataConKey, heqDataConKey,
- coercibleDataConKey, nothingDataConKey, justDataConKey :: Unique
+ coercibleDataConKey, eqDataConKey, nothingDataConKey, justDataConKey :: Unique
charDataConKey = mkPreludeDataConUnique 1
consDataConKey = mkPreludeDataConUnique 2
@@ -1902,6 +1918,7 @@ intDataConKey = mkPreludeDataConUnique 6
integerSDataConKey = mkPreludeDataConUnique 7
nothingDataConKey = mkPreludeDataConUnique 8
justDataConKey = mkPreludeDataConUnique 9
+eqDataConKey = mkPreludeDataConUnique 10
nilDataConKey = mkPreludeDataConUnique 11
ratioDataConKey = mkPreludeDataConUnique 12
word8DataConKey = mkPreludeDataConUnique 13
@@ -1919,18 +1936,15 @@ inlDataConKey = mkPreludeDataConUnique 21
inrDataConKey = mkPreludeDataConUnique 22
genUnitDataConKey = mkPreludeDataConUnique 23
--- Data constructor for parallel arrays
-parrDataConKey :: Unique
-parrDataConKey = mkPreludeDataConUnique 24
-
leftDataConKey, rightDataConKey :: Unique
leftDataConKey = mkPreludeDataConUnique 25
rightDataConKey = mkPreludeDataConUnique 26
-ltDataConKey, eqDataConKey, gtDataConKey :: Unique
-ltDataConKey = mkPreludeDataConUnique 27
-eqDataConKey = mkPreludeDataConUnique 28
-gtDataConKey = mkPreludeDataConUnique 29
+ordLTDataConKey, ordEQDataConKey, ordGTDataConKey :: Unique
+ordLTDataConKey = mkPreludeDataConUnique 27
+ordEQDataConKey = mkPreludeDataConUnique 28
+ordGTDataConKey = mkPreludeDataConUnique 29
+
coercibleDataConKey = mkPreludeDataConUnique 32
@@ -2003,12 +2017,16 @@ tupleRepDataConKey = mkPreludeDataConUnique 72
sumRepDataConKey = mkPreludeDataConUnique 73
-- See Note [Wiring in RuntimeRep] in TysWiredIn
-runtimeRepSimpleDataConKeys :: [Unique]
+runtimeRepSimpleDataConKeys, unliftedSimpleRepDataConKeys, unliftedRepDataConKeys :: [Unique]
liftedRepDataConKey :: Unique
-runtimeRepSimpleDataConKeys@(
- liftedRepDataConKey : _)
+runtimeRepSimpleDataConKeys@(liftedRepDataConKey : unliftedSimpleRepDataConKeys)
= map mkPreludeDataConUnique [74..82]
+unliftedRepDataConKeys = vecRepDataConKey :
+ tupleRepDataConKey :
+ sumRepDataConKey :
+ unliftedSimpleRepDataConKeys
+
-- See Note [Wiring in RuntimeRep] in TysWiredIn
-- VecCount
vecCountDataConKeys :: [Unique]
@@ -2052,13 +2070,14 @@ typeLitNatDataConKey = mkPreludeDataConUnique 108
wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey,
buildIdKey, errorIdKey, foldrIdKey, recSelErrorIdKey,
- seqIdKey, irrefutPatErrorIdKey, eqStringIdKey,
+ seqIdKey, eqStringIdKey,
noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey,
runtimeErrorIdKey, patErrorIdKey, voidPrimIdKey,
realWorldPrimIdKey, recConErrorIdKey,
unpackCStringUtf8IdKey, unpackCStringAppendIdKey,
unpackCStringFoldrIdKey, unpackCStringIdKey,
- typeErrorIdKey, divIntIdKey, modIntIdKey :: Unique
+ typeErrorIdKey, divIntIdKey, modIntIdKey,
+ absentSumFieldErrorIdKey :: Unique
wildCardKey = mkPreludeMiscIdUnique 0 -- See Note [WildCard binders]
absentErrorIdKey = mkPreludeMiscIdUnique 1
@@ -2069,7 +2088,6 @@ errorIdKey = mkPreludeMiscIdUnique 5
foldrIdKey = mkPreludeMiscIdUnique 6
recSelErrorIdKey = mkPreludeMiscIdUnique 7
seqIdKey = mkPreludeMiscIdUnique 8
-irrefutPatErrorIdKey = mkPreludeMiscIdUnique 9
eqStringIdKey = mkPreludeMiscIdUnique 10
noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 11
nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 12
@@ -2085,6 +2103,7 @@ voidPrimIdKey = mkPreludeMiscIdUnique 21
typeErrorIdKey = mkPreludeMiscIdUnique 22
divIntIdKey = mkPreludeMiscIdUnique 23
modIntIdKey = mkPreludeMiscIdUnique 24
+absentSumFieldErrorIdKey = mkPreludeMiscIdUnique 9
unsafeCoerceIdKey, concatIdKey, filterIdKey, zipIdKey, bindIOIdKey,
returnIOIdKey, newStablePtrIdKey,
@@ -2175,6 +2194,9 @@ assertErrorIdKey = mkPreludeMiscIdUnique 105
oneShotKey = mkPreludeMiscIdUnique 106
runRWKey = mkPreludeMiscIdUnique 107
+traceKey :: Unique
+traceKey = mkPreludeMiscIdUnique 108
+
breakpointIdKey, breakpointCondIdKey, breakpointAutoIdKey,
breakpointJumpIdKey, breakpointCondJumpIdKey,
breakpointAutoJumpIdKey :: Unique
@@ -2311,6 +2333,7 @@ proxyHashKey = mkPreludeMiscIdUnique 502
-- Used to make `Typeable` dictionaries
mkTyConKey
+ , mkTrTypeKey
, mkTrConKey
, mkTrAppKey
, mkTrFunKey
@@ -2319,12 +2342,13 @@ mkTyConKey
, typeRepIdKey
:: Unique
mkTyConKey = mkPreludeMiscIdUnique 503
-mkTrConKey = mkPreludeMiscIdUnique 504
-mkTrAppKey = mkPreludeMiscIdUnique 505
-typeNatTypeRepKey = mkPreludeMiscIdUnique 506
-typeSymbolTypeRepKey = mkPreludeMiscIdUnique 507
-typeRepIdKey = mkPreludeMiscIdUnique 508
-mkTrFunKey = mkPreludeMiscIdUnique 509
+mkTrTypeKey = mkPreludeMiscIdUnique 504
+mkTrConKey = mkPreludeMiscIdUnique 505
+mkTrAppKey = mkPreludeMiscIdUnique 506
+typeNatTypeRepKey = mkPreludeMiscIdUnique 507
+typeSymbolTypeRepKey = mkPreludeMiscIdUnique 508
+typeRepIdKey = mkPreludeMiscIdUnique 509
+mkTrFunKey = mkPreludeMiscIdUnique 510
-- Representations for primitive types
trTYPEKey
@@ -2332,10 +2356,10 @@ trTYPEKey
, trRuntimeRepKey
, tr'PtrRepLiftedKey
:: Unique
-trTYPEKey = mkPreludeMiscIdUnique 510
-trTYPE'PtrRepLiftedKey = mkPreludeMiscIdUnique 511
-trRuntimeRepKey = mkPreludeMiscIdUnique 512
-tr'PtrRepLiftedKey = mkPreludeMiscIdUnique 513
+trTYPEKey = mkPreludeMiscIdUnique 511
+trTYPE'PtrRepLiftedKey = mkPreludeMiscIdUnique 512
+trRuntimeRepKey = mkPreludeMiscIdUnique 513
+tr'PtrRepLiftedKey = mkPreludeMiscIdUnique 514
-- KindReps for common cases
starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey :: Unique
@@ -2345,12 +2369,14 @@ starArrStarArrStarKindRepKey = mkPreludeMiscIdUnique 522
-- Dynamic
toDynIdKey :: Unique
-toDynIdKey = mkPreludeMiscIdUnique 550
+toDynIdKey = mkPreludeMiscIdUnique 523
+
bitIntegerIdKey :: Unique
-bitIntegerIdKey = mkPreludeMiscIdUnique 551
+bitIntegerIdKey = mkPreludeMiscIdUnique 550
-heqSCSelIdKey, coercibleSCSelIdKey :: Unique
+heqSCSelIdKey, eqSCSelIdKey, coercibleSCSelIdKey :: Unique
+eqSCSelIdKey = mkPreludeMiscIdUnique 551
heqSCSelIdKey = mkPreludeMiscIdUnique 552
coercibleSCSelIdKey = mkPreludeMiscIdUnique 553
@@ -2373,8 +2399,17 @@ makeStaticKey :: Unique
makeStaticKey = mkPreludeMiscIdUnique 561
-- Natural
-naturalFromIntegerIdKey :: Unique
+naturalFromIntegerIdKey, naturalToIntegerIdKey, plusNaturalIdKey,
+ minusNaturalIdKey, timesNaturalIdKey, mkNaturalIdKey,
+ naturalSDataConKey, wordToNaturalIdKey :: Unique
naturalFromIntegerIdKey = mkPreludeMiscIdUnique 562
+naturalToIntegerIdKey = mkPreludeMiscIdUnique 563
+plusNaturalIdKey = mkPreludeMiscIdUnique 564
+minusNaturalIdKey = mkPreludeMiscIdUnique 565
+timesNaturalIdKey = mkPreludeMiscIdUnique 566
+mkNaturalIdKey = mkPreludeMiscIdUnique 567
+naturalSDataConKey = mkPreludeMiscIdUnique 568
+wordToNaturalIdKey = mkPreludeMiscIdUnique 569
{-
************************************************************************
@@ -2453,5 +2488,5 @@ The following names should be considered by GHCi to be in scope always.
pretendNameIsInScope :: Name -> Bool
pretendNameIsInScope n
= any (n `hasKey`)
- [ starKindTyConKey, liftedTypeKindTyConKey, tYPETyConKey
+ [ liftedTypeKindTyConKey, tYPETyConKey
, runtimeRepTyConKey, liftedRepDataConKey ]
diff --git a/compiler/prelude/PrelNames.hs-boot b/compiler/prelude/PrelNames.hs-boot
index e25c83618f..0bd74d5577 100644
--- a/compiler/prelude/PrelNames.hs-boot
+++ b/compiler/prelude/PrelNames.hs-boot
@@ -4,5 +4,4 @@ import Module
import Unique
mAIN :: Module
-starKindTyConKey :: Unique
-unicodeStarKindTyConKey :: Unique
+liftedTypeKindTyConKey :: Unique
diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs
index 1ef0565ff3..80cfa20ba3 100644
--- a/compiler/prelude/PrelRules.hs
+++ b/compiler/prelude/PrelRules.hs
@@ -12,7 +12,7 @@ ToDo:
(i1 + i2) only if it results in a valid Float.
-}
-{-# LANGUAGE CPP, RankNTypes #-}
+{-# LANGUAGE CPP, RankNTypes, PatternSynonyms, ViewPatterns, RecordWildCards #-}
{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
module PrelRules
@@ -25,6 +25,8 @@ where
#include "HsVersions.h"
#include "../includes/MachDeps.h"
+import GhcPrelude
+
import {-# SOURCE #-} MkId ( mkPrimOpId, magicDictId )
import CoreSyn
@@ -35,10 +37,11 @@ import CoreOpt ( exprIsLiteral_maybe )
import PrimOp ( PrimOp(..), tagToEnumKey )
import TysWiredIn
import TysPrim
-import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon
- , unwrapNewTyCon_maybe, tyConDataCons )
-import DataCon ( DataCon, dataConTagZ, dataConTyCon, dataConWorkId )
-import CoreUtils ( cheapEqExpr, exprIsHNF )
+import TyCon ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon
+ , isNewTyCon, unwrapNewTyCon_maybe, tyConDataCons
+ , tyConFamilySize )
+import DataCon ( dataConTagZ, dataConTyCon, dataConWorkId )
+import CoreUtils ( cheapEqExpr, exprIsHNF, exprType )
import CoreUnfold ( exprIsConApp_maybe )
import Type
import OccName ( occNameFS )
@@ -56,9 +59,7 @@ import Coercion (mkUnbranchedAxInstCo,mkSymCo,Role(..))
import Control.Applicative ( Alternative(..) )
import Control.Monad
-#if __GLASGOW_HASKELL__ > 710
import qualified Control.Monad.Fail as MonadFail
-#endif
import Data.Bits as Bits
import qualified Data.ByteString as BS
import Data.Int
@@ -90,13 +91,24 @@ primOpRules nm DataToTagOp = mkPrimOpRule nm 2 [ dataToTagRule ]
-- Int operations
primOpRules nm IntAddOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (+))
- , identityDynFlags zeroi ]
+ , identityDynFlags zeroi
+ , numFoldingRules IntAddOp intPrimOps
+ ]
primOpRules nm IntSubOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (-))
, rightIdentityDynFlags zeroi
- , equalArgs >> retLit zeroi ]
+ , equalArgs >> retLit zeroi
+ , numFoldingRules IntSubOp intPrimOps
+ ]
+primOpRules nm IntAddCOp = mkPrimOpRule nm 2 [ binaryLit (intOpC2 (+))
+ , identityCDynFlags zeroi ]
+primOpRules nm IntSubCOp = mkPrimOpRule nm 2 [ binaryLit (intOpC2 (-))
+ , rightIdentityCDynFlags zeroi
+ , equalArgs >> retLitNoC zeroi ]
primOpRules nm IntMulOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (*))
, zeroElem zeroi
- , identityDynFlags onei ]
+ , identityDynFlags onei
+ , numFoldingRules IntMulOp intPrimOps
+ ]
primOpRules nm IntQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot)
, leftZero zeroi
, rightIdentityDynFlags onei
@@ -122,21 +134,32 @@ primOpRules nm NotIOp = mkPrimOpRule nm 1 [ unaryLit complementOp
, inversePrimOp NotIOp ]
primOpRules nm IntNegOp = mkPrimOpRule nm 1 [ unaryLit negOp
, inversePrimOp IntNegOp ]
-primOpRules nm ISllOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftL)
+primOpRules nm ISllOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL)
, rightIdentityDynFlags zeroi ]
-primOpRules nm ISraOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftR)
+primOpRules nm ISraOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftR)
, rightIdentityDynFlags zeroi ]
-primOpRules nm ISrlOp = mkPrimOpRule nm 2 [ binaryLit (intOp2' shiftRightLogical)
+primOpRules nm ISrlOp = mkPrimOpRule nm 2 [ shiftRule shiftRightLogical
, rightIdentityDynFlags zeroi ]
-- Word operations
primOpRules nm WordAddOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+))
- , identityDynFlags zerow ]
+ , identityDynFlags zerow
+ , numFoldingRules WordAddOp wordPrimOps
+ ]
primOpRules nm WordSubOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-))
, rightIdentityDynFlags zerow
- , equalArgs >> retLit zerow ]
+ , equalArgs >> retLit zerow
+ , numFoldingRules WordSubOp wordPrimOps
+ ]
+primOpRules nm WordAddCOp = mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (+))
+ , identityCDynFlags zerow ]
+primOpRules nm WordSubCOp = mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (-))
+ , rightIdentityCDynFlags zerow
+ , equalArgs >> retLitNoC zerow ]
primOpRules nm WordMulOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*))
- , identityDynFlags onew ]
+ , identityDynFlags onew
+ , numFoldingRules WordMulOp wordPrimOps
+ ]
primOpRules nm WordQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot)
, rightIdentityDynFlags onew ]
primOpRules nm WordRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem)
@@ -157,8 +180,8 @@ primOpRules nm XorOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor)
, equalArgs >> retLit zerow ]
primOpRules nm NotOp = mkPrimOpRule nm 1 [ unaryLit complementOp
, inversePrimOp NotOp ]
-primOpRules nm SllOp = mkPrimOpRule nm 2 [ wordShiftRule (const Bits.shiftL) ]
-primOpRules nm SrlOp = mkPrimOpRule nm 2 [ wordShiftRule shiftRightLogical ]
+primOpRules nm SllOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) ]
+primOpRules nm SrlOp = mkPrimOpRule nm 2 [ shiftRule shiftRightLogical ]
-- coercions
primOpRules nm Word2IntOp = mkPrimOpRule nm 1 [ liftLitDynFlags word2IntLit
@@ -361,12 +384,11 @@ cmpOp dflags cmp = go
-- These compares are at different types
go (MachChar i1) (MachChar i2) = done (i1 `cmp` i2)
- go (MachInt i1) (MachInt i2) = done (i1 `cmp` i2)
- go (MachInt64 i1) (MachInt64 i2) = done (i1 `cmp` i2)
- go (MachWord i1) (MachWord i2) = done (i1 `cmp` i2)
- go (MachWord64 i1) (MachWord64 i2) = done (i1 `cmp` i2)
go (MachFloat i1) (MachFloat i2) = done (i1 `cmp` i2)
go (MachDouble i1) (MachDouble i2) = done (i1 `cmp` i2)
+ go (LitNumber nt1 i1 _) (LitNumber nt2 i2 _)
+ | nt1 /= nt2 = Nothing
+ | otherwise = done (i1 `cmp` i2)
go _ _ = Nothing
--------------------------
@@ -376,12 +398,13 @@ negOp _ (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational
negOp dflags (MachFloat f) = Just (mkFloatVal dflags (-f))
negOp _ (MachDouble 0.0) = Nothing
negOp dflags (MachDouble d) = Just (mkDoubleVal dflags (-d))
-negOp dflags (MachInt i) = intResult dflags (-i)
+negOp dflags (LitNumber nt i t)
+ | litNumIsSigned nt = Just (Lit (mkLitNumberWrap dflags nt (-i) t))
negOp _ _ = Nothing
complementOp :: DynFlags -> Literal -> Maybe CoreExpr -- Binary complement
-complementOp dflags (MachWord i) = wordResult dflags (complement i)
-complementOp dflags (MachInt i) = intResult dflags (complement i)
+complementOp dflags (LitNumber nt i t) =
+ Just (Lit (mkLitNumberWrap dflags nt (complement i) t))
complementOp _ _ = Nothing
--------------------------
@@ -393,11 +416,18 @@ intOp2 = intOp2' . const
intOp2' :: (Integral a, Integral b)
=> (DynFlags -> a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
-intOp2' op dflags (MachInt i1) (MachInt i2) =
+intOp2' op dflags (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) =
let o = op dflags
in intResult dflags (fromInteger i1 `o` fromInteger i2)
intOp2' _ _ _ _ = Nothing -- Could find LitLit
+intOpC2 :: (Integral a, Integral b)
+ => (a -> b -> Integer)
+ -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
+intOpC2 op dflags (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) = do
+ intCResult dflags (fromInteger i1 `op` fromInteger i2)
+intOpC2 _ _ _ _ = Nothing -- Could find LitLit
+
shiftRightLogical :: DynFlags -> Integer -> Int -> Integer
-- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do
-- Do this by converting to Word and back. Obviously this won't work for big
@@ -412,29 +442,45 @@ retLit :: (DynFlags -> Literal) -> RuleM CoreExpr
retLit l = do dflags <- getDynFlags
return $ Lit $ l dflags
+retLitNoC :: (DynFlags -> Literal) -> RuleM CoreExpr
+retLitNoC l = do dflags <- getDynFlags
+ let lit = l dflags
+ let ty = literalType lit
+ return $ mkCoreUbxTup [ty, ty] [Lit lit, Lit (zeroi dflags)]
+
wordOp2 :: (Integral a, Integral b)
=> (a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
-wordOp2 op dflags (MachWord w1) (MachWord w2)
+wordOp2 op dflags (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _)
= wordResult dflags (fromInteger w1 `op` fromInteger w2)
wordOp2 _ _ _ _ = Nothing -- Could find LitLit
-wordShiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr
+wordOpC2 :: (Integral a, Integral b)
+ => (a -> b -> Integer)
+ -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
+wordOpC2 op dflags (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _) =
+ wordCResult dflags (fromInteger w1 `op` fromInteger w2)
+wordOpC2 _ _ _ _ = Nothing -- Could find LitLit
+
+shiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr
-- Shifts take an Int; hence third arg of op is Int
-- See Note [Guarding against silly shifts]
-wordShiftRule shift_op
+shiftRule shift_op
= do { dflags <- getDynFlags
- ; [e1, Lit (MachInt shift_len)] <- getArgs
+ ; [e1, Lit (LitNumber LitNumInt shift_len _)] <- getArgs
; case e1 of
_ | shift_len == 0
-> return e1
| shift_len < 0 || wordSizeInBits dflags < shift_len
-> return (mkRuntimeErrorApp rUNTIME_ERROR_ID wordPrimTy
("Bad shift length" ++ show shift_len))
- Lit (MachWord x)
+
+ -- Do the shift at type Integer, but shift length is Int
+ Lit (LitNumber nt x t)
-> let op = shift_op dflags
- in liftMaybe $ wordResult dflags (x `op` fromInteger shift_len)
- -- Do the shift at type Integer, but shift length is Int
+ y = x `op` fromInteger shift_len
+ in liftMaybe $ Just (Lit (mkLitNumberWrap dflags nt y t))
+
_ -> mzero }
wordSizeInBits :: DynFlags -> Integer
@@ -524,30 +570,62 @@ mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just $ trueValInt dfla
mkRuleFn _ _ _ _ = Nothing
isMinBound :: DynFlags -> Literal -> Bool
-isMinBound _ (MachChar c) = c == minBound
-isMinBound dflags (MachInt i) = i == tARGET_MIN_INT dflags
-isMinBound _ (MachInt64 i) = i == toInteger (minBound :: Int64)
-isMinBound _ (MachWord i) = i == 0
-isMinBound _ (MachWord64 i) = i == 0
-isMinBound _ _ = False
+isMinBound _ (MachChar c) = c == minBound
+isMinBound dflags (LitNumber nt i _) = case nt of
+ LitNumInt -> i == tARGET_MIN_INT dflags
+ LitNumInt64 -> i == toInteger (minBound :: Int64)
+ LitNumWord -> i == 0
+ LitNumWord64 -> i == 0
+ LitNumNatural -> i == 0
+ LitNumInteger -> False
+isMinBound _ _ = False
isMaxBound :: DynFlags -> Literal -> Bool
-isMaxBound _ (MachChar c) = c == maxBound
-isMaxBound dflags (MachInt i) = i == tARGET_MAX_INT dflags
-isMaxBound _ (MachInt64 i) = i == toInteger (maxBound :: Int64)
-isMaxBound dflags (MachWord i) = i == tARGET_MAX_WORD dflags
-isMaxBound _ (MachWord64 i) = i == toInteger (maxBound :: Word64)
-isMaxBound _ _ = False
+isMaxBound _ (MachChar c) = c == maxBound
+isMaxBound dflags (LitNumber nt i _) = case nt of
+ LitNumInt -> i == tARGET_MAX_INT dflags
+ LitNumInt64 -> i == toInteger (maxBound :: Int64)
+ LitNumWord -> i == tARGET_MAX_WORD dflags
+ LitNumWord64 -> i == toInteger (maxBound :: Word64)
+ LitNumNatural -> False
+ LitNumInteger -> False
+isMaxBound _ _ = False
-- | Create an Int literal expression while ensuring the given Integer is in the
-- target Int range
intResult :: DynFlags -> Integer -> Maybe CoreExpr
-intResult dflags result = Just (Lit (mkMachIntWrap dflags result))
+intResult dflags result = Just (intResult' dflags result)
+
+intResult' :: DynFlags -> Integer -> CoreExpr
+intResult' dflags result = Lit (mkMachIntWrap dflags result)
+
+-- | Create an unboxed pair of an Int literal expression, ensuring the given
+-- Integer is in the target Int range and the corresponding overflow flag
+-- (@0#@/@1#@) if it wasn't.
+intCResult :: DynFlags -> Integer -> Maybe CoreExpr
+intCResult dflags result = Just (mkPair [Lit lit, Lit c])
+ where
+ mkPair = mkCoreUbxTup [intPrimTy, intPrimTy]
+ (lit, b) = mkMachIntWrapC dflags result
+ c = if b then onei dflags else zeroi dflags
-- | Create a Word literal expression while ensuring the given Integer is in the
-- target Word range
wordResult :: DynFlags -> Integer -> Maybe CoreExpr
-wordResult dflags result = Just (Lit (mkMachWordWrap dflags result))
+wordResult dflags result = Just (wordResult' dflags result)
+
+wordResult' :: DynFlags -> Integer -> CoreExpr
+wordResult' dflags result = Lit (mkMachWordWrap dflags result)
+
+-- | Create an unboxed pair of a Word literal expression, ensuring the given
+-- Integer is in the target Word range and the corresponding carry flag
+-- (@0#@/@1#@) if it wasn't.
+wordCResult :: DynFlags -> Integer -> Maybe CoreExpr
+wordCResult dflags result = Just (mkPair [Lit lit, Lit c])
+ where
+ mkPair = mkCoreUbxTup [wordPrimTy, intPrimTy]
+ (lit, b) = mkMachWordWrapC dflags result
+ c = if b then onei dflags else zeroi dflags
inversePrimOp :: PrimOp -> RuleM CoreExpr
inversePrimOp primop = do
@@ -649,12 +727,10 @@ instance Monad RuleM where
RuleM f >>= g = RuleM $ \dflags iu e -> case f dflags iu e of
Nothing -> Nothing
Just r -> runRuleM (g r) dflags iu e
- fail _ = mzero
+ fail = MonadFail.fail
-#if __GLASGOW_HASKELL__ > 710
instance MonadFail.MonadFail RuleM where
fail _ = mzero
-#endif
instance Alternative RuleM where
empty = RuleM $ \_ _ _ -> Nothing
@@ -734,6 +810,16 @@ leftIdentityDynFlags id_lit = do
guard $ l1 == id_lit dflags
return e2
+-- | Left identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in
+-- addition to the result, we have to indicate that no carry/overflow occured.
+leftIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
+leftIdentityCDynFlags id_lit = do
+ dflags <- getDynFlags
+ [Lit l1, e2] <- getArgs
+ guard $ l1 == id_lit dflags
+ let no_c = Lit (zeroi dflags)
+ return (mkCoreUbxTup [exprType e2, intPrimTy] [e2, no_c])
+
rightIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
rightIdentityDynFlags id_lit = do
dflags <- getDynFlags
@@ -741,8 +827,25 @@ rightIdentityDynFlags id_lit = do
guard $ l2 == id_lit dflags
return e1
+-- | Right identity rule for PrimOps like 'IntSubC' and 'WordSubC', where, in
+-- addition to the result, we have to indicate that no carry/overflow occured.
+rightIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
+rightIdentityCDynFlags id_lit = do
+ dflags <- getDynFlags
+ [e1, Lit l2] <- getArgs
+ guard $ l2 == id_lit dflags
+ let no_c = Lit (zeroi dflags)
+ return (mkCoreUbxTup [exprType e1, intPrimTy] [e1, no_c])
+
identityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
-identityDynFlags lit = leftIdentityDynFlags lit `mplus` rightIdentityDynFlags lit
+identityDynFlags lit =
+ leftIdentityDynFlags lit `mplus` rightIdentityDynFlags lit
+
+-- | Identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in addition
+-- to the result, we have to indicate that no carry/overflow occured.
+identityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
+identityCDynFlags lit =
+ leftIdentityCDynFlags lit `mplus` rightIdentityCDynFlags lit
leftZero :: (DynFlags -> Literal) -> RuleM CoreExpr
leftZero zero = do
@@ -831,9 +934,9 @@ trueValBool = Var trueDataConId -- see Note [What's true and false]
falseValBool = Var falseDataConId
ltVal, eqVal, gtVal :: Expr CoreBndr
-ltVal = Var ltDataConId
-eqVal = Var eqDataConId
-gtVal = Var gtDataConId
+ltVal = Var ordLTDataConId
+eqVal = Var ordEQDataConId
+gtVal = Var ordGTDataConId
mkIntVal :: DynFlags -> Integer -> Expr CoreBndr
mkIntVal dflags i = Lit (mkMachInt dflags i)
@@ -880,7 +983,7 @@ tagToEnumRule :: RuleM CoreExpr
-- If data T a = A | B | C
-- then tag2Enum# (T ty) 2# --> B ty
tagToEnumRule = do
- [Type ty, Lit (MachInt i)] <- getArgs
+ [Type ty, Lit (LitNumber LitNumInt i _)] <- getArgs
case splitTyConApp_maybe ty of
Just (tycon, tc_args) | isEnumerationTyCon tycon -> do
let tag = fromInteger i
@@ -893,21 +996,35 @@ tagToEnumRule = do
_ -> WARN( True, text "tagToEnum# on non-enumeration type" <+> ppr ty )
return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"
-{-
-For dataToTag#, we can reduce if either
-
- (a) the argument is a constructor
- (b) the argument is a variable whose unfolding is a known constructor
--}
-
+------------------------------
dataToTagRule :: RuleM CoreExpr
+-- Rules for dataToTag#
dataToTagRule = a `mplus` b
where
+ -- dataToTag (tagToEnum x) ==> x
a = do
[Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs
guard $ tag_to_enum `hasKey` tagToEnumKey
guard $ ty1 `eqType` ty2
- return tag -- dataToTag (tagToEnum x) ==> x
+ return tag
+
+ -- Why don't we simplify tagToEnum# (dataToTag# x) to x? We would
+ -- like to, but it seems tricky. See #14282. The trouble is that
+ -- we never actually see tagToEnum# (dataToTag# x). Because dataToTag#
+ -- is can_fail, this expression is immediately transformed into
+ --
+ -- case dataToTag# @T x of wild
+ -- { __DEFAULT -> tagToEnum# @T wild }
+ --
+ -- and wild has no unfolding. Simon Peyton Jones speculates one way around
+ -- might be to arrange to give unfoldings to case binders of CONLIKE
+ -- applications and mark dataToTag# CONLIKE, but he doubts it's really
+ -- worth the trouble.
+
+ -- dataToTag (K e1 e2) ==> tag-of K
+ -- This also works (via exprIsConApp_maybe) for
+ -- dataToTag x
+ -- where x's unfolding is a constructor application
b = do
dflags <- getDynFlags
[_, val_arg] <- getArgs
@@ -924,12 +1041,65 @@ dataToTagRule = a `mplus` b
************************************************************************
-}
--- seq# :: forall a s . a -> State# s -> (# State# s, a #)
+{- Note [seq# magic]
+~~~~~~~~~~~~~~~~~~~~
+The primop
+ seq# :: forall a s . a -> State# s -> (# State# s, a #)
+
+is /not/ the same as the Prelude function seq :: a -> b -> b
+as you can see from its type. In fact, seq# is the implementation
+mechanism for 'evaluate'
+
+ evaluate :: a -> IO a
+ evaluate a = IO $ \s -> seq# a s
+
+The semantics of seq# is
+ * evaluate its first argument
+ * and return it
+
+Things to note
+
+* Why do we need a primop at all? That is, instead of
+ case seq# x s of (# x, s #) -> blah
+ why not instead say this?
+ case x of { DEFAULT -> blah)
+
+ Reason (see Trac #5129): if we saw
+ catch# (\s -> case x of { DEFAULT -> raiseIO# exn s }) handler
+
+ then we'd drop the 'case x' because the body of the case is bottom
+ anyway. But we don't want to do that; the whole /point/ of
+ seq#/evaluate is to evaluate 'x' first in the IO monad.
+
+ In short, we /always/ evaluate the first argument and never
+ just discard it.
+
+* Why return the value? So that we can control sharing of seq'd
+ values: in
+ let x = e in x `seq` ... x ...
+ We don't want to inline x, so better to represent it as
+ let x = e in case seq# x RW of (# _, x' #) -> ... x' ...
+ also it matches the type of rseq in the Eval monad.
+
+Implementing seq#. The compiler has magic for SeqOp in
+
+- PrelRules.seqRule: eliminate (seq# <whnf> s)
+
+- StgCmmExpr.cgExpr, and cgCase: special case for seq#
+
+- CoreUtils.exprOkForSpeculation;
+ see Note [seq# and expr_ok] in CoreUtils
+
+- Simplify.addEvals records evaluated-ness for the result; see
+ Note [Adding evaluatedness info to pattern-bound variables]
+ in Simplify
+-}
+
seqRule :: RuleM CoreExpr
seqRule = do
- [Type ty_a, Type ty_s, a, s] <- getArgs
+ [Type ty_a, Type _ty_s, a, s] <- getArgs
guard $ exprIsHNF a
- return $ mkCoreUbxTup [mkStatePrimTy ty_s, ty_a] [s, a]
+ return $ mkCoreUbxTup [exprType s, ty_a] [s, a]
-- spark# :: forall a s . a -> State# s -> (# State# s, a #)
sparkRule :: RuleM CoreExpr
@@ -987,7 +1157,7 @@ builtinRules
[ nonZeroLit 1 >> binaryLit (intOp2 div)
, leftZero zeroi
, do
- [arg, Lit (MachInt d)] <- getArgs
+ [arg, Lit (LitNumber LitNumInt d _)] <- getArgs
Just n <- return $ exactLog2 d
dflags <- getDynFlags
return $ Var (mkPrimOpId ISraOp) `App` arg `App` mkIntVal dflags n
@@ -996,7 +1166,7 @@ builtinRules
[ nonZeroLit 1 >> binaryLit (intOp2 mod)
, leftZero zeroi
, do
- [arg, Lit (MachInt d)] <- getArgs
+ [arg, Lit (LitNumber LitNumInt d _)] <- getArgs
Just _ <- return $ exactLog2 d
dflags <- getDynFlags
return $ Var (mkPrimOpId AndIOp)
@@ -1004,6 +1174,10 @@ builtinRules
]
]
++ builtinIntegerRules
+ ++ builtinNaturalRules
+{-# NOINLINE builtinRules #-}
+-- there is no benefit to inlining these yet, despite this, GHC produces
+-- unfoldings for this regardless since the floated list entries look small.
builtinIntegerRules :: [CoreRule]
builtinIntegerRules =
@@ -1082,7 +1256,7 @@ builtinIntegerRules =
ru_try = match_Integer_unop op }
rule_bitInteger str name
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
- ru_try = match_IntToInteger_unop (bit . fromIntegral) }
+ ru_try = match_bitInteger }
rule_binop str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
ru_try = match_Integer_binop op }
@@ -1117,6 +1291,31 @@ builtinIntegerRules =
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
ru_try = match_rationalTo mkLit }
+builtinNaturalRules :: [CoreRule]
+builtinNaturalRules =
+ [rule_binop "plusNatural" plusNaturalName (+)
+ ,rule_partial_binop "minusNatural" minusNaturalName (\a b -> if a >= b then Just (a - b) else Nothing)
+ ,rule_binop "timesNatural" timesNaturalName (*)
+ ,rule_NaturalFromInteger "naturalFromInteger" naturalFromIntegerName
+ ,rule_NaturalToInteger "naturalToInteger" naturalToIntegerName
+ ,rule_WordToNatural "wordToNatural" wordToNaturalName
+ ]
+ where rule_binop str name op
+ = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
+ ru_try = match_Natural_binop op }
+ rule_partial_binop str name op
+ = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
+ ru_try = match_Natural_partial_binop op }
+ rule_NaturalToInteger str name
+ = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
+ ru_try = match_NaturalToInteger }
+ rule_NaturalFromInteger str name
+ = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
+ ru_try = match_NaturalFromInteger }
+ rule_WordToNatural str name
+ = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
+ ru_try = match_WordToNatural }
+
---------------------------------------------------
-- The rule is this:
-- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
@@ -1208,51 +1407,68 @@ match_IntToInteger = match_IntToInteger_unop id
match_WordToInteger :: RuleFun
match_WordToInteger _ id_unf id [xl]
- | Just (MachWord x) <- exprIsLiteral_maybe id_unf xl
+ | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl
= case splitFunTy_maybe (idType id) of
Just (_, integerTy) ->
- Just (Lit (LitInteger x integerTy))
+ Just (Lit (mkLitInteger x integerTy))
_ ->
panic "match_WordToInteger: Id has the wrong type"
match_WordToInteger _ _ _ _ = Nothing
match_Int64ToInteger :: RuleFun
match_Int64ToInteger _ id_unf id [xl]
- | Just (MachInt64 x) <- exprIsLiteral_maybe id_unf xl
+ | Just (LitNumber LitNumInt64 x _) <- exprIsLiteral_maybe id_unf xl
= case splitFunTy_maybe (idType id) of
Just (_, integerTy) ->
- Just (Lit (LitInteger x integerTy))
+ Just (Lit (mkLitInteger x integerTy))
_ ->
panic "match_Int64ToInteger: Id has the wrong type"
match_Int64ToInteger _ _ _ _ = Nothing
match_Word64ToInteger :: RuleFun
match_Word64ToInteger _ id_unf id [xl]
- | Just (MachWord64 x) <- exprIsLiteral_maybe id_unf xl
+ | Just (LitNumber LitNumWord64 x _) <- exprIsLiteral_maybe id_unf xl
= case splitFunTy_maybe (idType id) of
Just (_, integerTy) ->
- Just (Lit (LitInteger x integerTy))
+ Just (Lit (mkLitInteger x integerTy))
_ ->
panic "match_Word64ToInteger: Id has the wrong type"
match_Word64ToInteger _ _ _ _ = Nothing
--------------------------------------------------
-match_Integer_convert :: Num a
- => (DynFlags -> a -> Expr CoreBndr)
- -> RuleFun
-match_Integer_convert convert dflags id_unf _ [xl]
- | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
- = Just (convert dflags (fromInteger x))
-match_Integer_convert _ _ _ _ _ = Nothing
+match_NaturalToInteger :: RuleFun
+match_NaturalToInteger _ id_unf id [xl]
+ | Just (LitNumber LitNumNatural x _) <- exprIsLiteral_maybe id_unf xl
+ = case splitFunTy_maybe (idType id) of
+ Just (_, naturalTy) ->
+ Just (Lit (LitNumber LitNumInteger x naturalTy))
+ _ ->
+ panic "match_NaturalToInteger: Id has the wrong type"
+match_NaturalToInteger _ _ _ _ = Nothing
-match_Integer_unop :: (Integer -> Integer) -> RuleFun
-match_Integer_unop unop _ id_unf _ [xl]
- | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
- = Just (Lit (LitInteger (unop x) i))
-match_Integer_unop _ _ _ _ _ = Nothing
+match_NaturalFromInteger :: RuleFun
+match_NaturalFromInteger _ id_unf id [xl]
+ | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
+ , x >= 0
+ = case splitFunTy_maybe (idType id) of
+ Just (_, naturalTy) ->
+ Just (Lit (LitNumber LitNumNatural x naturalTy))
+ _ ->
+ panic "match_NaturalFromInteger: Id has the wrong type"
+match_NaturalFromInteger _ _ _ _ = Nothing
-{- Note [Rewriting bitInteger]
+match_WordToNatural :: RuleFun
+match_WordToNatural _ id_unf id [xl]
+ | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl
+ = case splitFunTy_maybe (idType id) of
+ Just (_, naturalTy) ->
+ Just (Lit (LitNumber LitNumNatural x naturalTy))
+ _ ->
+ panic "match_WordToNatural: Id has the wrong type"
+match_WordToNatural _ _ _ _ = Nothing
+-------------------------------------------------
+{- Note [Rewriting bitInteger]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For most types the bitInteger operation can be implemented in terms of shifts.
The integer-gmp package, however, can do substantially better than this if
allowed to provide its own implementation. However, in so doing it previously lost
@@ -1260,68 +1476,117 @@ constant-folding (see Trac #8832). The bitInteger rule above provides constant f
specifically for this function.
There is, however, a bit of trickiness here when it comes to ranges. While the
-AST encodes all integers (even MachInts) as Integers, `bit` expects the bit
+AST encodes all integers as Integers, `bit` expects the bit
index to be given as an Int. Hence we coerce to an Int in the rule definition.
This will behave a bit funny for constants larger than the word size, but the user
should expect some funniness given that they will have at very least ignored a
warning in this case.
-}
+match_bitInteger :: RuleFun
+-- Just for GHC.Integer.Type.bitInteger :: Int# -> Integer
+match_bitInteger dflags id_unf fn [arg]
+ | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf arg
+ , x >= 0
+ , x <= (wordSizeInBits dflags - 1)
+ -- Make sure x is small enough to yield a decently small iteger
+ -- Attempting to construct the Integer for
+ -- (bitInteger 9223372036854775807#)
+ -- would be a bad idea (Trac #14959)
+ , let x_int = fromIntegral x :: Int
+ = case splitFunTy_maybe (idType fn) of
+ Just (_, integerTy)
+ -> Just (Lit (LitNumber LitNumInteger (bit x_int) integerTy))
+ _ -> panic "match_IntToInteger_unop: Id has the wrong type"
+
+match_bitInteger _ _ _ _ = Nothing
+
+
+-------------------------------------------------
+match_Integer_convert :: Num a
+ => (DynFlags -> a -> Expr CoreBndr)
+ -> RuleFun
+match_Integer_convert convert dflags id_unf _ [xl]
+ | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
+ = Just (convert dflags (fromInteger x))
+match_Integer_convert _ _ _ _ _ = Nothing
+
+match_Integer_unop :: (Integer -> Integer) -> RuleFun
+match_Integer_unop unop _ id_unf _ [xl]
+ | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
+ = Just (Lit (LitNumber LitNumInteger (unop x) i))
+match_Integer_unop _ _ _ _ _ = Nothing
+
match_IntToInteger_unop :: (Integer -> Integer) -> RuleFun
match_IntToInteger_unop unop _ id_unf fn [xl]
- | Just (MachInt x) <- exprIsLiteral_maybe id_unf xl
+ | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf xl
= case splitFunTy_maybe (idType fn) of
Just (_, integerTy) ->
- Just (Lit (LitInteger (unop x) integerTy))
+ Just (Lit (LitNumber LitNumInteger (unop x) integerTy))
_ ->
panic "match_IntToInteger_unop: Id has the wrong type"
match_IntToInteger_unop _ _ _ _ _ = Nothing
match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun
match_Integer_binop binop _ id_unf _ [xl,yl]
- | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
- , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
- = Just (Lit (LitInteger (x `binop` y) i))
+ | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
+ , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
+ = Just (Lit (mkLitInteger (x `binop` y) i))
match_Integer_binop _ _ _ _ _ = Nothing
+match_Natural_binop :: (Integer -> Integer -> Integer) -> RuleFun
+match_Natural_binop binop _ id_unf _ [xl,yl]
+ | Just (LitNumber LitNumNatural x i) <- exprIsLiteral_maybe id_unf xl
+ , Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl
+ = Just (Lit (mkLitNatural (x `binop` y) i))
+match_Natural_binop _ _ _ _ _ = Nothing
+
+match_Natural_partial_binop :: (Integer -> Integer -> Maybe Integer) -> RuleFun
+match_Natural_partial_binop binop _ id_unf _ [xl,yl]
+ | Just (LitNumber LitNumNatural x i) <- exprIsLiteral_maybe id_unf xl
+ , Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl
+ , Just z <- x `binop` y
+ = Just (Lit (mkLitNatural z i))
+match_Natural_partial_binop _ _ _ _ _ = Nothing
+
-- This helper is used for the quotRem and divMod functions
match_Integer_divop_both
:: (Integer -> Integer -> (Integer, Integer)) -> RuleFun
match_Integer_divop_both divop _ id_unf _ [xl,yl]
- | Just (LitInteger x t) <- exprIsLiteral_maybe id_unf xl
- , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
+ | Just (LitNumber LitNumInteger x t) <- exprIsLiteral_maybe id_unf xl
+ , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
, y /= 0
, (r,s) <- x `divop` y
- = Just $ mkCoreUbxTup [t,t] [Lit (LitInteger r t), Lit (LitInteger s t)]
+ = Just $ mkCoreUbxTup [t,t] [Lit (mkLitInteger r t), Lit (mkLitInteger s t)]
match_Integer_divop_both _ _ _ _ _ = Nothing
-- This helper is used for the quot and rem functions
match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun
match_Integer_divop_one divop _ id_unf _ [xl,yl]
- | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
- , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
+ | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
+ , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
, y /= 0
- = Just (Lit (LitInteger (x `divop` y) i))
+ = Just (Lit (mkLitInteger (x `divop` y) i))
match_Integer_divop_one _ _ _ _ _ = Nothing
match_Integer_Int_binop :: (Integer -> Int -> Integer) -> RuleFun
match_Integer_Int_binop binop _ id_unf _ [xl,yl]
- | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
- , Just (MachInt y) <- exprIsLiteral_maybe id_unf yl
- = Just (Lit (LitInteger (x `binop` fromIntegral y) i))
+ | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
+ , Just (LitNumber LitNumInt y _) <- exprIsLiteral_maybe id_unf yl
+ = Just (Lit (mkLitInteger (x `binop` fromIntegral y) i))
match_Integer_Int_binop _ _ _ _ _ = Nothing
match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun
match_Integer_binop_Prim binop dflags id_unf _ [xl, yl]
- | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
- , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
+ | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
+ , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
= Just (if x `binop` y then trueValInt dflags else falseValInt dflags)
match_Integer_binop_Prim _ _ _ _ _ = Nothing
match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun
match_Integer_binop_Ordering binop _ id_unf _ [xl, yl]
- | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
- , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
+ | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
+ , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
= Just $ case x `binop` y of
LT -> ltVal
EQ -> eqVal
@@ -1332,8 +1597,8 @@ match_Integer_Int_encodeFloat :: RealFloat a
=> (a -> Expr CoreBndr)
-> RuleFun
match_Integer_Int_encodeFloat mkLit _ id_unf _ [xl,yl]
- | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
- , Just (MachInt y) <- exprIsLiteral_maybe id_unf yl
+ | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
+ , Just (LitNumber LitNumInt y _) <- exprIsLiteral_maybe id_unf yl
= Just (mkLit $ encodeFloat x (fromInteger y))
match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing
@@ -1351,14 +1616,14 @@ match_rationalTo :: RealFloat a
=> (a -> Expr CoreBndr)
-> RuleFun
match_rationalTo mkLit _ id_unf _ [xl, yl]
- | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
- , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
+ | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
+ , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
, y /= 0
= Just (mkLit (fromRational (x % y)))
match_rationalTo _ _ _ _ _ = Nothing
match_decodeDouble :: RuleFun
-match_decodeDouble _ id_unf fn [xl]
+match_decodeDouble dflags id_unf fn [xl]
| Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl
= case splitFunTy_maybe (idType fn) of
Just (_, res)
@@ -1366,8 +1631,8 @@ match_decodeDouble _ id_unf fn [xl]
-> case decodeFloat (fromRational x :: Double) of
(y, z) ->
Just $ mkCoreUbxTup [integerTy, intHashTy]
- [Lit (LitInteger y integerTy),
- Lit (MachInt (toInteger z))]
+ [Lit (mkLitInteger y integerTy),
+ Lit (mkMachInt dflags (toInteger z))]
_ ->
pprPanic "match_decodeDouble: Id has the wrong type"
(ppr fn <+> dcolon <+> ppr (idType fn))
@@ -1388,6 +1653,275 @@ match_smallIntegerTo _ _ _ _ _ = Nothing
--------------------------------------------------------
+-- Note [Constant folding through nested expressions]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- We use rewrites rules to perform constant folding. It means that we don't
+-- have a global view of the expression we are trying to optimise. As a
+-- consequence we only perform local (small-step) transformations that either:
+-- 1) reduce the number of operations
+-- 2) rearrange the expression to increase the odds that other rules will
+-- match
+--
+-- We don't try to handle more complex expression optimisation cases that would
+-- require a global view. For example, rewriting expressions to increase
+-- sharing (e.g., Horner's method); optimisations that require local
+-- transformations increasing the number of operations; rearrangements to
+-- cancel/factorize terms (e.g., (a+b-a-b) isn't rearranged to reduce to 0).
+--
+-- We already have rules to perform constant folding on expressions with the
+-- following shape (where a and/or b are literals):
+--
+-- D) op
+-- /\
+-- / \
+-- / \
+-- a b
+--
+-- To support nested expressions, we match three other shapes of expression
+-- trees:
+--
+-- A) op1 B) op1 C) op1
+-- /\ /\ /\
+-- / \ / \ / \
+-- / \ / \ / \
+-- a op2 op2 c op2 op3
+-- /\ /\ /\ /\
+-- / \ / \ / \ / \
+-- b c a b a b c d
+--
+--
+-- R1) +/- simplification:
+-- ops = + or -, two literals (not siblings)
+--
+-- Examples:
+-- A: 5 + (10-x) ==> 15-x
+-- B: (10+x) + 5 ==> 15+x
+-- C: (5+a)-(5-b) ==> 0+(a+b)
+--
+-- R2) * simplification
+-- ops = *, two literals (not siblings)
+--
+-- Examples:
+-- A: 5 * (10*x) ==> 50*x
+-- B: (10*x) * 5 ==> 50*x
+-- C: (5*a)*(5*b) ==> 25*(a*b)
+--
+-- R3) * distribution over +/-
+-- op1 = *, op2 = + or -, two literals (not siblings)
+--
+-- This transformation doesn't reduce the number of operations but switches
+-- the outer and the inner operations so that the outer is (+) or (-) instead
+-- of (*). It increases the odds that other rules will match after this one.
+--
+-- Examples:
+-- A: 5 * (10-x) ==> 50 - (5*x)
+-- B: (10+x) * 5 ==> 50 + (5*x)
+-- C: Not supported as it would increase the number of operations:
+-- (5+a)*(5-b) ==> 25 - 5*b + 5*a - a*b
+--
+-- R4) Simple factorization
+--
+-- op1 = + or -, op2/op3 = *,
+-- one literal for each innermost * operation (except in the D case),
+-- the two other terms are equals
+--
+-- Examples:
+-- A: x - (10*x) ==> (-9)*x
+-- B: (10*x) + x ==> 11*x
+-- C: (5*x)-(x*3) ==> 2*x
+-- D: x+x ==> 2*x
+--
+-- R5) +/- propagation
+--
+-- ops = + or -, one literal
+--
+-- This transformation doesn't reduce the number of operations but propagates
+-- the constant to the outer level. It increases the odds that other rules
+-- will match after this one.
+--
+-- Examples:
+-- A: x - (10-y) ==> (x+y) - 10
+-- B: (10+x) - y ==> 10 + (x-y)
+-- C: N/A (caught by the A and B cases)
+--
+--------------------------------------------------------
+
+-- | Rules to perform constant folding into nested expressions
+--
+--See Note [Constant folding through nested expressions]
+numFoldingRules :: PrimOp -> (DynFlags -> PrimOps) -> RuleM CoreExpr
+numFoldingRules op dict = do
+ [e1,e2] <- getArgs
+ dflags <- getDynFlags
+ let PrimOps{..} = dict dflags
+ if not (gopt Opt_NumConstantFolding dflags)
+ then mzero
+ else case BinOpApp e1 op e2 of
+ -- R1) +/- simplification
+ x :++: (y :++: v) -> return $ mkL (x+y) `add` v
+ x :++: (L y :-: v) -> return $ mkL (x+y) `sub` v
+ x :++: (v :-: L y) -> return $ mkL (x-y) `add` v
+ L x :-: (y :++: v) -> return $ mkL (x-y) `sub` v
+ L x :-: (L y :-: v) -> return $ mkL (x-y) `add` v
+ L x :-: (v :-: L y) -> return $ mkL (x+y) `sub` v
+
+ (y :++: v) :-: L x -> return $ mkL (y-x) `add` v
+ (L y :-: v) :-: L x -> return $ mkL (y-x) `sub` v
+ (v :-: L y) :-: L x -> return $ mkL (0-y-x) `add` v
+
+ (x :++: w) :+: (y :++: v) -> return $ mkL (x+y) `add` (w `add` v)
+ (w :-: L x) :+: (L y :-: v) -> return $ mkL (y-x) `add` (w `sub` v)
+ (w :-: L x) :+: (v :-: L y) -> return $ mkL (0-x-y) `add` (w `add` v)
+ (L x :-: w) :+: (L y :-: v) -> return $ mkL (x+y) `sub` (w `add` v)
+ (L x :-: w) :+: (v :-: L y) -> return $ mkL (x-y) `add` (v `sub` w)
+ (w :-: L x) :+: (y :++: v) -> return $ mkL (y-x) `add` (w `add` v)
+ (L x :-: w) :+: (y :++: v) -> return $ mkL (x+y) `add` (v `sub` w)
+ (y :++: v) :+: (w :-: L x) -> return $ mkL (y-x) `add` (w `add` v)
+ (y :++: v) :+: (L x :-: w) -> return $ mkL (x+y) `add` (v `sub` w)
+
+ (v :-: L y) :-: (w :-: L x) -> return $ mkL (x-y) `add` (v `sub` w)
+ (v :-: L y) :-: (L x :-: w) -> return $ mkL (0-x-y) `add` (v `add` w)
+ (L y :-: v) :-: (w :-: L x) -> return $ mkL (x+y) `sub` (v `add` w)
+ (L y :-: v) :-: (L x :-: w) -> return $ mkL (y-x) `add` (w `sub` v)
+ (x :++: w) :-: (y :++: v) -> return $ mkL (x-y) `add` (w `sub` v)
+ (w :-: L x) :-: (y :++: v) -> return $ mkL (0-y-x) `add` (w `sub` v)
+ (L x :-: w) :-: (y :++: v) -> return $ mkL (x-y) `sub` (v `add` w)
+ (y :++: v) :-: (w :-: L x) -> return $ mkL (y+x) `add` (v `sub` w)
+ (y :++: v) :-: (L x :-: w) -> return $ mkL (y-x) `add` (v `add` w)
+
+ -- R2) * simplification
+ x :**: (y :**: v) -> return $ mkL (x*y) `mul` v
+ (x :**: w) :*: (y :**: v) -> return $ mkL (x*y) `mul` (w `mul` v)
+
+ -- R3) * distribution over +/-
+ x :**: (y :++: v) -> return $ mkL (x*y) `add` (mkL x `mul` v)
+ x :**: (L y :-: v) -> return $ mkL (x*y) `sub` (mkL x `mul` v)
+ x :**: (v :-: L y) -> return $ (mkL x `mul` v) `sub` mkL (x*y)
+
+ -- R4) Simple factorization
+ v :+: w
+ | w `cheapEqExpr` v -> return $ mkL 2 `mul` v
+ w :+: (y :**: v)
+ | w `cheapEqExpr` v -> return $ mkL (1+y) `mul` v
+ w :-: (y :**: v)
+ | w `cheapEqExpr` v -> return $ mkL (1-y) `mul` v
+ (y :**: v) :+: w
+ | w `cheapEqExpr` v -> return $ mkL (y+1) `mul` v
+ (y :**: v) :-: w
+ | w `cheapEqExpr` v -> return $ mkL (y-1) `mul` v
+ (x :**: w) :+: (y :**: v)
+ | w `cheapEqExpr` v -> return $ mkL (x+y) `mul` v
+ (x :**: w) :-: (y :**: v)
+ | w `cheapEqExpr` v -> return $ mkL (x-y) `mul` v
+
+ -- R5) +/- propagation
+ w :+: (y :++: v) -> return $ mkL y `add` (w `add` v)
+ (y :++: v) :+: w -> return $ mkL y `add` (w `add` v)
+ w :-: (y :++: v) -> return $ (w `sub` v) `sub` mkL y
+ (y :++: v) :-: w -> return $ mkL y `add` (v `sub` w)
+ w :-: (L y :-: v) -> return $ (w `add` v) `sub` mkL y
+ (L y :-: v) :-: w -> return $ mkL y `sub` (w `add` v)
+ w :+: (L y :-: v) -> return $ mkL y `add` (w `sub` v)
+ w :+: (v :-: L y) -> return $ (w `add` v) `sub` mkL y
+ (L y :-: v) :+: w -> return $ mkL y `add` (w `sub` v)
+ (v :-: L y) :+: w -> return $ (w `add` v) `sub` mkL y
+
+ _ -> mzero
+
+
+
+-- | Match the application of a binary primop
+pattern BinOpApp :: Arg CoreBndr -> PrimOp -> Arg CoreBndr -> CoreExpr
+pattern BinOpApp x op y = OpVal op `App` x `App` y
+
+-- | Match a primop
+pattern OpVal :: PrimOp -> Arg CoreBndr
+pattern OpVal op <- Var (isPrimOpId_maybe -> Just op) where
+ OpVal op = Var (mkPrimOpId op)
+
+
+
+-- | Match a literal
+pattern L :: Integer -> Arg CoreBndr
+pattern L l <- Lit (isLitValue_maybe -> Just l)
+
+-- | Match an addition
+pattern (:+:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr
+pattern x :+: y <- BinOpApp x (isAddOp -> True) y
+
+-- | Match an addition with a literal (handle commutativity)
+pattern (:++:) :: Integer -> Arg CoreBndr -> CoreExpr
+pattern l :++: x <- (isAdd -> Just (l,x))
+
+isAdd :: CoreExpr -> Maybe (Integer,CoreExpr)
+isAdd e = case e of
+ L l :+: x -> Just (l,x)
+ x :+: L l -> Just (l,x)
+ _ -> Nothing
+
+-- | Match a multiplication
+pattern (:*:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr
+pattern x :*: y <- BinOpApp x (isMulOp -> True) y
+
+-- | Match a multiplication with a literal (handle commutativity)
+pattern (:**:) :: Integer -> Arg CoreBndr -> CoreExpr
+pattern l :**: x <- (isMul -> Just (l,x))
+
+isMul :: CoreExpr -> Maybe (Integer,CoreExpr)
+isMul e = case e of
+ L l :*: x -> Just (l,x)
+ x :*: L l -> Just (l,x)
+ _ -> Nothing
+
+
+-- | Match a subtraction
+pattern (:-:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr
+pattern x :-: y <- BinOpApp x (isSubOp -> True) y
+
+isSubOp :: PrimOp -> Bool
+isSubOp IntSubOp = True
+isSubOp WordSubOp = True
+isSubOp _ = False
+
+isAddOp :: PrimOp -> Bool
+isAddOp IntAddOp = True
+isAddOp WordAddOp = True
+isAddOp _ = False
+
+isMulOp :: PrimOp -> Bool
+isMulOp IntMulOp = True
+isMulOp WordMulOp = True
+isMulOp _ = False
+
+-- | Explicit "type-class"-like dictionary for numeric primops
+--
+-- Depends on DynFlags because creating a literal value depends on DynFlags
+data PrimOps = PrimOps
+ { add :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Add two numbers
+ , sub :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Sub two numbers
+ , mul :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Multiply two numbers
+ , mkL :: Integer -> CoreExpr -- ^ Create a literal value
+ }
+
+intPrimOps :: DynFlags -> PrimOps
+intPrimOps dflags = PrimOps
+ { add = \x y -> BinOpApp x IntAddOp y
+ , sub = \x y -> BinOpApp x IntSubOp y
+ , mul = \x y -> BinOpApp x IntMulOp y
+ , mkL = intResult' dflags
+ }
+
+wordPrimOps :: DynFlags -> PrimOps
+wordPrimOps dflags = PrimOps
+ { add = \x y -> BinOpApp x WordAddOp y
+ , sub = \x y -> BinOpApp x WordSubOp y
+ , mul = \x y -> BinOpApp x WordMulOp y
+ , mkL = wordResult' dflags
+ }
+
+
+--------------------------------------------------------
-- Constant folding through case-expressions
--
-- cf Scrutinee Constant Folding in simplCore/SimplUtils
@@ -1396,11 +1930,13 @@ match_smallIntegerTo _ _ _ _ _ = Nothing
-- | Match the scrutinee of a case and potentially return a new scrutinee and a
-- function to apply to each literal alternative.
caseRules :: DynFlags
- -> CoreExpr -- Scrutinee
- -> Maybe ( CoreExpr -- New scrutinee
- , AltCon -> AltCon -- How to fix up the alt pattern
- , Id -> CoreExpr) -- How to reconstruct the original scrutinee
- -- from the new case-binder
+ -> CoreExpr -- Scrutinee
+ -> Maybe ( CoreExpr -- New scrutinee
+ , AltCon -> Maybe AltCon -- How to fix up the alt pattern
+ -- Nothing <=> Unreachable
+ -- See Note [Unreachable caseRules alternatives]
+ , Id -> CoreExpr) -- How to reconstruct the original scrutinee
+ -- from the new case-binder
-- e.g case e of b {
-- ...;
-- con bs -> rhs;
@@ -1423,7 +1959,7 @@ caseRules dflags (App (App (Var f) (Lit l)) v) -- x# `op` v
, Just x <- isLitValue_maybe l
, Just adjust_lit <- adjustDyadicLeft x op
= Just (v, tx_lit_con dflags adjust_lit
- , \v -> (App (App (Var f) (Var v)) (Lit l)))
+ , \v -> (App (App (Var f) (Lit l)) (Var v)))
caseRules dflags (App (Var f) v ) -- op v
@@ -1441,15 +1977,17 @@ caseRules dflags (App (App (Var f) type_arg) v)
-- See Note [caseRules for dataToTag]
caseRules _ (App (App (Var f) (Type ty)) v) -- dataToTag x
| Just DataToTagOp <- isPrimOpId_maybe f
+ , Just (tc, _) <- tcSplitTyConApp_maybe ty
+ , isAlgTyCon tc
= Just (v, tx_con_dtt ty
, \v -> App (App (Var f) (Type ty)) (Var v))
caseRules _ _ = Nothing
-tx_lit_con :: DynFlags -> (Integer -> Integer) -> AltCon -> AltCon
-tx_lit_con _ _ DEFAULT = DEFAULT
-tx_lit_con dflags adjust (LitAlt l) = LitAlt (mapLitValue dflags adjust l)
+tx_lit_con :: DynFlags -> (Integer -> Integer) -> AltCon -> Maybe AltCon
+tx_lit_con _ _ DEFAULT = Just DEFAULT
+tx_lit_con dflags adjust (LitAlt l) = Just $ LitAlt (mapLitValue dflags adjust l)
tx_lit_con _ _ alt = pprPanic "caseRules" (ppr alt)
-- NB: mapLitValue uses mkMachIntWrap etc, to ensure that the
-- literal alternatives remain in Word/Int target ranges
@@ -1489,22 +2027,28 @@ adjustUnary op
IntNegOp -> Just (\y -> negate y )
_ -> Nothing
-tx_con_tte :: DynFlags -> AltCon -> AltCon
-tx_con_tte _ DEFAULT = DEFAULT
-tx_con_tte dflags (DataAlt dc)
- | tag == 0 = DEFAULT -- See Note [caseRules for tagToEnum]
- | otherwise = LitAlt (mkMachInt dflags (toInteger tag))
- where
- tag = dataConTagZ dc
-tx_con_tte _ alt = pprPanic "caseRules" (ppr alt)
+tx_con_tte :: DynFlags -> AltCon -> Maybe AltCon
+tx_con_tte _ DEFAULT = Just DEFAULT
+tx_con_tte _ alt@(LitAlt {}) = pprPanic "caseRules" (ppr alt)
+tx_con_tte dflags (DataAlt dc) -- See Note [caseRules for tagToEnum]
+ = Just $ LitAlt $ mkMachInt dflags $ toInteger $ dataConTagZ dc
+
+tx_con_dtt :: Type -> AltCon -> Maybe AltCon
+tx_con_dtt _ DEFAULT = Just DEFAULT
+tx_con_dtt ty (LitAlt (LitNumber LitNumInt i _))
+ | tag >= 0
+ , tag < n_data_cons
+ = Just (DataAlt (data_cons !! tag)) -- tag is zero-indexed, as is (!!)
+ | otherwise
+ = Nothing
+ where
+ tag = fromInteger i :: ConTagZ
+ tc = tyConAppTyCon ty
+ n_data_cons = tyConFamilySize tc
+ data_cons = tyConDataCons tc
+
+tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt)
-tx_con_dtt :: Type -> AltCon -> AltCon
-tx_con_dtt _ DEFAULT = DEFAULT
-tx_con_dtt ty (LitAlt (MachInt i)) = DataAlt (get_con ty (fromInteger i))
-tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt)
-
-get_con :: Type -> ConTagZ -> DataCon
-get_con ty tag = tyConDataCons (tyConAppTyCon ty) !! tag
{- Note [caseRules for tagToEnum]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1515,18 +2059,34 @@ We want to transform
into
case x of
0# -> e1
- 1# -> e1
+ 1# -> e2
-This rule elimiantes a lot of boilerplate. For
- if (x>y) then e1 else e2
+This rule eliminates a lot of boilerplate. For
+ if (x>y) then e2 else e1
we generate
case tagToEnum (x ># y) of
- False -> e2
- True -> e1
+ False -> e1
+ True -> e2
and it is nice to then get rid of the tagToEnum.
-NB: in SimplUtils, where we invoke caseRules,
- we convert that 0# to DEFAULT
+Beware (Trac #14768): avoid the temptation to map constructor 0 to
+DEFAULT, in the hope of getting this
+ case (x ># y) of
+ DEFAULT -> e1
+ 1# -> e2
+That fails utterly in the case of
+ data Colour = Red | Green | Blue
+ case tagToEnum x of
+ DEFAULT -> e1
+ Red -> e2
+
+We don't want to get this!
+ case x of
+ DEFAULT -> e1
+ DEFAULT -> e2
+
+Instead, we deal with turning one branch into DEFAULT in SimplUtils
+(add_default in mkCase3).
Note [caseRules for dataToTag]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1541,4 +2101,25 @@ into
Note the need for some wildcard binders in
the 'cons' case.
+
+For the time, we only apply this transformation when the type of `x` is a type
+headed by a normal tycon. In particular, we do not apply this in the case of a
+data family tycon, since that would require carefully applying coercion(s)
+between the data family and the data family instance's representation type,
+which caseRules isn't currently engineered to handle (#14680).
+
+Note [Unreachable caseRules alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Take care if we see something like
+ case dataToTag x of
+ DEFAULT -> e1
+ -1# -> e2
+ 100 -> e3
+because there isn't a data constructor with tag -1 or 100. In this case the
+out-of-range alterantive is dead code -- we know the range of tags for x.
+
+Hence caseRules returns (AltCon -> Maybe AltCon), with Nothing indicating
+an alternative that is unreachable.
+
+You may wonder how this can happen: check out Trac #15436.
-}
diff --git a/compiler/prelude/PrimOp.hs b/compiler/prelude/PrimOp.hs
index 3a849060ff..4eb94e9fdb 100644
--- a/compiler/prelude/PrimOp.hs
+++ b/compiler/prelude/PrimOp.hs
@@ -7,9 +7,7 @@
{-# LANGUAGE CPP #-}
-- The default is a bit too low for the quite large primOpInfo definition
-#if __GLASGOW_HASKELL__ >= 801
{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}
-#endif
module PrimOp (
PrimOp(..), PrimOpVecCat(..), allThePrimOps,
@@ -29,6 +27,8 @@ module PrimOp (
#include "HsVersions.h"
+import GhcPrelude
+
import TysPrim
import TysWiredIn
diff --git a/compiler/prelude/PrimOp.hs-boot b/compiler/prelude/PrimOp.hs-boot
index 6b92ef3d49..f10ef44972 100644
--- a/compiler/prelude/PrimOp.hs-boot
+++ b/compiler/prelude/PrimOp.hs-boot
@@ -1,3 +1,5 @@
module PrimOp where
+import GhcPrelude ()
+
data PrimOp
diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs
index 85362434cc..7183a7edd6 100644
--- a/compiler/prelude/THNames.hs
+++ b/compiler/prelude/THNames.hs
@@ -6,6 +6,8 @@
module THNames where
+import GhcPrelude ()
+
import PrelNames( mk_known_key_name )
import Module( Module, mkModuleNameFS, mkModule, thUnitId )
import Name( Name )
@@ -51,10 +53,10 @@ templateHaskellNames = [
varEName, conEName, litEName, appEName, appTypeEName, infixEName,
infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName,
tupEName, unboxedTupEName, unboxedSumEName,
- condEName, multiIfEName, letEName, caseEName, doEName, compEName,
+ condEName, multiIfEName, letEName, caseEName, doEName, mdoEName, compEName,
fromEName, fromThenEName, fromToEName, fromThenToEName,
listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName,
- labelEName,
+ labelEName, implicitParamVarEName,
-- FieldExp
fieldExpName,
-- Body
@@ -62,7 +64,7 @@ templateHaskellNames = [
-- Guard
normalGEName, patGEName,
-- Stmt
- bindSName, letSName, noBindSName, parSName,
+ bindSName, letSName, noBindSName, parSName, recSName,
-- Dec
funDName, valDName, dataDName, newtypeDName, tySynDName,
classDName, instanceWithOverlapDName,
@@ -73,6 +75,7 @@ templateHaskellNames = [
dataInstDName, newtypeInstDName, tySynInstDName,
infixLDName, infixRDName, infixNDName,
roleAnnotDName, patSynDName, patSynSigDName,
+ implicitParamBindDName,
-- Cxt
cxtName,
@@ -95,9 +98,9 @@ templateHaskellNames = [
-- Type
forallTName, varTName, conTName, appTName, equalityTName,
tupleTName, unboxedTupleTName, unboxedSumTName,
- arrowTName, listTName, sigTName, sigTDataConName, litTName,
+ arrowTName, listTName, sigTName, litTName,
promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName,
- wildCardTName,
+ wildCardTName, implicitParamTName,
-- TyLit
numTyLitName, strTyLitName,
-- TyVarBndr
@@ -127,16 +130,14 @@ templateHaskellNames = [
overlappableDataConName, overlappingDataConName, overlapsDataConName,
incoherentDataConName,
-- DerivStrategy
- stockStrategyDataConName, anyclassStrategyDataConName,
- newtypeStrategyDataConName,
+ stockStrategyName, anyclassStrategyName,
+ newtypeStrategyName, viaStrategyName,
-- TExp
tExpDataConName,
-- RuleBndr
ruleVarName, typedRuleVarName,
-- FunDep
funDepName,
- -- FamFlavour
- typeFamName, dataFamName,
-- TySynEqn
tySynEqnName,
-- AnnTarget
@@ -152,18 +153,18 @@ templateHaskellNames = [
clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,
stmtQTyConName, decQTyConName, conQTyConName, bangTypeQTyConName,
varBangTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
- typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,
+ typeTyConName, tyVarBndrQTyConName, matchTyConName, clauseTyConName,
patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName,
- roleTyConName, tExpTyConName, injAnnTyConName, kindTyConName,
- overlapTyConName, derivClauseQTyConName, derivStrategyTyConName,
+ roleTyConName, tExpTyConName, injAnnTyConName, kindQTyConName,
+ overlapTyConName, derivClauseQTyConName, derivStrategyQTyConName,
-- Quasiquoting
quoteDecName, quoteTypeName, quoteExpName, quotePatName]
thSyn, thLib, qqLib :: Module
thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")
-thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib")
+thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib.Internal")
qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")
mkTHModule :: FastString -> Module
@@ -184,9 +185,8 @@ liftClassName = thCls (fsLit "Lift") liftClassKey
qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
- tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName,
- predTyConName, tExpTyConName, injAnnTyConName, kindTyConName,
- overlapTyConName, derivStrategyTyConName :: Name
+ matchTyConName, clauseTyConName, funDepTyConName, predTyConName,
+ tExpTyConName, injAnnTyConName, overlapTyConName :: Name
qTyConName = thTc (fsLit "Q") qTyConKey
nameTyConName = thTc (fsLit "Name") nameTyConKey
fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey
@@ -195,16 +195,13 @@ fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey
expTyConName = thTc (fsLit "Exp") expTyConKey
decTyConName = thTc (fsLit "Dec") decTyConKey
typeTyConName = thTc (fsLit "Type") typeTyConKey
-tyVarBndrTyConName = thTc (fsLit "TyVarBndr") tyVarBndrTyConKey
matchTyConName = thTc (fsLit "Match") matchTyConKey
clauseTyConName = thTc (fsLit "Clause") clauseTyConKey
funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey
predTyConName = thTc (fsLit "Pred") predTyConKey
tExpTyConName = thTc (fsLit "TExp") tExpTyConKey
injAnnTyConName = thTc (fsLit "InjectivityAnn") injAnnTyConKey
-kindTyConName = thTc (fsLit "Kind") kindTyConKey
overlapTyConName = thTc (fsLit "Overlap") overlapTyConKey
-derivStrategyTyConName = thTc (fsLit "DerivStrategy") derivStrategyTyConKey
returnQName, bindQName, sequenceQName, newNameName, liftName,
mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
@@ -279,43 +276,45 @@ clauseName = libFun (fsLit "clause") clauseIdKey
varEName, conEName, litEName, appEName, appTypeEName, infixEName, infixAppName,
sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,
unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName,
- caseEName, doEName, compEName, staticEName, unboundVarEName,
- labelEName :: Name
-varEName = libFun (fsLit "varE") varEIdKey
-conEName = libFun (fsLit "conE") conEIdKey
-litEName = libFun (fsLit "litE") litEIdKey
-appEName = libFun (fsLit "appE") appEIdKey
-appTypeEName = libFun (fsLit "appTypeE") appTypeEIdKey
-infixEName = libFun (fsLit "infixE") infixEIdKey
-infixAppName = libFun (fsLit "infixApp") infixAppIdKey
-sectionLName = libFun (fsLit "sectionL") sectionLIdKey
-sectionRName = libFun (fsLit "sectionR") sectionRIdKey
-lamEName = libFun (fsLit "lamE") lamEIdKey
-lamCaseEName = libFun (fsLit "lamCaseE") lamCaseEIdKey
-tupEName = libFun (fsLit "tupE") tupEIdKey
-unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey
-unboxedSumEName = libFun (fsLit "unboxedSumE") unboxedSumEIdKey
-condEName = libFun (fsLit "condE") condEIdKey
-multiIfEName = libFun (fsLit "multiIfE") multiIfEIdKey
-letEName = libFun (fsLit "letE") letEIdKey
-caseEName = libFun (fsLit "caseE") caseEIdKey
-doEName = libFun (fsLit "doE") doEIdKey
-compEName = libFun (fsLit "compE") compEIdKey
+ caseEName, doEName, mdoEName, compEName, staticEName, unboundVarEName,
+ labelEName, implicitParamVarEName :: Name
+varEName = libFun (fsLit "varE") varEIdKey
+conEName = libFun (fsLit "conE") conEIdKey
+litEName = libFun (fsLit "litE") litEIdKey
+appEName = libFun (fsLit "appE") appEIdKey
+appTypeEName = libFun (fsLit "appTypeE") appTypeEIdKey
+infixEName = libFun (fsLit "infixE") infixEIdKey
+infixAppName = libFun (fsLit "infixApp") infixAppIdKey
+sectionLName = libFun (fsLit "sectionL") sectionLIdKey
+sectionRName = libFun (fsLit "sectionR") sectionRIdKey
+lamEName = libFun (fsLit "lamE") lamEIdKey
+lamCaseEName = libFun (fsLit "lamCaseE") lamCaseEIdKey
+tupEName = libFun (fsLit "tupE") tupEIdKey
+unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey
+unboxedSumEName = libFun (fsLit "unboxedSumE") unboxedSumEIdKey
+condEName = libFun (fsLit "condE") condEIdKey
+multiIfEName = libFun (fsLit "multiIfE") multiIfEIdKey
+letEName = libFun (fsLit "letE") letEIdKey
+caseEName = libFun (fsLit "caseE") caseEIdKey
+doEName = libFun (fsLit "doE") doEIdKey
+mdoEName = libFun (fsLit "mdoE") mdoEIdKey
+compEName = libFun (fsLit "compE") compEIdKey
-- ArithSeq skips a level
fromEName, fromThenEName, fromToEName, fromThenToEName :: Name
-fromEName = libFun (fsLit "fromE") fromEIdKey
-fromThenEName = libFun (fsLit "fromThenE") fromThenEIdKey
-fromToEName = libFun (fsLit "fromToE") fromToEIdKey
-fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey
+fromEName = libFun (fsLit "fromE") fromEIdKey
+fromThenEName = libFun (fsLit "fromThenE") fromThenEIdKey
+fromToEName = libFun (fsLit "fromToE") fromToEIdKey
+fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey
-- end ArithSeq
listEName, sigEName, recConEName, recUpdEName :: Name
-listEName = libFun (fsLit "listE") listEIdKey
-sigEName = libFun (fsLit "sigE") sigEIdKey
-recConEName = libFun (fsLit "recConE") recConEIdKey
-recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey
-staticEName = libFun (fsLit "staticE") staticEIdKey
-unboundVarEName = libFun (fsLit "unboundVarE") unboundVarEIdKey
-labelEName = libFun (fsLit "labelE") labelEIdKey
+listEName = libFun (fsLit "listE") listEIdKey
+sigEName = libFun (fsLit "sigE") sigEIdKey
+recConEName = libFun (fsLit "recConE") recConEIdKey
+recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey
+staticEName = libFun (fsLit "staticE") staticEIdKey
+unboundVarEName = libFun (fsLit "unboundVarE") unboundVarEIdKey
+labelEName = libFun (fsLit "labelE") labelEIdKey
+implicitParamVarEName = libFun (fsLit "implicitParamVarE") implicitParamVarEIdKey
-- type FieldExp = ...
fieldExpName :: Name
@@ -332,11 +331,12 @@ normalGEName = libFun (fsLit "normalGE") normalGEIdKey
patGEName = libFun (fsLit "patGE") patGEIdKey
-- data Stmt = ...
-bindSName, letSName, noBindSName, parSName :: Name
+bindSName, letSName, noBindSName, parSName, recSName :: Name
bindSName = libFun (fsLit "bindS") bindSIdKey
letSName = libFun (fsLit "letS") letSIdKey
noBindSName = libFun (fsLit "noBindS") noBindSIdKey
parSName = libFun (fsLit "parS") parSIdKey
+recSName = libFun (fsLit "recS") recSIdKey
-- data Dec = ...
funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
@@ -346,39 +346,38 @@ funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,
openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName,
infixNDName, roleAnnotDName, patSynDName, patSynSigDName,
- pragCompleteDName :: Name
-funDName = libFun (fsLit "funD") funDIdKey
-valDName = libFun (fsLit "valD") valDIdKey
-dataDName = libFun (fsLit "dataD") dataDIdKey
-newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey
-tySynDName = libFun (fsLit "tySynD") tySynDIdKey
-classDName = libFun (fsLit "classD") classDIdKey
-instanceWithOverlapDName
- = libFun (fsLit "instanceWithOverlapD") instanceWithOverlapDIdKey
-standaloneDerivWithStrategyDName = libFun
- (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey
-sigDName = libFun (fsLit "sigD") sigDIdKey
-defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey
-forImpDName = libFun (fsLit "forImpD") forImpDIdKey
-pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey
-pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey
-pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey
-pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey
-pragRuleDName = libFun (fsLit "pragRuleD") pragRuleDIdKey
-pragCompleteDName = libFun (fsLit "pragCompleteD") pragCompleteDIdKey
-pragAnnDName = libFun (fsLit "pragAnnD") pragAnnDIdKey
-dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey
-newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
-tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey
-openTypeFamilyDName = libFun (fsLit "openTypeFamilyD") openTypeFamilyDIdKey
-closedTypeFamilyDName= libFun (fsLit "closedTypeFamilyD") closedTypeFamilyDIdKey
-dataFamilyDName = libFun (fsLit "dataFamilyD") dataFamilyDIdKey
-infixLDName = libFun (fsLit "infixLD") infixLDIdKey
-infixRDName = libFun (fsLit "infixRD") infixRDIdKey
-infixNDName = libFun (fsLit "infixND") infixNDIdKey
-roleAnnotDName = libFun (fsLit "roleAnnotD") roleAnnotDIdKey
-patSynDName = libFun (fsLit "patSynD") patSynDIdKey
-patSynSigDName = libFun (fsLit "patSynSigD") patSynSigDIdKey
+ pragCompleteDName, implicitParamBindDName :: Name
+funDName = libFun (fsLit "funD") funDIdKey
+valDName = libFun (fsLit "valD") valDIdKey
+dataDName = libFun (fsLit "dataD") dataDIdKey
+newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey
+tySynDName = libFun (fsLit "tySynD") tySynDIdKey
+classDName = libFun (fsLit "classD") classDIdKey
+instanceWithOverlapDName = libFun (fsLit "instanceWithOverlapD") instanceWithOverlapDIdKey
+standaloneDerivWithStrategyDName = libFun (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey
+sigDName = libFun (fsLit "sigD") sigDIdKey
+defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey
+forImpDName = libFun (fsLit "forImpD") forImpDIdKey
+pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey
+pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey
+pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey
+pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey
+pragRuleDName = libFun (fsLit "pragRuleD") pragRuleDIdKey
+pragCompleteDName = libFun (fsLit "pragCompleteD") pragCompleteDIdKey
+pragAnnDName = libFun (fsLit "pragAnnD") pragAnnDIdKey
+dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey
+newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
+tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey
+openTypeFamilyDName = libFun (fsLit "openTypeFamilyD") openTypeFamilyDIdKey
+closedTypeFamilyDName = libFun (fsLit "closedTypeFamilyD") closedTypeFamilyDIdKey
+dataFamilyDName = libFun (fsLit "dataFamilyD") dataFamilyDIdKey
+infixLDName = libFun (fsLit "infixLD") infixLDIdKey
+infixRDName = libFun (fsLit "infixRD") infixRDIdKey
+infixNDName = libFun (fsLit "infixND") infixNDIdKey
+roleAnnotDName = libFun (fsLit "roleAnnotD") roleAnnotDIdKey
+patSynDName = libFun (fsLit "patSynD") patSynDIdKey
+patSynSigDName = libFun (fsLit "patSynSigD") patSynSigDIdKey
+implicitParamBindDName = libFun (fsLit "implicitParamBindD") implicitParamBindDIdKey
-- type Ctxt = ...
cxtName :: Name
@@ -432,9 +431,9 @@ recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey
-- data Type = ...
forallTName, varTName, conTName, tupleTName, unboxedTupleTName,
unboxedSumTName, arrowTName, listTName, appTName, sigTName,
- sigTDataConName, equalityTName, litTName, promotedTName,
+ equalityTName, litTName, promotedTName,
promotedTupleTName, promotedNilTName, promotedConsTName,
- wildCardTName :: Name
+ wildCardTName, implicitParamTName :: Name
forallTName = libFun (fsLit "forallT") forallTIdKey
varTName = libFun (fsLit "varT") varTIdKey
conTName = libFun (fsLit "conT") conTIdKey
@@ -445,9 +444,6 @@ arrowTName = libFun (fsLit "arrowT") arrowTIdKey
listTName = libFun (fsLit "listT") listTIdKey
appTName = libFun (fsLit "appT") appTIdKey
sigTName = libFun (fsLit "sigT") sigTIdKey
--- Yes, we need names for both the monadic sigT as well as the pure SigT. Why?
--- Refer to the documentation for repLKind in DsMeta.
-sigTDataConName = thCon (fsLit "SigT") sigTDataConKey
equalityTName = libFun (fsLit "equalityT") equalityTIdKey
litTName = libFun (fsLit "litT") litTIdKey
promotedTName = libFun (fsLit "promotedT") promotedTIdKey
@@ -455,6 +451,7 @@ promotedTupleTName = libFun (fsLit "promotedTupleT") promotedTupleTIdKey
promotedNilTName = libFun (fsLit "promotedNilT") promotedNilTIdKey
promotedConsTName = libFun (fsLit "promotedConsT") promotedConsTIdKey
wildCardTName = libFun (fsLit "wildCardT") wildCardTIdKey
+implicitParamTName = libFun (fsLit "implicitParamT") implicitParamTIdKey
-- data TyLit = ...
numTyLitName, strTyLitName :: Name
@@ -463,8 +460,8 @@ strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey
-- data TyVarBndr = ...
plainTVName, kindedTVName :: Name
-plainTVName = libFun (fsLit "plainTV") plainTVIdKey
-kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey
+plainTVName = libFun (fsLit "plainTV") plainTVIdKey
+kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey
-- data Role = ...
nominalRName, representationalRName, phantomRName, inferRName :: Name
@@ -487,9 +484,9 @@ constraintKName = libFun (fsLit "constraintK") constraintKIdKey
-- data FamilyResultSig = ...
noSigName, kindSigName, tyVarSigName :: Name
-noSigName = libFun (fsLit "noSig") noSigIdKey
-kindSigName = libFun (fsLit "kindSig") kindSigIdKey
-tyVarSigName = libFun (fsLit "tyVarSig") tyVarSigIdKey
+noSigName = libFun (fsLit "noSig") noSigIdKey
+kindSigName = libFun (fsLit "kindSig") kindSigIdKey
+tyVarSigName = libFun (fsLit "tyVarSig") tyVarSigIdKey
-- data InjectivityAnn = ...
injectivityAnnName :: Name
@@ -522,11 +519,6 @@ typedRuleVarName = libFun (fsLit ("typedRuleVar")) typedRuleVarIdKey
funDepName :: Name
funDepName = libFun (fsLit "funDep") funDepIdKey
--- data FamFlavour = ...
-typeFamName, dataFamName :: Name
-typeFamName = libFun (fsLit "typeFam") typeFamIdKey
-dataFamName = libFun (fsLit "dataFam") dataFamIdKey
-
-- data TySynEqn = ...
tySynEqnName :: Name
tySynEqnName = libFun (fsLit "tySynEqn") tySynEqnIdKey
@@ -541,12 +533,21 @@ moduleAnnotationName = libFun (fsLit "moduleAnnotation") moduleAnnotationIdKey
derivClauseName :: Name
derivClauseName = libFun (fsLit "derivClause") derivClauseIdKey
+-- data DerivStrategy = ...
+stockStrategyName, anyclassStrategyName, newtypeStrategyName,
+ viaStrategyName :: Name
+stockStrategyName = libFun (fsLit "stockStrategy") stockStrategyIdKey
+anyclassStrategyName = libFun (fsLit "anyclassStrategy") anyclassStrategyIdKey
+newtypeStrategyName = libFun (fsLit "newtypeStrategy") newtypeStrategyIdKey
+viaStrategyName = libFun (fsLit "viaStrategy") viaStrategyIdKey
+
matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
decQTyConName, conQTyConName, bangTypeQTyConName,
varBangTypeQTyConName, typeQTyConName, fieldExpQTyConName,
patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName,
ruleBndrQTyConName, tySynEqnQTyConName, roleTyConName,
- derivClauseQTyConName :: Name
+ derivClauseQTyConName, kindQTyConName, tyVarBndrQTyConName,
+ derivStrategyQTyConName :: Name
matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey
clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey
expQTyConName = libTc (fsLit "ExpQ") expQTyConKey
@@ -565,6 +566,9 @@ ruleBndrQTyConName = libTc (fsLit "RuleBndrQ") ruleBndrQTyConKey
tySynEqnQTyConName = libTc (fsLit "TySynEqnQ") tySynEqnQTyConKey
roleTyConName = libTc (fsLit "Role") roleTyConKey
derivClauseQTyConName = libTc (fsLit "DerivClauseQ") derivClauseQTyConKey
+kindQTyConName = libTc (fsLit "KindQ") kindQTyConKey
+tyVarBndrQTyConName = libTc (fsLit "TyVarBndrQ") tyVarBndrQTyConKey
+derivStrategyQTyConName = libTc (fsLit "DerivStrategyQ") derivStrategyQTyConKey
-- quasiquoting
quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name
@@ -600,13 +604,6 @@ overlappingDataConName = thCon (fsLit "Overlapping") overlappingDataConKey
overlapsDataConName = thCon (fsLit "Overlaps") overlapsDataConKey
incoherentDataConName = thCon (fsLit "Incoherent") incoherentDataConKey
--- data DerivStrategy = ...
-stockStrategyDataConName, anyclassStrategyDataConName,
- newtypeStrategyDataConName :: Name
-stockStrategyDataConName = thCon (fsLit "StockStrategy") stockDataConKey
-anyclassStrategyDataConName = thCon (fsLit "AnyclassStrategy") anyclassDataConKey
-newtypeStrategyDataConName = thCon (fsLit "NewtypeStrategy") newtypeDataConKey
-
{- *********************************************************************
* *
Class keys
@@ -630,13 +627,13 @@ liftClassKey = mkPreludeClassUnique 200
expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,
- stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey,
- decTyConKey, bangTypeQTyConKey, varBangTypeQTyConKey,
+ stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey,
+ tyVarBndrQTyConKey, decTyConKey, bangTypeQTyConKey, varBangTypeQTyConKey,
fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey,
- roleTyConKey, tExpTyConKey, injAnnTyConKey, kindTyConKey,
- overlapTyConKey, derivClauseQTyConKey, derivStrategyTyConKey :: Unique
+ roleTyConKey, tExpTyConKey, injAnnTyConKey, kindQTyConKey,
+ overlapTyConKey, derivClauseQTyConKey, derivStrategyQTyConKey :: Unique
expTyConKey = mkPreludeTyConUnique 200
matchTyConKey = mkPreludeTyConUnique 201
clauseTyConKey = mkPreludeTyConUnique 202
@@ -662,17 +659,17 @@ fieldExpQTyConKey = mkPreludeTyConUnique 221
funDepTyConKey = mkPreludeTyConUnique 222
predTyConKey = mkPreludeTyConUnique 223
predQTyConKey = mkPreludeTyConUnique 224
-tyVarBndrTyConKey = mkPreludeTyConUnique 225
+tyVarBndrQTyConKey = mkPreludeTyConUnique 225
decsQTyConKey = mkPreludeTyConUnique 226
ruleBndrQTyConKey = mkPreludeTyConUnique 227
tySynEqnQTyConKey = mkPreludeTyConUnique 228
roleTyConKey = mkPreludeTyConUnique 229
tExpTyConKey = mkPreludeTyConUnique 230
injAnnTyConKey = mkPreludeTyConUnique 231
-kindTyConKey = mkPreludeTyConUnique 232
+kindQTyConKey = mkPreludeTyConUnique 232
overlapTyConKey = mkPreludeTyConUnique 233
derivClauseQTyConKey = mkPreludeTyConUnique 234
-derivStrategyTyConKey = mkPreludeTyConUnique 235
+derivStrategyQTyConKey = mkPreludeTyConUnique 235
{- *********************************************************************
* *
@@ -714,12 +711,6 @@ overlappingDataConKey = mkPreludeDataConUnique 210
overlapsDataConKey = mkPreludeDataConUnique 211
incoherentDataConKey = mkPreludeDataConUnique 212
--- data DerivStrategy = ...
-stockDataConKey, anyclassDataConKey, newtypeDataConKey :: Unique
-stockDataConKey = mkPreludeDataConUnique 213
-anyclassDataConKey = mkPreludeDataConUnique 214
-newtypeDataConKey = mkPreludeDataConUnique 215
-
{- *********************************************************************
* *
Id keys
@@ -807,38 +798,40 @@ varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey,
letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey,
- unboundVarEIdKey, labelEIdKey :: Unique
-varEIdKey = mkPreludeMiscIdUnique 270
-conEIdKey = mkPreludeMiscIdUnique 271
-litEIdKey = mkPreludeMiscIdUnique 272
-appEIdKey = mkPreludeMiscIdUnique 273
-appTypeEIdKey = mkPreludeMiscIdUnique 274
-infixEIdKey = mkPreludeMiscIdUnique 275
-infixAppIdKey = mkPreludeMiscIdUnique 276
-sectionLIdKey = mkPreludeMiscIdUnique 277
-sectionRIdKey = mkPreludeMiscIdUnique 278
-lamEIdKey = mkPreludeMiscIdUnique 279
-lamCaseEIdKey = mkPreludeMiscIdUnique 280
-tupEIdKey = mkPreludeMiscIdUnique 281
-unboxedTupEIdKey = mkPreludeMiscIdUnique 282
-unboxedSumEIdKey = mkPreludeMiscIdUnique 283
-condEIdKey = mkPreludeMiscIdUnique 284
-multiIfEIdKey = mkPreludeMiscIdUnique 285
-letEIdKey = mkPreludeMiscIdUnique 286
-caseEIdKey = mkPreludeMiscIdUnique 287
-doEIdKey = mkPreludeMiscIdUnique 288
-compEIdKey = mkPreludeMiscIdUnique 289
-fromEIdKey = mkPreludeMiscIdUnique 290
-fromThenEIdKey = mkPreludeMiscIdUnique 291
-fromToEIdKey = mkPreludeMiscIdUnique 292
-fromThenToEIdKey = mkPreludeMiscIdUnique 293
-listEIdKey = mkPreludeMiscIdUnique 294
-sigEIdKey = mkPreludeMiscIdUnique 295
-recConEIdKey = mkPreludeMiscIdUnique 296
-recUpdEIdKey = mkPreludeMiscIdUnique 297
-staticEIdKey = mkPreludeMiscIdUnique 298
-unboundVarEIdKey = mkPreludeMiscIdUnique 299
-labelEIdKey = mkPreludeMiscIdUnique 300
+ unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey :: Unique
+varEIdKey = mkPreludeMiscIdUnique 270
+conEIdKey = mkPreludeMiscIdUnique 271
+litEIdKey = mkPreludeMiscIdUnique 272
+appEIdKey = mkPreludeMiscIdUnique 273
+appTypeEIdKey = mkPreludeMiscIdUnique 274
+infixEIdKey = mkPreludeMiscIdUnique 275
+infixAppIdKey = mkPreludeMiscIdUnique 276
+sectionLIdKey = mkPreludeMiscIdUnique 277
+sectionRIdKey = mkPreludeMiscIdUnique 278
+lamEIdKey = mkPreludeMiscIdUnique 279
+lamCaseEIdKey = mkPreludeMiscIdUnique 280
+tupEIdKey = mkPreludeMiscIdUnique 281
+unboxedTupEIdKey = mkPreludeMiscIdUnique 282
+unboxedSumEIdKey = mkPreludeMiscIdUnique 283
+condEIdKey = mkPreludeMiscIdUnique 284
+multiIfEIdKey = mkPreludeMiscIdUnique 285
+letEIdKey = mkPreludeMiscIdUnique 286
+caseEIdKey = mkPreludeMiscIdUnique 287
+doEIdKey = mkPreludeMiscIdUnique 288
+compEIdKey = mkPreludeMiscIdUnique 289
+fromEIdKey = mkPreludeMiscIdUnique 290
+fromThenEIdKey = mkPreludeMiscIdUnique 291
+fromToEIdKey = mkPreludeMiscIdUnique 292
+fromThenToEIdKey = mkPreludeMiscIdUnique 293
+listEIdKey = mkPreludeMiscIdUnique 294
+sigEIdKey = mkPreludeMiscIdUnique 295
+recConEIdKey = mkPreludeMiscIdUnique 296
+recUpdEIdKey = mkPreludeMiscIdUnique 297
+staticEIdKey = mkPreludeMiscIdUnique 298
+unboundVarEIdKey = mkPreludeMiscIdUnique 299
+labelEIdKey = mkPreludeMiscIdUnique 300
+implicitParamVarEIdKey = mkPreludeMiscIdUnique 301
+mdoEIdKey = mkPreludeMiscIdUnique 302
-- type FieldExp = ...
fieldExpIdKey :: Unique
@@ -855,11 +848,12 @@ normalGEIdKey = mkPreludeMiscIdUnique 308
patGEIdKey = mkPreludeMiscIdUnique 309
-- data Stmt = ...
-bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique
+bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey, recSIdKey :: Unique
bindSIdKey = mkPreludeMiscIdUnique 310
letSIdKey = mkPreludeMiscIdUnique 311
noBindSIdKey = mkPreludeMiscIdUnique 312
parSIdKey = mkPreludeMiscIdUnique 313
+recSIdKey = mkPreludeMiscIdUnique 314
-- data Dec = ...
funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
@@ -869,7 +863,7 @@ funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey,
newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,
infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,
- patSynSigDIdKey, pragCompleteDIdKey :: Unique
+ patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey :: Unique
funDIdKey = mkPreludeMiscIdUnique 320
valDIdKey = mkPreludeMiscIdUnique 321
dataDIdKey = mkPreludeMiscIdUnique 322
@@ -901,144 +895,140 @@ defaultSigDIdKey = mkPreludeMiscIdUnique 347
patSynDIdKey = mkPreludeMiscIdUnique 348
patSynSigDIdKey = mkPreludeMiscIdUnique 349
pragCompleteDIdKey = mkPreludeMiscIdUnique 350
+implicitParamBindDIdKey = mkPreludeMiscIdUnique 351
-- type Cxt = ...
cxtIdKey :: Unique
-cxtIdKey = mkPreludeMiscIdUnique 351
+cxtIdKey = mkPreludeMiscIdUnique 361
-- data SourceUnpackedness = ...
noSourceUnpackednessKey, sourceNoUnpackKey, sourceUnpackKey :: Unique
-noSourceUnpackednessKey = mkPreludeMiscIdUnique 352
-sourceNoUnpackKey = mkPreludeMiscIdUnique 353
-sourceUnpackKey = mkPreludeMiscIdUnique 354
+noSourceUnpackednessKey = mkPreludeMiscIdUnique 362
+sourceNoUnpackKey = mkPreludeMiscIdUnique 363
+sourceUnpackKey = mkPreludeMiscIdUnique 364
-- data SourceStrictness = ...
noSourceStrictnessKey, sourceLazyKey, sourceStrictKey :: Unique
-noSourceStrictnessKey = mkPreludeMiscIdUnique 355
-sourceLazyKey = mkPreludeMiscIdUnique 356
-sourceStrictKey = mkPreludeMiscIdUnique 357
+noSourceStrictnessKey = mkPreludeMiscIdUnique 365
+sourceLazyKey = mkPreludeMiscIdUnique 366
+sourceStrictKey = mkPreludeMiscIdUnique 367
-- data Con = ...
normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey, gadtCIdKey,
recGadtCIdKey :: Unique
-normalCIdKey = mkPreludeMiscIdUnique 358
-recCIdKey = mkPreludeMiscIdUnique 359
-infixCIdKey = mkPreludeMiscIdUnique 360
-forallCIdKey = mkPreludeMiscIdUnique 361
-gadtCIdKey = mkPreludeMiscIdUnique 362
-recGadtCIdKey = mkPreludeMiscIdUnique 363
+normalCIdKey = mkPreludeMiscIdUnique 368
+recCIdKey = mkPreludeMiscIdUnique 369
+infixCIdKey = mkPreludeMiscIdUnique 370
+forallCIdKey = mkPreludeMiscIdUnique 371
+gadtCIdKey = mkPreludeMiscIdUnique 372
+recGadtCIdKey = mkPreludeMiscIdUnique 373
-- data Bang = ...
bangIdKey :: Unique
-bangIdKey = mkPreludeMiscIdUnique 364
+bangIdKey = mkPreludeMiscIdUnique 374
-- type BangType = ...
bangTKey :: Unique
-bangTKey = mkPreludeMiscIdUnique 365
+bangTKey = mkPreludeMiscIdUnique 375
-- type VarBangType = ...
varBangTKey :: Unique
-varBangTKey = mkPreludeMiscIdUnique 366
+varBangTKey = mkPreludeMiscIdUnique 376
-- data PatSynDir = ...
unidirPatSynIdKey, implBidirPatSynIdKey, explBidirPatSynIdKey :: Unique
-unidirPatSynIdKey = mkPreludeMiscIdUnique 367
-implBidirPatSynIdKey = mkPreludeMiscIdUnique 368
-explBidirPatSynIdKey = mkPreludeMiscIdUnique 369
+unidirPatSynIdKey = mkPreludeMiscIdUnique 377
+implBidirPatSynIdKey = mkPreludeMiscIdUnique 378
+explBidirPatSynIdKey = mkPreludeMiscIdUnique 379
-- data PatSynArgs = ...
prefixPatSynIdKey, infixPatSynIdKey, recordPatSynIdKey :: Unique
-prefixPatSynIdKey = mkPreludeMiscIdUnique 370
-infixPatSynIdKey = mkPreludeMiscIdUnique 371
-recordPatSynIdKey = mkPreludeMiscIdUnique 372
+prefixPatSynIdKey = mkPreludeMiscIdUnique 380
+infixPatSynIdKey = mkPreludeMiscIdUnique 381
+recordPatSynIdKey = mkPreludeMiscIdUnique 382
-- data Type = ...
forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey,
unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey, sigTIdKey,
- sigTDataConKey, equalityTIdKey, litTIdKey, promotedTIdKey,
+ equalityTIdKey, litTIdKey, promotedTIdKey,
promotedTupleTIdKey, promotedNilTIdKey, promotedConsTIdKey,
- wildCardTIdKey :: Unique
-forallTIdKey = mkPreludeMiscIdUnique 381
-varTIdKey = mkPreludeMiscIdUnique 382
-conTIdKey = mkPreludeMiscIdUnique 383
-tupleTIdKey = mkPreludeMiscIdUnique 384
-unboxedTupleTIdKey = mkPreludeMiscIdUnique 385
-unboxedSumTIdKey = mkPreludeMiscIdUnique 386
-arrowTIdKey = mkPreludeMiscIdUnique 387
-listTIdKey = mkPreludeMiscIdUnique 388
-appTIdKey = mkPreludeMiscIdUnique 389
-sigTIdKey = mkPreludeMiscIdUnique 390
-sigTDataConKey = mkPreludeMiscIdUnique 391
-equalityTIdKey = mkPreludeMiscIdUnique 392
-litTIdKey = mkPreludeMiscIdUnique 393
-promotedTIdKey = mkPreludeMiscIdUnique 394
-promotedTupleTIdKey = mkPreludeMiscIdUnique 395
-promotedNilTIdKey = mkPreludeMiscIdUnique 396
-promotedConsTIdKey = mkPreludeMiscIdUnique 397
-wildCardTIdKey = mkPreludeMiscIdUnique 398
+ wildCardTIdKey, implicitParamTIdKey :: Unique
+forallTIdKey = mkPreludeMiscIdUnique 391
+varTIdKey = mkPreludeMiscIdUnique 392
+conTIdKey = mkPreludeMiscIdUnique 393
+tupleTIdKey = mkPreludeMiscIdUnique 394
+unboxedTupleTIdKey = mkPreludeMiscIdUnique 395
+unboxedSumTIdKey = mkPreludeMiscIdUnique 396
+arrowTIdKey = mkPreludeMiscIdUnique 397
+listTIdKey = mkPreludeMiscIdUnique 398
+appTIdKey = mkPreludeMiscIdUnique 399
+sigTIdKey = mkPreludeMiscIdUnique 400
+equalityTIdKey = mkPreludeMiscIdUnique 401
+litTIdKey = mkPreludeMiscIdUnique 402
+promotedTIdKey = mkPreludeMiscIdUnique 403
+promotedTupleTIdKey = mkPreludeMiscIdUnique 404
+promotedNilTIdKey = mkPreludeMiscIdUnique 405
+promotedConsTIdKey = mkPreludeMiscIdUnique 406
+wildCardTIdKey = mkPreludeMiscIdUnique 407
+implicitParamTIdKey = mkPreludeMiscIdUnique 408
-- data TyLit = ...
numTyLitIdKey, strTyLitIdKey :: Unique
-numTyLitIdKey = mkPreludeMiscIdUnique 400
-strTyLitIdKey = mkPreludeMiscIdUnique 401
+numTyLitIdKey = mkPreludeMiscIdUnique 410
+strTyLitIdKey = mkPreludeMiscIdUnique 411
-- data TyVarBndr = ...
plainTVIdKey, kindedTVIdKey :: Unique
-plainTVIdKey = mkPreludeMiscIdUnique 402
-kindedTVIdKey = mkPreludeMiscIdUnique 403
+plainTVIdKey = mkPreludeMiscIdUnique 412
+kindedTVIdKey = mkPreludeMiscIdUnique 413
-- data Role = ...
nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique
-nominalRIdKey = mkPreludeMiscIdUnique 404
-representationalRIdKey = mkPreludeMiscIdUnique 405
-phantomRIdKey = mkPreludeMiscIdUnique 406
-inferRIdKey = mkPreludeMiscIdUnique 407
+nominalRIdKey = mkPreludeMiscIdUnique 414
+representationalRIdKey = mkPreludeMiscIdUnique 415
+phantomRIdKey = mkPreludeMiscIdUnique 416
+inferRIdKey = mkPreludeMiscIdUnique 417
-- data Kind = ...
varKIdKey, conKIdKey, tupleKIdKey, arrowKIdKey, listKIdKey, appKIdKey,
starKIdKey, constraintKIdKey :: Unique
-varKIdKey = mkPreludeMiscIdUnique 408
-conKIdKey = mkPreludeMiscIdUnique 409
-tupleKIdKey = mkPreludeMiscIdUnique 410
-arrowKIdKey = mkPreludeMiscIdUnique 411
-listKIdKey = mkPreludeMiscIdUnique 412
-appKIdKey = mkPreludeMiscIdUnique 413
-starKIdKey = mkPreludeMiscIdUnique 414
-constraintKIdKey = mkPreludeMiscIdUnique 415
+varKIdKey = mkPreludeMiscIdUnique 418
+conKIdKey = mkPreludeMiscIdUnique 419
+tupleKIdKey = mkPreludeMiscIdUnique 420
+arrowKIdKey = mkPreludeMiscIdUnique 421
+listKIdKey = mkPreludeMiscIdUnique 422
+appKIdKey = mkPreludeMiscIdUnique 423
+starKIdKey = mkPreludeMiscIdUnique 424
+constraintKIdKey = mkPreludeMiscIdUnique 425
-- data FamilyResultSig = ...
noSigIdKey, kindSigIdKey, tyVarSigIdKey :: Unique
-noSigIdKey = mkPreludeMiscIdUnique 416
-kindSigIdKey = mkPreludeMiscIdUnique 417
-tyVarSigIdKey = mkPreludeMiscIdUnique 418
+noSigIdKey = mkPreludeMiscIdUnique 426
+kindSigIdKey = mkPreludeMiscIdUnique 427
+tyVarSigIdKey = mkPreludeMiscIdUnique 428
-- data InjectivityAnn = ...
injectivityAnnIdKey :: Unique
-injectivityAnnIdKey = mkPreludeMiscIdUnique 419
+injectivityAnnIdKey = mkPreludeMiscIdUnique 429
-- data Callconv = ...
cCallIdKey, stdCallIdKey, cApiCallIdKey, primCallIdKey,
javaScriptCallIdKey :: Unique
-cCallIdKey = mkPreludeMiscIdUnique 420
-stdCallIdKey = mkPreludeMiscIdUnique 421
-cApiCallIdKey = mkPreludeMiscIdUnique 422
-primCallIdKey = mkPreludeMiscIdUnique 423
-javaScriptCallIdKey = mkPreludeMiscIdUnique 424
+cCallIdKey = mkPreludeMiscIdUnique 430
+stdCallIdKey = mkPreludeMiscIdUnique 431
+cApiCallIdKey = mkPreludeMiscIdUnique 432
+primCallIdKey = mkPreludeMiscIdUnique 433
+javaScriptCallIdKey = mkPreludeMiscIdUnique 434
-- data Safety = ...
unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique
-unsafeIdKey = mkPreludeMiscIdUnique 430
-safeIdKey = mkPreludeMiscIdUnique 431
-interruptibleIdKey = mkPreludeMiscIdUnique 432
+unsafeIdKey = mkPreludeMiscIdUnique 440
+safeIdKey = mkPreludeMiscIdUnique 441
+interruptibleIdKey = mkPreludeMiscIdUnique 442
-- data FunDep = ...
funDepIdKey :: Unique
-funDepIdKey = mkPreludeMiscIdUnique 440
-
--- data FamFlavour = ...
-typeFamIdKey, dataFamIdKey :: Unique
-typeFamIdKey = mkPreludeMiscIdUnique 450
-dataFamIdKey = mkPreludeMiscIdUnique 451
+funDepIdKey = mkPreludeMiscIdUnique 445
-- data TySynEqn = ...
tySynEqnIdKey :: Unique
@@ -1066,6 +1056,14 @@ moduleAnnotationIdKey = mkPreludeMiscIdUnique 492
derivClauseIdKey :: Unique
derivClauseIdKey = mkPreludeMiscIdUnique 493
+-- data DerivStrategy = ...
+stockStrategyIdKey, anyclassStrategyIdKey, newtypeStrategyIdKey,
+ viaStrategyIdKey :: Unique
+stockStrategyIdKey = mkPreludeDataConUnique 494
+anyclassStrategyIdKey = mkPreludeDataConUnique 495
+newtypeStrategyIdKey = mkPreludeDataConUnique 496
+viaStrategyIdKey = mkPreludeDataConUnique 497
+
{-
************************************************************************
* *
diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs
index 0732b5636d..c5af4a5121 100644
--- a/compiler/prelude/TysPrim.hs
+++ b/compiler/prelude/TysPrim.hs
@@ -30,7 +30,7 @@ module TysPrim(
tYPE, primRepToRuntimeRep,
funTyCon, funTyConName,
- primTyCons,
+ unexposedPrimTyCons, exposedPrimTyCons, primTyCons,
charPrimTyCon, charPrimTy, charPrimTyConName,
intPrimTyCon, intPrimTy, intPrimTyConName,
@@ -80,6 +80,8 @@ module TysPrim(
#include "HsVersions.h"
+import GhcPrelude
+
import {-# SOURCE #-} TysWiredIn
( runtimeRepTy, unboxedTupleKind, liftedTypeKind
, vecRepDataConTyCon, tupleRepDataConTyCon
@@ -94,7 +96,7 @@ import {-# SOURCE #-} TysWiredIn
, doubleElemRepDataConTy
, mkPromotedListTy )
-import Var ( TyVar, TyVarBndr(TvBndr), mkTyVar )
+import Var ( TyVar, VarBndr(Bndr), mkTyVar )
import Name
import TyCon
import SrcLoc
@@ -116,7 +118,22 @@ import Data.Char
-}
primTyCons :: [TyCon]
-primTyCons
+primTyCons = unexposedPrimTyCons ++ exposedPrimTyCons
+
+-- | Primitive 'TyCon's that are defined in "GHC.Prim" but not exposed.
+-- It's important to keep these separate as we don't want users to be able to
+-- write them (see Trac #15209) or see them in GHCi's @:browse@ output
+-- (see Trac #12023).
+unexposedPrimTyCons :: [TyCon]
+unexposedPrimTyCons
+ = [ eqPrimTyCon
+ , eqReprPrimTyCon
+ , eqPhantPrimTyCon
+ ]
+
+-- | Primitive 'TyCon's that are defined in, and exported from, "GHC.Prim".
+exposedPrimTyCons :: [TyCon]
+exposedPrimTyCons
= [ addrPrimTyCon
, arrayPrimTyCon
, byteArrayPrimTyCon
@@ -148,9 +165,6 @@ primTyCons
, wordPrimTyCon
, word32PrimTyCon
, word64PrimTyCon
- , eqPrimTyCon
- , eqReprPrimTyCon
- , eqPhantPrimTyCon
, tYPETyCon
@@ -326,7 +340,7 @@ openBetaTy = mkTyVarTy openBetaTyVar
-}
funTyConName :: Name
-funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon
+funTyConName = mkPrimTyConName (fsLit "->") funTyConKey funTyCon
-- | The @(->)@ type constructor.
--
@@ -337,8 +351,8 @@ funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon
funTyCon :: TyCon
funTyCon = mkFunTyCon funTyConName tc_bndrs tc_rep_nm
where
- tc_bndrs = [ TvBndr runtimeRep1TyVar (NamedTCB Inferred)
- , TvBndr runtimeRep2TyVar (NamedTCB Inferred)
+ tc_bndrs = [ Bndr runtimeRep1TyVar (NamedTCB Inferred)
+ , Bndr runtimeRep2TyVar (NamedTCB Inferred)
]
++ mkTemplateAnonTyConBinders [ tYPE runtimeRep1Ty
, tYPE runtimeRep2Ty
@@ -580,18 +594,19 @@ Note [The equality types story]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
GHC sports a veritable menagerie of equality types:
- Hetero? Levity Result Role Defining module
- ------------------------------------------------------------
- ~# hetero unlifted # nominal GHC.Prim
- ~~ hetero lifted Constraint nominal GHC.Types
- ~ homo lifted Constraint nominal Data.Type.Equality
- :~: homo lifted * nominal Data.Type.Equality
-
- ~R# hetero unlifted # repr GHC.Prim
- Coercible homo lifted Constraint repr GHC.Types
- Coercion homo lifted * repr Data.Type.Coercion
+ Type or Lifted? Hetero? Role Built in Defining module
+ class? L/U TyCon
+-----------------------------------------------------------------------------------------
+~# T U hetero nominal eqPrimTyCon GHC.Prim
+~~ C L hetero nominal heqTyCon GHC.Types
+~ C L homo nominal eqTyCon GHC.Types
+:~: T L homo nominal (not built-in) Data.Type.Equality
+:~~: T L hetero nominal (not built-in) Data.Type.Equality
- ~P# hetero unlifted phantom GHC.Prim
+~R# T U hetero repr eqReprPrimTy GHC.Prim
+Coercible C L homo repr coercibleTyCon GHC.Types
+Coercion T L homo repr (not built-in) Data.Type.Coercion
+~P# T U hetero phantom eqPhantPrimTyCon GHC.Prim
Recall that "hetero" means the equality can related types of different
kinds. Knowing that (t1 ~# t2) or (t1 ~R# t2) or even that (t1 ~P# t2)
@@ -627,6 +642,7 @@ This is (almost) an ordinary class, defined as if by
class a ~# b => a ~~ b
instance a ~# b => a ~~ b
Here's what's unusual about it:
+
* We can't actually declare it that way because we don't have syntax for ~#.
And ~# isn't a constraint, so even if we could write it, it wouldn't kind
check.
@@ -636,8 +652,8 @@ Here's what's unusual about it:
* It is "naturally coherent". This means that the solver won't hesitate to
solve a goal of type (a ~~ b) even if there is, say (Int ~~ c) in the
context. (Normally, it waits to learn more, just in case the given
- influences what happens next.) This is quite like having
- IncoherentInstances enabled.
+ influences what happens next.) See Note [Naturally coherent classes]
+ in TcInteract.
* It always terminates. That is, in the UndecidableInstances checks, we
don't worry if a (~~) constraint is too big, as we know that solving
@@ -656,28 +672,31 @@ Within GHC, ~~ is called heqTyCon, and it is defined in TysWiredIn.
--------------------------
(~) :: forall k. k -> k -> Constraint
--------------------------
-This is defined in Data.Type.Equality:
- class a ~~ b => (a :: k) ~ (b :: k)
- instance a ~~ b => a ~ b
-This is even more so an ordinary class than (~~), with the following exceptions:
- * Users cannot write instances of it.
+This is /exactly/ like (~~), except with a homogeneous kind.
+It is an almost-ordinary class defined as if by
+ class a ~# b => (a :: k) ~ (b :: k)
+ instance a ~# b => a ~ b
- * It is "naturally coherent". (See (~~).)
+ * All the bullets for (~~) apply
- * (~) is magical syntax, as ~ is a reserved symbol. It cannot be exported
- or imported.
+ * In addition (~) is magical syntax, as ~ is a reserved symbol.
+ It cannot be exported or imported.
- * It always terminates.
+Within GHC, ~ is called eqTyCon, and it is defined in TysWiredIn.
-Within GHC, ~ is called eqTyCon, and it is defined in PrelNames. Note that
-it is *not* wired in.
+Historical note: prior to July 18 (~) was defined as a
+ more-ordinary class with (~~) as a superclass. But that made it
+ special in different ways; and the extra superclass selections to
+ get from (~) to (~#) via (~~) were tiresome. Now it's defined
+ uniformly with (~~) and Coercible; much nicer.)
--------------------------
(:~:) :: forall k. k -> k -> *
+ (:~~:) :: forall k1 k2. k1 -> k2 -> *
--------------------------
-This is a perfectly ordinary GADT, wrapping (~). It is not defined within
-GHC at all.
+These are perfectly ordinary GADTs, wrapping (~) and (~~) resp.
+They are not defined within GHC at all.
--------------------------
diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs
index 28c6629a91..1d47185f02 100644
--- a/compiler/prelude/TysWiredIn.hs
+++ b/compiler/prelude/TysWiredIn.hs
@@ -29,9 +29,9 @@ module TysWiredIn (
-- * Ordering
orderingTyCon,
- ltDataCon, ltDataConId,
- eqDataCon, eqDataConId,
- gtDataCon, gtDataConId,
+ ordLTDataCon, ordLTDataConId,
+ ordEQDataCon, ordEQDataConId,
+ ordGTDataCon, ordGTDataConId,
promotedLTDataCon, promotedEQDataCon, promotedGTDataCon,
-- * Boxing primitive types
@@ -91,17 +91,12 @@ module TysWiredIn (
-- * Kinds
typeNatKindCon, typeNatKind, typeSymbolKindCon, typeSymbolKind,
isLiftedTypeKindTyConName, liftedTypeKind, constraintKind,
- starKindTyCon, starKindTyConName,
- unicodeStarKindTyCon, unicodeStarKindTyConName,
liftedTypeKindTyCon, constraintKindTyCon,
-
- -- * Parallel arrays
- mkPArrTy,
- parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon,
- parrTyCon_RDR, parrTyConName,
+ liftedTypeKindTyConName,
-- * Equality predicates
- heqTyCon, heqClass, heqDataCon,
+ heqTyCon, heqTyConName, heqClass, heqDataCon,
+ eqTyCon, eqTyConName, eqClass, eqDataCon, eqTyCon_RDR,
coercibleTyCon, coercibleTyConName, coercibleDataCon, coercibleClass,
-- * RuntimeRep and friends
@@ -128,6 +123,8 @@ module TysWiredIn (
#include "HsVersions.h"
#include "MachDeps.h"
+import GhcPrelude
+
import {-# SOURCE #-} MkId( mkDataConWorkId, mkDictSelId )
-- friends:
@@ -148,7 +145,7 @@ import TyCon
import Class ( Class, mkClass )
import RdrName
import Name
-import NameEnv ( NameEnv, mkNameEnv, lookupNameEnv )
+import NameEnv ( NameEnv, mkNameEnv, lookupNameEnv, lookupNameEnv_NF )
import NameSet ( NameSet, mkNameSet, elemNameSet )
import BasicTypes ( Arity, Boxity(..), TupleSort(..), ConTagZ,
SourceText(..) )
@@ -162,10 +159,6 @@ import Util
import BooleanFormula ( mkAnd )
import qualified Data.ByteString.Char8 as BS
-#if !MIN_VERSION_bytestring(0,10,8)
-import qualified Data.ByteString.Internal as BSI
-import qualified Data.ByteString.Unsafe as BSU
-#endif
alpha_tyvar :: [TyVar]
alpha_tyvar = [alphaTyVar]
@@ -222,8 +215,8 @@ wiredInTyCons = [ -- Units are not treated like other tuples, because then
, word8TyCon
, listTyCon
, maybeTyCon
- , parrTyCon
, heqTyCon
+ , eqTyCon
, coercibleTyCon
, typeNatKindCon
, typeSymbolKindCon
@@ -232,8 +225,6 @@ wiredInTyCons = [ -- Units are not treated like other tuples, because then
, vecElemTyCon
, constraintKindTyCon
, liftedTypeKindTyCon
- , starKindTyCon
- , unicodeStarKindTyCon
]
mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name
@@ -254,16 +245,26 @@ mkWiredInIdName mod fs uniq id
-- See Note [Kind-changing of (~) and Coercible]
-- in libraries/ghc-prim/GHC/Types.hs
+eqTyConName, eqDataConName, eqSCSelIdName :: Name
+eqTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "~") eqTyConKey eqTyCon
+eqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#") eqDataConKey eqDataCon
+eqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "eq_sel") eqSCSelIdKey eqSCSelId
+
+eqTyCon_RDR :: RdrName
+eqTyCon_RDR = nameRdrName eqTyConName
+
+-- See Note [Kind-changing of (~) and Coercible]
+-- in libraries/ghc-prim/GHC/Types.hs
heqTyConName, heqDataConName, heqSCSelIdName :: Name
heqTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "~~") heqTyConKey heqTyCon
-heqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#") heqDataConKey heqDataCon
-heqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "HEq_sc") heqSCSelIdKey heqSCSelId
+heqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "HEq#") heqDataConKey heqDataCon
+heqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "heq_sel") heqSCSelIdKey heqSCSelId
-- See Note [Kind-changing of (~) and Coercible] in libraries/ghc-prim/GHC/Types.hs
coercibleTyConName, coercibleDataConName, coercibleSCSelIdName :: Name
coercibleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Coercible") coercibleTyConKey coercibleTyCon
coercibleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "MkCoercible") coercibleDataConKey coercibleDataCon
-coercibleSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "Coercible_sc") coercibleSCSelIdKey coercibleSCSelId
+coercibleSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "coercible_sel") coercibleSCSelIdKey coercibleSCSelId
charTyConName, charDataConName, intTyConName, intDataConName :: Name
charTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Char") charTyConKey charTyCon
@@ -282,11 +283,11 @@ nilDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") ni
consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon
maybeTyConName, nothingDataConName, justDataConName :: Name
-maybeTyConName = mkWiredInTyConName UserSyntax gHC_BASE (fsLit "Maybe")
+maybeTyConName = mkWiredInTyConName UserSyntax gHC_MAYBE (fsLit "Maybe")
maybeTyConKey maybeTyCon
-nothingDataConName = mkWiredInDataConName UserSyntax gHC_BASE (fsLit "Nothing")
+nothingDataConName = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Nothing")
nothingDataConKey nothingDataCon
-justDataConName = mkWiredInDataConName UserSyntax gHC_BASE (fsLit "Just")
+justDataConName = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Just")
justDataConKey justDataCon
wordTyConName, wordDataConName, word8TyConName, word8DataConName :: Name
@@ -397,11 +398,8 @@ typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Symbol")
constraintKindTyConName :: Name
constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint") constraintKindTyConKey constraintKindTyCon
-liftedTypeKindTyConName, starKindTyConName, unicodeStarKindTyConName
- :: Name
+liftedTypeKindTyConName :: Name
liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type") liftedTypeKindTyConKey liftedTypeKindTyCon
-starKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "*") starKindTyConKey starKindTyCon
-unicodeStarKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "★") unicodeStarKindTyConKey unicodeStarKindTyCon
runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName :: Name
runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon
@@ -447,14 +445,8 @@ vecElemDataConNames = zipWith3Lazy mk_special_dc_name
mk_special_dc_name :: FastString -> Unique -> DataCon -> Name
mk_special_dc_name fs u dc = mkWiredInDataConName UserSyntax gHC_TYPES fs u dc
-parrTyConName, parrDataConName :: Name
-parrTyConName = mkWiredInTyConName BuiltInSyntax
- gHC_PARR' (fsLit "[::]") parrTyConKey parrTyCon
-parrDataConName = mkWiredInDataConName UserSyntax
- gHC_PARR' (fsLit "PArr") parrDataConKey parrDataCon
-
boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR,
- intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR :: RdrName
+ intDataCon_RDR, listTyCon_RDR, consDataCon_RDR :: RdrName
boolTyCon_RDR = nameRdrName boolTyConName
false_RDR = nameRdrName falseDataConName
true_RDR = nameRdrName trueDataConName
@@ -463,7 +455,6 @@ charTyCon_RDR = nameRdrName charTyConName
intDataCon_RDR = nameRdrName intDataConName
listTyCon_RDR = nameRdrName listTyConName
consDataCon_RDR = nameRdrName consDataConName
-parrTyCon_RDR = nameRdrName parrTyConName
{-
************************************************************************
@@ -473,31 +464,30 @@ parrTyCon_RDR = nameRdrName parrTyConName
************************************************************************
-}
-pcNonEnumTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
--- Not an enumeration
-pcNonEnumTyCon = pcTyCon False
-
-- This function assumes that the types it creates have all parameters at
-- Representational role, and that there is no kind polymorphism.
-pcTyCon :: Bool -> Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
-pcTyCon is_enum name cType tyvars cons
+pcTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
+pcTyCon name cType tyvars cons
= mkAlgTyCon name
(mkAnonTyConBinders tyvars)
liftedTypeKind
(map (const Representational) tyvars)
cType
[] -- No stupid theta
- (DataTyCon cons is_enum)
+ (mkDataTyConRhs cons)
(VanillaAlgTyCon (mkPrelTyConRepName name))
False -- Not in GADT syntax
pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon
-pcDataCon n univs = pcDataConWithFixity False n univs [] -- no ex_tvs
+pcDataCon n univs = pcDataConWithFixity False n univs
+ [] -- no ex_tvs
+ univs -- the univs are precisely the user-written tyvars
pcDataConWithFixity :: Bool -- ^ declared infix?
-> Name -- ^ datacon name
-> [TyVar] -- ^ univ tyvars
- -> [TyVar] -- ^ ex tyvars
+ -> [TyCoVar] -- ^ ex tycovars
+ -> [TyCoVar] -- ^ user-written tycovars
-> [Type] -- ^ args
-> TyCon
-> DataCon
@@ -511,24 +501,33 @@ pcDataConWithFixity infx n = pcDataConWithFixity' infx n (dataConWorkerUnique (n
-- one DataCon unique per pair of Ints.
pcDataConWithFixity' :: Bool -> Name -> Unique -> RuntimeRepInfo
- -> [TyVar] -> [TyVar]
+ -> [TyVar] -> [TyCoVar] -> [TyCoVar]
-> [Type] -> TyCon -> DataCon
-- The Name should be in the DataName name space; it's the name
-- of the DataCon itself.
-pcDataConWithFixity' declared_infix dc_name wrk_key rri tyvars ex_tyvars arg_tys tycon
+pcDataConWithFixity' declared_infix dc_name wrk_key rri
+ tyvars ex_tyvars user_tyvars arg_tys tycon
= data_con
where
+ tag_map = mkTyConTagMap tycon
+ -- This constructs the constructor Name to ConTag map once per
+ -- constructor, which is quadratic. It's OK here, because it's
+ -- only called for wired in data types that don't have a lot of
+ -- constructors. It's also likely that GHC will lift tag_map, since
+ -- we call pcDataConWithFixity' with static TyCons in the same module.
+ -- See Note [Constructor tag allocation] and #14657
data_con = mkDataCon dc_name declared_infix prom_info
(map (const no_bang) arg_tys)
[] -- No labelled fields
- (mkTyVarBinders Specified tyvars)
- (mkTyVarBinders Specified ex_tyvars)
+ tyvars ex_tyvars
+ (mkTyCoVarBinders Specified user_tyvars)
[] -- No equality spec
[] -- No theta
arg_tys (mkTyConApp tycon (mkTyVarTys tyvars))
rri
tycon
+ (lookupNameEnv_NF tag_map dc_name)
[] -- No stupid theta
(mkDataConWorkId wrk_name data_con)
NoDataConRep -- Wired-in types are too simple to need wrappers
@@ -554,7 +553,7 @@ mkDataConWorkerName data_con wrk_key =
pcSpecialDataCon :: Name -> [Type] -> TyCon -> RuntimeRepInfo -> DataCon
pcSpecialDataCon dc_name arg_tys tycon rri
= pcDataConWithFixity' False dc_name (dataConWorkerUnique (nameUnique dc_name)) rri
- [] [] arg_tys tycon
+ [] [] [] arg_tys tycon
{-
************************************************************************
@@ -567,16 +566,15 @@ pcSpecialDataCon dc_name arg_tys tycon rri
typeNatKindCon, typeSymbolKindCon :: TyCon
-- data Nat
-- data Symbol
-typeNatKindCon = pcTyCon False typeNatKindConName Nothing [] []
-typeSymbolKindCon = pcTyCon False typeSymbolKindConName Nothing [] []
+typeNatKindCon = pcTyCon typeNatKindConName Nothing [] []
+typeSymbolKindCon = pcTyCon typeSymbolKindConName Nothing [] []
typeNatKind, typeSymbolKind :: Kind
typeNatKind = mkTyConTy typeNatKindCon
typeSymbolKind = mkTyConTy typeSymbolKindCon
constraintKindTyCon :: TyCon
-constraintKindTyCon = pcTyCon False constraintKindTyConName
- Nothing [] []
+constraintKindTyCon = pcTyCon constraintKindTyConName Nothing [] []
liftedTypeKind, constraintKind :: Kind
liftedTypeKind = tYPE liftedRepTy
@@ -587,7 +585,7 @@ constraintKind = mkTyConApp constraintKindTyCon []
mkFunKind :: Kind -> Kind -> Kind
mkFunKind = mkFunTy
-mkForAllKind :: TyVar -> ArgFlag -> Kind -> Kind
+mkForAllKind :: TyCoVar -> ArgFlag -> Kind -> Kind
mkForAllKind = mkForAllTy
{-
@@ -623,12 +621,13 @@ Note [How tuples work] See also Note [Known-key names] in PrelNames
- Given constraints: the superclasses automatically become available
- Wanted constraints: there is a built-in instance
instance (c1,c2) => (c1,c2)
- - Currently just go up to 16; beyond that
+ See TcInteract.matchCTuple
+ - Currently just go up to 62; beyond that
you have to use manual nesting
- Their OccNames look like (%,,,%), so they can easily be
distinguished from term tuples. But (following Haskell) we
- pretty-print saturated constraint tuples with round parens; see
- BasicTypes.tupleParens.
+ pretty-print saturated constraint tuples with round parens;
+ see BasicTypes.tupleParens.
* In quite a lot of places things are restrcted just to
BoxedTuple/UnboxedTuple, and then we used BasicTypes.Boxity to distinguish
@@ -686,11 +685,12 @@ isBuiltInOcc_maybe occ =
"[]" -> Just $ choose_ns listTyConName nilDataConName
":" -> Just consDataConName
- "[::]" -> Just parrTyConName
+ -- equality tycon
+ "~" -> Just eqTyConName
-- boxed tuple data/tycon
"()" -> Just $ tup_name Boxed 0
- _ | Just rest <- "(" `stripPrefix` name
+ _ | Just rest <- "(" `BS.stripPrefix` name
, (commas, rest') <- BS.span (==',') rest
, ")" <- rest'
-> Just $ tup_name Boxed (1+BS.length commas)
@@ -698,21 +698,21 @@ isBuiltInOcc_maybe occ =
-- unboxed tuple data/tycon
"(##)" -> Just $ tup_name Unboxed 0
"Unit#" -> Just $ tup_name Unboxed 1
- _ | Just rest <- "(#" `stripPrefix` name
+ _ | Just rest <- "(#" `BS.stripPrefix` name
, (commas, rest') <- BS.span (==',') rest
, "#)" <- rest'
-> Just $ tup_name Unboxed (1+BS.length commas)
-- unboxed sum tycon
- _ | Just rest <- "(#" `stripPrefix` name
+ _ | Just rest <- "(#" `BS.stripPrefix` name
, (pipes, rest') <- BS.span (=='|') rest
, "#)" <- rest'
-> Just $ tyConName $ sumTyCon (1+BS.length pipes)
-- unboxed sum datacon
- _ | Just rest <- "(#" `stripPrefix` name
+ _ | Just rest <- "(#" `BS.stripPrefix` name
, (pipes1, rest') <- BS.span (=='|') rest
- , Just rest'' <- "_" `stripPrefix` rest'
+ , Just rest'' <- "_" `BS.stripPrefix` rest'
, (pipes2, rest''') <- BS.span (=='|') rest''
, "#)" <- rest'''
-> let arity = BS.length pipes1 + BS.length pipes2 + 1
@@ -720,15 +720,6 @@ isBuiltInOcc_maybe occ =
in Just $ dataConName $ sumDataCon alt arity
_ -> Nothing
where
- -- TODO: Drop when bytestring 0.10.8 can be assumed
-#if MIN_VERSION_bytestring(0,10,8)
- stripPrefix = BS.stripPrefix
-#else
- stripPrefix bs1@(BSI.PS _ _ l1) bs2
- | bs1 `BS.isPrefixOf` bs2 = Just (BSU.unsafeDrop l1 bs2)
- | otherwise = Nothing
-#endif
-
name = fastStringToByteString $ occNameFS occ
choose_ns :: Name -> Name -> Name
@@ -1015,16 +1006,34 @@ mk_sum arity = (tycon, sum_cons)
********************************************************************* -}
-- See Note [The equality types story] in TysPrim
--- (:~~: :: forall k1 k2 (a :: k1) (b :: k2). a -> b -> Constraint)
+-- ((~~) :: forall k1 k2 (a :: k1) (b :: k2). a -> b -> Constraint)
--
-- It's tempting to put functional dependencies on (~~), but it's not
-- necessary because the functional-dependency coverage check looks
-- through superclasses, and (~#) is handled in that check.
-heqTyCon, coercibleTyCon :: TyCon
-heqClass, coercibleClass :: Class
-heqDataCon, coercibleDataCon :: DataCon
-heqSCSelId, coercibleSCSelId :: Id
+eqTyCon, heqTyCon, coercibleTyCon :: TyCon
+eqClass, heqClass, coercibleClass :: Class
+eqDataCon, heqDataCon, coercibleDataCon :: DataCon
+eqSCSelId, heqSCSelId, coercibleSCSelId :: Id
+
+(eqTyCon, eqClass, eqDataCon, eqSCSelId)
+ = (tycon, klass, datacon, sc_sel_id)
+ where
+ tycon = mkClassTyCon eqTyConName binders roles
+ rhs klass
+ (mkPrelTyConRepName eqTyConName)
+ klass = mk_class tycon sc_pred sc_sel_id
+ datacon = pcDataCon eqDataConName tvs [sc_pred] tycon
+
+ -- Kind: forall k. k -> k -> Constraint
+ binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k])
+ roles = [Nominal, Nominal, Nominal]
+ rhs = mkDataTyConRhs [datacon]
+
+ tvs@[k,a,b] = binderVars binders
+ sc_pred = mkTyConApp eqPrimTyCon (mkTyVarTys [k,k,a,b])
+ sc_sel_id = mkDictSelId eqSCSelIdName klass
(heqTyCon, heqClass, heqDataCon, heqSCSelId)
= (tycon, klass, datacon, sc_sel_id)
@@ -1038,7 +1047,7 @@ heqSCSelId, coercibleSCSelId :: Id
-- Kind: forall k1 k2. k1 -> k2 -> Constraint
binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] (\ks -> ks)
roles = [Nominal, Nominal, Nominal, Nominal]
- rhs = DataTyCon { data_cons = [datacon], is_enum = False }
+ rhs = mkDataTyConRhs [datacon]
tvs = binderVars binders
sc_pred = mkTyConApp eqPrimTyCon (mkTyVarTys tvs)
@@ -1056,7 +1065,7 @@ heqSCSelId, coercibleSCSelId :: Id
-- Kind: forall k. k -> k -> Constraint
binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k])
roles = [Nominal, Representational, Representational]
- rhs = DataTyCon { data_cons = [datacon], is_enum = False }
+ rhs = mkDataTyConRhs [datacon]
tvs@[k,a,b] = binderVars binders
sc_pred = mkTyConApp eqReprPrimTyCon (mkTyVarTys [k, k, a, b])
@@ -1067,6 +1076,8 @@ mk_class tycon sc_pred sc_sel_id
= mkClass (tyConName tycon) (tyConTyVars tycon) [] [sc_pred] [sc_sel_id]
[] [] (mkAnd []) tycon
+
+
{- *********************************************************************
* *
Kinds and RuntimeRep
@@ -1078,27 +1089,15 @@ mk_class tycon sc_pred sc_sel_id
runtimeRepTy :: Type
runtimeRepTy = mkTyConTy runtimeRepTyCon
-liftedTypeKindTyCon, starKindTyCon, unicodeStarKindTyCon :: TyCon
-
-- Type synonyms; see Note [TYPE and RuntimeRep] in TysPrim
-- type Type = tYPE 'LiftedRep
--- type * = tYPE 'LiftedRep
--- type * = tYPE 'LiftedRep -- Unicode variant
-
+liftedTypeKindTyCon :: TyCon
liftedTypeKindTyCon = buildSynTyCon liftedTypeKindTyConName
[] liftedTypeKind []
(tYPE liftedRepTy)
-starKindTyCon = buildSynTyCon starKindTyConName
- [] liftedTypeKind []
- (tYPE liftedRepTy)
-
-unicodeStarKindTyCon = buildSynTyCon unicodeStarKindTyConName
- [] liftedTypeKind []
- (tYPE liftedRepTy)
-
runtimeRepTyCon :: TyCon
-runtimeRepTyCon = pcNonEnumTyCon runtimeRepTyConName Nothing []
+runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing []
(vecRepDataCon : tupleRepDataCon :
sumRepDataCon : runtimeRepSimpleDataCons)
@@ -1171,8 +1170,7 @@ liftedRepDataConTy, unliftedRepDataConTy,
= map (mkTyConTy . promoteDataCon) runtimeRepSimpleDataCons
vecCountTyCon :: TyCon
-vecCountTyCon = pcTyCon True vecCountTyConName Nothing []
- vecCountDataCons
+vecCountTyCon = pcTyCon vecCountTyConName Nothing [] vecCountDataCons
-- See Note [Wiring in RuntimeRep]
vecCountDataCons :: [DataCon]
@@ -1190,7 +1188,7 @@ vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,
vec64DataConTy] = map (mkTyConTy . promoteDataCon) vecCountDataCons
vecElemTyCon :: TyCon
-vecElemTyCon = pcTyCon True vecElemTyConName Nothing [] vecElemDataCons
+vecElemTyCon = pcTyCon vecElemTyConName Nothing [] vecElemDataCons
-- See Note [Wiring in RuntimeRep]
vecElemDataCons :: [DataCon]
@@ -1255,7 +1253,7 @@ charTy :: Type
charTy = mkTyConTy charTyCon
charTyCon :: TyCon
-charTyCon = pcNonEnumTyCon charTyConName
+charTyCon = pcTyCon charTyConName
(Just (CType NoSourceText Nothing
(NoSourceText,fsLit "HsChar")))
[] [charDataCon]
@@ -1269,7 +1267,7 @@ intTy :: Type
intTy = mkTyConTy intTyCon
intTyCon :: TyCon
-intTyCon = pcNonEnumTyCon intTyConName
+intTyCon = pcTyCon intTyConName
(Just (CType NoSourceText Nothing (NoSourceText,fsLit "HsInt")))
[] [intDataCon]
intDataCon :: DataCon
@@ -1279,7 +1277,7 @@ wordTy :: Type
wordTy = mkTyConTy wordTyCon
wordTyCon :: TyCon
-wordTyCon = pcNonEnumTyCon wordTyConName
+wordTyCon = pcTyCon wordTyConName
(Just (CType NoSourceText Nothing (NoSourceText, fsLit "HsWord")))
[] [wordDataCon]
wordDataCon :: DataCon
@@ -1289,10 +1287,10 @@ word8Ty :: Type
word8Ty = mkTyConTy word8TyCon
word8TyCon :: TyCon
-word8TyCon = pcNonEnumTyCon word8TyConName
- (Just (CType NoSourceText Nothing
- (NoSourceText, fsLit "HsWord8"))) []
- [word8DataCon]
+word8TyCon = pcTyCon word8TyConName
+ (Just (CType NoSourceText Nothing
+ (NoSourceText, fsLit "HsWord8"))) []
+ [word8DataCon]
word8DataCon :: DataCon
word8DataCon = pcDataCon word8DataConName [] [wordPrimTy] word8TyCon
@@ -1300,7 +1298,7 @@ floatTy :: Type
floatTy = mkTyConTy floatTyCon
floatTyCon :: TyCon
-floatTyCon = pcNonEnumTyCon floatTyConName
+floatTyCon = pcTyCon floatTyConName
(Just (CType NoSourceText Nothing
(NoSourceText, fsLit "HsFloat"))) []
[floatDataCon]
@@ -1311,7 +1309,7 @@ doubleTy :: Type
doubleTy = mkTyConTy doubleTyCon
doubleTyCon :: TyCon
-doubleTyCon = pcNonEnumTyCon doubleTyConName
+doubleTyCon = pcTyCon doubleTyConName
(Just (CType NoSourceText Nothing
(NoSourceText,fsLit "HsDouble"))) []
[doubleDataCon]
@@ -1373,7 +1371,7 @@ boolTy :: Type
boolTy = mkTyConTy boolTyCon
boolTyCon :: TyCon
-boolTyCon = pcTyCon True boolTyConName
+boolTyCon = pcTyCon boolTyConName
(Just (CType NoSourceText Nothing
(NoSourceText, fsLit "HsBool")))
[] [falseDataCon, trueDataCon]
@@ -1387,18 +1385,18 @@ falseDataConId = dataConWorkId falseDataCon
trueDataConId = dataConWorkId trueDataCon
orderingTyCon :: TyCon
-orderingTyCon = pcTyCon True orderingTyConName Nothing
- [] [ltDataCon, eqDataCon, gtDataCon]
+orderingTyCon = pcTyCon orderingTyConName Nothing
+ [] [ordLTDataCon, ordEQDataCon, ordGTDataCon]
-ltDataCon, eqDataCon, gtDataCon :: DataCon
-ltDataCon = pcDataCon ltDataConName [] [] orderingTyCon
-eqDataCon = pcDataCon eqDataConName [] [] orderingTyCon
-gtDataCon = pcDataCon gtDataConName [] [] orderingTyCon
+ordLTDataCon, ordEQDataCon, ordGTDataCon :: DataCon
+ordLTDataCon = pcDataCon ordLTDataConName [] [] orderingTyCon
+ordEQDataCon = pcDataCon ordEQDataConName [] [] orderingTyCon
+ordGTDataCon = pcDataCon ordGTDataConName [] [] orderingTyCon
-ltDataConId, eqDataConId, gtDataConId :: Id
-ltDataConId = dataConWorkId ltDataCon
-eqDataConId = dataConWorkId eqDataCon
-gtDataConId = dataConWorkId gtDataCon
+ordLTDataConId, ordEQDataConId, ordGTDataConId :: Id
+ordLTDataConId = dataConWorkId ordLTDataCon
+ordEQDataConId = dataConWorkId ordEQDataCon
+ordGTDataConId = dataConWorkId ordGTDataCon
{-
************************************************************************
@@ -1416,11 +1414,12 @@ mkListTy :: Type -> Type
mkListTy ty = mkTyConApp listTyCon [ty]
listTyCon :: TyCon
-listTyCon = buildAlgTyCon listTyConName alpha_tyvar [Representational]
- Nothing []
- (DataTyCon [nilDataCon, consDataCon] False )
- False
- (VanillaAlgTyCon $ mkPrelTyConRepName listTyConName)
+listTyCon =
+ buildAlgTyCon listTyConName alpha_tyvar [Representational]
+ Nothing []
+ (mkDataTyConRhs [nilDataCon, consDataCon])
+ False
+ (VanillaAlgTyCon $ mkPrelTyConRepName listTyConName)
nilDataCon :: DataCon
nilDataCon = pcDataCon nilDataConName alpha_tyvar [] listTyCon
@@ -1428,7 +1427,8 @@ nilDataCon = pcDataCon nilDataConName alpha_tyvar [] listTyCon
consDataCon :: DataCon
consDataCon = pcDataConWithFixity True {- Declared infix -}
consDataConName
- alpha_tyvar [] [alphaTy, mkTyConApp listTyCon alpha_ty] listTyCon
+ alpha_tyvar [] alpha_tyvar
+ [alphaTy, mkTyConApp listTyCon alpha_ty] listTyCon
-- Interesting: polymorphic recursion would help here.
-- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy
-- gets the over-specific type (Type -> Type)
@@ -1436,7 +1436,7 @@ consDataCon = pcDataConWithFixity True {- Declared infix -}
-- Wired-in type Maybe
maybeTyCon :: TyCon
-maybeTyCon = pcTyCon False maybeTyConName Nothing alpha_tyvar
+maybeTyCon = pcTyCon maybeTyConName Nothing alpha_tyvar
[nothingDataCon, justDataCon]
nothingDataCon :: DataCon
@@ -1500,7 +1500,7 @@ mkTupleTy :: Boxity -> [Type] -> Type
mkTupleTy Boxed [ty] = ty
mkTupleTy Boxed tys = mkTyConApp (tupleTyCon Boxed (length tys)) tys
mkTupleTy Unboxed tys = mkTyConApp (tupleTyCon Unboxed (length tys))
- (map (getRuntimeRep "mkTupleTy") tys ++ tys)
+ (map getRuntimeRep tys ++ tys)
-- | Build the type of a small tuple that holds the specified type of thing
mkBoxedTupleTy :: [Type] -> Type
@@ -1518,79 +1518,7 @@ unitTy = mkTupleTy Boxed []
mkSumTy :: [Type] -> Type
mkSumTy tys = mkTyConApp (sumTyCon (length tys))
- (map (getRuntimeRep "mkSumTy") tys ++ tys)
-
-{- *********************************************************************
-* *
- The parallel-array type, [::]
-* *
-************************************************************************
-
-Special syntax for parallel arrays needs some wired in definitions.
--}
-
--- | Construct a type representing the application of the parallel array constructor
-mkPArrTy :: Type -> Type
-mkPArrTy ty = mkTyConApp parrTyCon [ty]
-
--- | Represents the type constructor of parallel arrays
---
--- * This must match the definition in @PrelPArr@
---
--- NB: Although the constructor is given here, it will not be accessible in
--- user code as it is not in the environment of any compiled module except
--- @PrelPArr@.
---
-parrTyCon :: TyCon
-parrTyCon = pcNonEnumTyCon parrTyConName Nothing alpha_tyvar [parrDataCon]
-
-parrDataCon :: DataCon
-parrDataCon = pcDataCon
- parrDataConName
- alpha_tyvar -- forall'ed type variables
- [intTy, -- 1st argument: Int
- mkTyConApp -- 2nd argument: Array# a
- arrayPrimTyCon
- alpha_ty]
- parrTyCon
-
--- | Check whether a type constructor is the constructor for parallel arrays
-isPArrTyCon :: TyCon -> Bool
-isPArrTyCon tc = tyConName tc == parrTyConName
-
--- | Fake array constructors
---
--- * These constructors are never really used to represent array values;
--- however, they are very convenient during desugaring (and, in particular,
--- in the pattern matching compiler) to treat array pattern just like
--- yet another constructor pattern
---
-parrFakeCon :: Arity -> DataCon
-parrFakeCon i | i > mAX_TUPLE_SIZE = mkPArrFakeCon i -- build one specially
-parrFakeCon i = parrFakeConArr!i
-
--- pre-defined set of constructors
---
-parrFakeConArr :: Array Int DataCon
-parrFakeConArr = array (0, mAX_TUPLE_SIZE) [(i, mkPArrFakeCon i)
- | i <- [0..mAX_TUPLE_SIZE]]
-
--- build a fake parallel array constructor for the given arity
---
-mkPArrFakeCon :: Int -> DataCon
-mkPArrFakeCon arity = data_con
- where
- data_con = pcDataCon name [tyvar] tyvarTys parrTyCon
- tyvar = head alphaTyVars
- tyvarTys = replicate arity $ mkTyVarTy tyvar
- nameStr = mkFastString ("MkPArr" ++ show arity)
- name = mkWiredInName gHC_PARR' (mkDataOccFS nameStr) unique
- (AConLike (RealDataCon data_con)) UserSyntax
- unique = mkPArrDataConUnique arity
-
--- | Checks whether a data constructor is a fake constructor for parallel arrays
-isPArrFakeCon :: DataCon -> Bool
-isPArrFakeCon dcon = dcon == parrFakeCon (dataConSourceArity dcon)
+ (map getRuntimeRep tys ++ tys)
-- Promoted Booleans
@@ -1609,9 +1537,9 @@ promotedLTDataCon
, promotedEQDataCon
, promotedGTDataCon
:: TyCon
-promotedLTDataCon = promoteDataCon ltDataCon
-promotedEQDataCon = promoteDataCon eqDataCon
-promotedGTDataCon = promoteDataCon gtDataCon
+promotedLTDataCon = promoteDataCon ordLTDataCon
+promotedEQDataCon = promoteDataCon ordEQDataCon
+promotedGTDataCon = promoteDataCon ordGTDataCon
-- Promoted List
promotedConsDataCon, promotedNilDataCon :: TyCon
diff --git a/compiler/prelude/TysWiredIn.hs-boot b/compiler/prelude/TysWiredIn.hs-boot
index 26e42010c9..b777fa187b 100644
--- a/compiler/prelude/TysWiredIn.hs-boot
+++ b/compiler/prelude/TysWiredIn.hs-boot
@@ -12,6 +12,8 @@ listTyCon :: TyCon
typeNatKind, typeSymbolKind :: Type
mkBoxedTupleTy :: [Type] -> Type
+coercibleTyCon, heqTyCon :: TyCon
+
liftedTypeKind :: Kind
constraintKind :: Kind
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index 97ae89cb84..2f8ced7de8 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -38,6 +38,14 @@
-- processors of this file to easily get hold of simple info
-- (eg, out_of_line), whilst avoiding parsing complex expressions
-- needed for strictness info.
+--
+-- type refers to the general category of the primop. Valid settings include,
+--
+-- * Compare: A comparison operation of the shape a -> a -> Int#
+-- * Monadic: A unary operation of shape a -> a
+-- * Dyadic: A binary operation of shape a -> a -> a
+-- * GenPrimOp: Any other sort of primop
+--
-- The vector attribute is rather special. It takes a list of 3-tuples, each of
-- which is of the form <ELEM_TYPE,SCALAR_TYPE,LENGTH>. ELEM_TYPE is the type of
@@ -83,10 +91,11 @@ section "The word size story."
This is normally set based on the {\tt config.h} parameter
{\tt SIZEOF\_HSWORD}, i.e., 32 bits on 32-bit machines, 64
bits on 64-bit machines. However, it can also be explicitly
- set to a smaller number, e.g., 31 bits, to allow the
+ set to a smaller number than 64, e.g., 62 bits, to allow the
possibility of using tag bits. Currently GHC itself has only
- 32-bit and 64-bit variants, but 30 or 31-bit code can be
+ 32-bit and 64-bit variants, but 61, 62, or 63-bit code can be
exported as an external core file for use in other back ends.
+ 30 and 31-bit code is no longer supported.
GHC also implements a primitive unsigned integer type {\tt
Word\#} which always has the same number of bits as {\tt
@@ -97,7 +106,7 @@ section "The word size story."
arithmetic operations, comparisons, and a range of
conversions. The 8-bit and 16-bit sizes are always
represented as {\tt Int\#} and {\tt Word\#}, and the
- operations implemented in terms of the the primops on these
+ operations implemented in terms of the primops on these
types, with suitable range restrictions on the results (using
the {\tt narrow$n$Int\#} and {\tt narrow$n$Word\#} families
of primops. The 32-bit sizes are represented using {\tt
@@ -134,13 +143,8 @@ section "The word size story."
-- Define synonyms for indexing ops.
-#if WORD_SIZE_IN_BITS < 32
-#define INT32 Int32#
-#define WORD32 Word32#
-#else
#define INT32 Int#
#define WORD32 Word#
-#endif
#if WORD_SIZE_IN_BITS < 64
#define INT64 Int64#
@@ -176,7 +180,7 @@ primop OrdOp "ord#" GenPrimOp Char# -> Int#
------------------------------------------------------------------------
section "Int#"
- {Operations on native-size integers (30+ bits).}
+ {Operations on native-size integers (32+ bits).}
------------------------------------------------------------------------
primtype Int#
@@ -257,6 +261,7 @@ primop IntAddCOp "addIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #)
nonzero if overflow occurred (the sum is either too large
or too small to fit in an {\tt Int#}).}
with code_size = 2
+ commutable = True
primop IntSubCOp "subIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #)
{Subtract signed integers reporting overflow.
@@ -312,7 +317,7 @@ primop ISrlOp "uncheckedIShiftRL#" GenPrimOp Int# -> Int# -> Int#
------------------------------------------------------------------------
section "Word#"
- {Operations on native-sized unsigned words (30+ bits).}
+ {Operations on native-sized unsigned words (32+ bits).}
------------------------------------------------------------------------
primtype Word#
@@ -320,15 +325,25 @@ primtype Word#
primop WordAddOp "plusWord#" Dyadic Word# -> Word# -> Word#
with commutable = True
+primop WordAddCOp "addWordC#" GenPrimOp Word# -> Word# -> (# Word#, Int# #)
+ {Add unsigned integers reporting overflow.
+ The first element of the pair is the result. The second element is
+ the carry flag, which is nonzero on overflow. See also {\tt plusWord2#}.}
+ with code_size = 2
+ commutable = True
+
primop WordSubCOp "subWordC#" GenPrimOp Word# -> Word# -> (# Word#, Int# #)
{Subtract unsigned integers reporting overflow.
The first element of the pair is the result. The second element is
the carry flag, which is nonzero on overflow.}
+ with code_size = 2
--- Returns (# high, low #) (or equivalently, (# carry, low #))
-primop WordAdd2Op "plusWord2#" GenPrimOp
- Word# -> Word# -> (# Word#, Word# #)
- with commutable = True
+primop WordAdd2Op "plusWord2#" GenPrimOp Word# -> Word# -> (# Word#, Word# #)
+ {Add unsigned integers, with the high part (carry) in the first
+ component of the returned pair and the low part in the second
+ component of the pair. See also {\tt addWordC#}.}
+ with code_size = 2
+ commutable = True
primop WordSubOp "minusWord#" Dyadic Word# -> Word# -> Word#
@@ -395,6 +410,28 @@ primop PopCnt64Op "popCnt64#" GenPrimOp WORD64 -> Word#
primop PopCntOp "popCnt#" Monadic Word# -> Word#
{Count the number of set bits in a word.}
+primop Pdep8Op "pdep8#" Dyadic Word# -> Word# -> Word#
+ {Deposit bits to lower 8 bits of a word at locations specified by a mask.}
+primop Pdep16Op "pdep16#" Dyadic Word# -> Word# -> Word#
+ {Deposit bits to lower 16 bits of a word at locations specified by a mask.}
+primop Pdep32Op "pdep32#" Dyadic Word# -> Word# -> Word#
+ {Deposit bits to lower 32 bits of a word at locations specified by a mask.}
+primop Pdep64Op "pdep64#" GenPrimOp WORD64 -> WORD64 -> WORD64
+ {Deposit bits to a word at locations specified by a mask.}
+primop PdepOp "pdep#" Dyadic Word# -> Word# -> Word#
+ {Deposit bits to a word at locations specified by a mask.}
+
+primop Pext8Op "pext8#" Dyadic Word# -> Word# -> Word#
+ {Extract bits from lower 8 bits of a word at locations specified by a mask.}
+primop Pext16Op "pext16#" Dyadic Word# -> Word# -> Word#
+ {Extract bits from lower 16 bits of a word at locations specified by a mask.}
+primop Pext32Op "pext32#" Dyadic Word# -> Word# -> Word#
+ {Extract bits from lower 32 bits of a word at locations specified by a mask.}
+primop Pext64Op "pext64#" GenPrimOp WORD64 -> WORD64 -> WORD64
+ {Extract bits from a word at locations specified by a mask.}
+primop PextOp "pext#" Dyadic Word# -> Word# -> Word#
+ {Extract bits from a word at locations specified by a mask.}
+
primop Clz8Op "clz8#" Monadic Word# -> Word#
{Count leading zeros in the lower 8 bits of a word.}
primop Clz16Op "clz16#" Monadic Word# -> Word#
@@ -439,28 +476,6 @@ primop Narrow16WordOp "narrow16Word#" Monadic Word# -> Word#
primop Narrow32WordOp "narrow32Word#" Monadic Word# -> Word#
-#if WORD_SIZE_IN_BITS < 32
-------------------------------------------------------------------------
-section "Int32#"
- {Operations on 32-bit integers ({\tt Int32\#}). This type is only used
- if plain {\tt Int\#} has less than 32 bits. In any case, the operations
- are not primops; they are implemented (if needed) as ccalls instead.}
-------------------------------------------------------------------------
-
-primtype Int32#
-
-------------------------------------------------------------------------
-section "Word32#"
- {Operations on 32-bit unsigned words. This type is only used
- if plain {\tt Word\#} has less than 32 bits. In any case, the operations
- are not primops; they are implemented (if needed) as ccalls instead.}
-------------------------------------------------------------------------
-
-primtype Word32#
-
-#endif
-
-
#if WORD_SIZE_IN_BITS < 64
------------------------------------------------------------------------
section "Int64#"
@@ -603,6 +618,21 @@ primop DoubleTanhOp "tanhDouble#" Monadic
with
code_size = { primOpCodeSizeForeignCall }
+primop DoubleAsinhOp "asinhDouble#" Monadic
+ Double# -> Double#
+ with
+ code_size = { primOpCodeSizeForeignCall }
+
+primop DoubleAcoshOp "acoshDouble#" Monadic
+ Double# -> Double#
+ with
+ code_size = { primOpCodeSizeForeignCall }
+
+primop DoubleAtanhOp "atanhDouble#" Monadic
+ Double# -> Double#
+ with
+ code_size = { primOpCodeSizeForeignCall }
+
primop DoublePowerOp "**##" Dyadic
Double# -> Double# -> Double#
{Exponentiation.}
@@ -729,6 +759,21 @@ primop FloatTanhOp "tanhFloat#" Monadic
with
code_size = { primOpCodeSizeForeignCall }
+primop FloatAsinhOp "asinhFloat#" Monadic
+ Float# -> Float#
+ with
+ code_size = { primOpCodeSizeForeignCall }
+
+primop FloatAcoshOp "acoshFloat#" Monadic
+ Float# -> Float#
+ with
+ code_size = { primOpCodeSizeForeignCall }
+
+primop FloatAtanhOp "atanhFloat#" Monadic
+ Float# -> Float#
+ with
+ code_size = { primOpCodeSizeForeignCall }
+
primop FloatPowerOp "powerFloat#" Dyadic
Float# -> Float# -> Float#
with
@@ -788,8 +833,13 @@ primop SizeofMutableArrayOp "sizeofMutableArray#" GenPrimOp
primop IndexArrayOp "indexArray#" GenPrimOp
Array# a -> Int# -> (# a #)
- {Read from specified index of immutable array. Result is packaged into
- an unboxed singleton; the result itself is not yet evaluated.}
+ {Read from the specified index of an immutable array. The result is packaged
+ into an unboxed unary tuple; the result itself is not yet
+ evaluated. Pattern matching on the tuple forces the indexing of the
+ array to happen but does not evaluate the element itself. Evaluating
+ the thunk prevents additional thunks from building up on the
+ heap. Avoiding these thunks, in turn, reduces references to the
+ argument array, allowing it to be garbage collected more promptly.}
with
can_fail = True
@@ -1224,6 +1274,76 @@ primop IndexByteArrayOp_Word64 "indexWord64Array#" GenPrimOp
{Read 64-bit word; offset in 64-bit words.}
with can_fail = True
+primop IndexByteArrayOp_Word8AsChar "indexWord8ArrayAsChar#" GenPrimOp
+ ByteArray# -> Int# -> Char#
+ {Read 8-bit character; offset in bytes.}
+ with can_fail = True
+
+primop IndexByteArrayOp_Word8AsWideChar "indexWord8ArrayAsWideChar#" GenPrimOp
+ ByteArray# -> Int# -> Char#
+ {Read 31-bit character; offset in bytes.}
+ with can_fail = True
+
+primop IndexByteArrayOp_Word8AsAddr "indexWord8ArrayAsAddr#" GenPrimOp
+ ByteArray# -> Int# -> Addr#
+ {Read address; offset in bytes.}
+ with can_fail = True
+
+primop IndexByteArrayOp_Word8AsFloat "indexWord8ArrayAsFloat#" GenPrimOp
+ ByteArray# -> Int# -> Float#
+ {Read float; offset in bytes.}
+ with can_fail = True
+
+primop IndexByteArrayOp_Word8AsDouble "indexWord8ArrayAsDouble#" GenPrimOp
+ ByteArray# -> Int# -> Double#
+ {Read double; offset in bytes.}
+ with can_fail = True
+
+primop IndexByteArrayOp_Word8AsStablePtr "indexWord8ArrayAsStablePtr#" GenPrimOp
+ ByteArray# -> Int# -> StablePtr# a
+ {Read stable pointer; offset in bytes.}
+ with can_fail = True
+
+primop IndexByteArrayOp_Word8AsInt16 "indexWord8ArrayAsInt16#" GenPrimOp
+ ByteArray# -> Int# -> Int#
+ {Read 16-bit int; offset in bytes.}
+ with can_fail = True
+
+primop IndexByteArrayOp_Word8AsInt32 "indexWord8ArrayAsInt32#" GenPrimOp
+ ByteArray# -> Int# -> INT32
+ {Read 32-bit int; offset in bytes.}
+ with can_fail = True
+
+primop IndexByteArrayOp_Word8AsInt64 "indexWord8ArrayAsInt64#" GenPrimOp
+ ByteArray# -> Int# -> INT64
+ {Read 64-bit int; offset in bytes.}
+ with can_fail = True
+
+primop IndexByteArrayOp_Word8AsInt "indexWord8ArrayAsInt#" GenPrimOp
+ ByteArray# -> Int# -> Int#
+ {Read int; offset in bytes.}
+ with can_fail = True
+
+primop IndexByteArrayOp_Word8AsWord16 "indexWord8ArrayAsWord16#" GenPrimOp
+ ByteArray# -> Int# -> Word#
+ {Read 16-bit word; offset in bytes.}
+ with can_fail = True
+
+primop IndexByteArrayOp_Word8AsWord32 "indexWord8ArrayAsWord32#" GenPrimOp
+ ByteArray# -> Int# -> WORD32
+ {Read 32-bit word; offset in bytes.}
+ with can_fail = True
+
+primop IndexByteArrayOp_Word8AsWord64 "indexWord8ArrayAsWord64#" GenPrimOp
+ ByteArray# -> Int# -> WORD64
+ {Read 64-bit word; offset in bytes.}
+ with can_fail = True
+
+primop IndexByteArrayOp_Word8AsWord "indexWord8ArrayAsWord#" GenPrimOp
+ ByteArray# -> Int# -> Word#
+ {Read word; offset in bytes.}
+ with can_fail = True
+
primop ReadByteArrayOp_Char "readCharArray#" GenPrimOp
MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #)
{Read 8-bit character; offset in bytes.}
@@ -1238,7 +1358,7 @@ primop ReadByteArrayOp_WideChar "readWideCharArray#" GenPrimOp
primop ReadByteArrayOp_Int "readIntArray#" GenPrimOp
MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)
- {Read intger; offset in words.}
+ {Read integer; offset in words.}
with has_side_effects = True
can_fail = True
@@ -1308,6 +1428,76 @@ primop ReadByteArrayOp_Word64 "readWord64Array#" GenPrimOp
with has_side_effects = True
can_fail = True
+primop ReadByteArrayOp_Word8AsChar "readWord8ArrayAsChar#" GenPrimOp
+ MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #)
+ with has_side_effects = True
+ can_fail = True
+
+primop ReadByteArrayOp_Word8AsWideChar "readWord8ArrayAsWideChar#" GenPrimOp
+ MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #)
+ with has_side_effects = True
+ can_fail = True
+
+primop ReadByteArrayOp_Word8AsAddr "readWord8ArrayAsAddr#" GenPrimOp
+ MutableByteArray# s -> Int# -> State# s -> (# State# s, Addr# #)
+ with has_side_effects = True
+ can_fail = True
+
+primop ReadByteArrayOp_Word8AsFloat "readWord8ArrayAsFloat#" GenPrimOp
+ MutableByteArray# s -> Int# -> State# s -> (# State# s, Float# #)
+ with has_side_effects = True
+ can_fail = True
+
+primop ReadByteArrayOp_Word8AsDouble "readWord8ArrayAsDouble#" GenPrimOp
+ MutableByteArray# s -> Int# -> State# s -> (# State# s, Double# #)
+ with has_side_effects = True
+ can_fail = True
+
+primop ReadByteArrayOp_Word8AsStablePtr "readWord8ArrayAsStablePtr#" GenPrimOp
+ MutableByteArray# s -> Int# -> State# s -> (# State# s, StablePtr# a #)
+ with has_side_effects = True
+ can_fail = True
+
+primop ReadByteArrayOp_Word8AsInt16 "readWord8ArrayAsInt16#" GenPrimOp
+ MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)
+ with has_side_effects = True
+ can_fail = True
+
+primop ReadByteArrayOp_Word8AsInt32 "readWord8ArrayAsInt32#" GenPrimOp
+ MutableByteArray# s -> Int# -> State# s -> (# State# s, INT32 #)
+ with has_side_effects = True
+ can_fail = True
+
+primop ReadByteArrayOp_Word8AsInt64 "readWord8ArrayAsInt64#" GenPrimOp
+ MutableByteArray# s -> Int# -> State# s -> (# State# s, INT64 #)
+ with has_side_effects = True
+ can_fail = True
+
+primop ReadByteArrayOp_Word8AsInt "readWord8ArrayAsInt#" GenPrimOp
+ MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)
+ with has_side_effects = True
+ can_fail = True
+
+primop ReadByteArrayOp_Word8AsWord16 "readWord8ArrayAsWord16#" GenPrimOp
+ MutableByteArray# s -> Int# -> State# s -> (# State# s, Word# #)
+ with has_side_effects = True
+ can_fail = True
+
+primop ReadByteArrayOp_Word8AsWord32 "readWord8ArrayAsWord32#" GenPrimOp
+ MutableByteArray# s -> Int# -> State# s -> (# State# s, WORD32 #)
+ with has_side_effects = True
+ can_fail = True
+
+primop ReadByteArrayOp_Word8AsWord64 "readWord8ArrayAsWord64#" GenPrimOp
+ MutableByteArray# s -> Int# -> State# s -> (# State# s, WORD64 #)
+ with has_side_effects = True
+ can_fail = True
+
+primop ReadByteArrayOp_Word8AsWord "readWord8ArrayAsWord#" GenPrimOp
+ MutableByteArray# s -> Int# -> State# s -> (# State# s, Word# #)
+ with has_side_effects = True
+ can_fail = True
+
primop WriteByteArrayOp_Char "writeCharArray#" GenPrimOp
MutableByteArray# s -> Int# -> Char# -> State# s -> State# s
{Write 8-bit character; offset in bytes.}
@@ -1390,11 +1580,99 @@ primop WriteByteArrayOp_Word64 "writeWord64Array#" GenPrimOp
with has_side_effects = True
can_fail = True
+primop WriteByteArrayOp_Word8AsChar "writeWord8ArrayAsChar#" GenPrimOp
+ MutableByteArray# s -> Int# -> Char# -> State# s -> State# s
+ with has_side_effects = True
+ can_fail = True
+
+primop WriteByteArrayOp_Word8AsWideChar "writeWord8ArrayAsWideChar#" GenPrimOp
+ MutableByteArray# s -> Int# -> Char# -> State# s -> State# s
+ with has_side_effects = True
+ can_fail = True
+
+primop WriteByteArrayOp_Word8AsAddr "writeWord8ArrayAsAddr#" GenPrimOp
+ MutableByteArray# s -> Int# -> Addr# -> State# s -> State# s
+ with has_side_effects = True
+ can_fail = True
+
+primop WriteByteArrayOp_Word8AsFloat "writeWord8ArrayAsFloat#" GenPrimOp
+ MutableByteArray# s -> Int# -> Float# -> State# s -> State# s
+ with has_side_effects = True
+ can_fail = True
+
+primop WriteByteArrayOp_Word8AsDouble "writeWord8ArrayAsDouble#" GenPrimOp
+ MutableByteArray# s -> Int# -> Double# -> State# s -> State# s
+ with has_side_effects = True
+ can_fail = True
+
+primop WriteByteArrayOp_Word8AsStablePtr "writeWord8ArrayAsStablePtr#" GenPrimOp
+ MutableByteArray# s -> Int# -> StablePtr# a -> State# s -> State# s
+ with has_side_effects = True
+ can_fail = True
+
+primop WriteByteArrayOp_Word8AsInt16 "writeWord8ArrayAsInt16#" GenPrimOp
+ MutableByteArray# s -> Int# -> Int# -> State# s -> State# s
+ with has_side_effects = True
+ can_fail = True
+
+primop WriteByteArrayOp_Word8AsInt32 "writeWord8ArrayAsInt32#" GenPrimOp
+ MutableByteArray# s -> Int# -> INT32 -> State# s -> State# s
+ with has_side_effects = True
+ can_fail = True
+
+primop WriteByteArrayOp_Word8AsInt64 "writeWord8ArrayAsInt64#" GenPrimOp
+ MutableByteArray# s -> Int# -> INT64 -> State# s -> State# s
+ with has_side_effects = True
+ can_fail = True
+
+primop WriteByteArrayOp_Word8AsInt "writeWord8ArrayAsInt#" GenPrimOp
+ MutableByteArray# s -> Int# -> Int# -> State# s -> State# s
+ with has_side_effects = True
+ can_fail = True
+
+primop WriteByteArrayOp_Word8AsWord16 "writeWord8ArrayAsWord16#" GenPrimOp
+ MutableByteArray# s -> Int# -> Word# -> State# s -> State# s
+ with has_side_effects = True
+ can_fail = True
+
+primop WriteByteArrayOp_Word8AsWord32 "writeWord8ArrayAsWord32#" GenPrimOp
+ MutableByteArray# s -> Int# -> WORD32 -> State# s -> State# s
+ with has_side_effects = True
+ can_fail = True
+
+primop WriteByteArrayOp_Word8AsWord64 "writeWord8ArrayAsWord64#" GenPrimOp
+ MutableByteArray# s -> Int# -> WORD64 -> State# s -> State# s
+ with has_side_effects = True
+ can_fail = True
+
+primop WriteByteArrayOp_Word8AsWord "writeWord8ArrayAsWord#" GenPrimOp
+ MutableByteArray# s -> Int# -> Word# -> State# s -> State# s
+ with has_side_effects = True
+ can_fail = True
+
+primop CompareByteArraysOp "compareByteArrays#" GenPrimOp
+ ByteArray# -> Int# -> ByteArray# -> Int# -> Int# -> Int#
+ {{\tt compareByteArrays# src1 src1_ofs src2 src2_ofs n} compares
+ {\tt n} bytes starting at offset {\tt src1_ofs} in the first
+ {\tt ByteArray#} {\tt src1} to the range of {\tt n} bytes
+ (i.e. same length) starting at offset {\tt src2_ofs} of the second
+ {\tt ByteArray#} {\tt src2}. Both arrays must fully contain the
+ specified ranges, but this is not checked. Returns an {\tt Int#}
+ less than, equal to, or greater than zero if the range is found,
+ respectively, to be byte-wise lexicographically less than, to
+ match, or be greater than the second range.}
+ with
+ can_fail = True
+
primop CopyByteArrayOp "copyByteArray#" GenPrimOp
ByteArray# -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s
- {Copy a range of the ByteArray# to the specified region in the MutableByteArray#.
- Both arrays must fully contain the specified ranges, but this is not checked.
- The two arrays must not be the same array in different states, but this is not checked either.}
+ {{\tt copyByteArray# src src_ofs dst dst_ofs n} copies the range
+ starting at offset {\tt src_ofs} of length {\tt n} from the
+ {\tt ByteArray#} {\tt src} to the {\tt MutableByteArray#} {\tt dst}
+ starting at offset {\tt dst_ofs}. Both arrays must fully contain
+ the specified ranges, but this is not checked. The two arrays must
+ not be the same array in different states, but this is not checked
+ either.}
with
has_side_effects = True
code_size = { primOpCodeSizeForeignCall + 4}
@@ -1402,7 +1680,7 @@ primop CopyByteArrayOp "copyByteArray#" GenPrimOp
primop CopyMutableByteArrayOp "copyMutableByteArray#" GenPrimOp
MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s
- {Copy a range of the first MutableByteArray# to the specified region in the second MutableByteArray#.
+ {Copy a range of the first MutableByteArray\# to the specified region in the second MutableByteArray\#.
Both arrays must fully contain the specified ranges, but this is not checked. The regions are
allowed to overlap, although this is only possible when the same array is provided
as both the source and the destination.}
@@ -1413,10 +1691,10 @@ primop CopyMutableByteArrayOp "copyMutableByteArray#" GenPrimOp
primop CopyByteArrayToAddrOp "copyByteArrayToAddr#" GenPrimOp
ByteArray# -> Int# -> Addr# -> Int# -> State# s -> State# s
- {Copy a range of the ByteArray# to the memory range starting at the Addr#.
- The ByteArray# and the memory region at Addr# must fully contain the
- specified ranges, but this is not checked. The Addr# must not point into the
- ByteArray# (e.g. if the ByteArray# were pinned), but this is not checked
+ {Copy a range of the ByteArray\# to the memory range starting at the Addr\#.
+ The ByteArray\# and the memory region at Addr\# must fully contain the
+ specified ranges, but this is not checked. The Addr\# must not point into the
+ ByteArray\# (e.g. if the ByteArray\# were pinned), but this is not checked
either.}
with
has_side_effects = True
@@ -1425,10 +1703,10 @@ primop CopyByteArrayToAddrOp "copyByteArrayToAddr#" GenPrimOp
primop CopyMutableByteArrayToAddrOp "copyMutableByteArrayToAddr#" GenPrimOp
MutableByteArray# s -> Int# -> Addr# -> Int# -> State# s -> State# s
- {Copy a range of the MutableByteArray# to the memory range starting at the
- Addr#. The MutableByteArray# and the memory region at Addr# must fully
- contain the specified ranges, but this is not checked. The Addr# must not
- point into the MutableByteArray# (e.g. if the MutableByteArray# were
+ {Copy a range of the MutableByteArray\# to the memory range starting at the
+ Addr\#. The MutableByteArray\# and the memory region at Addr\# must fully
+ contain the specified ranges, but this is not checked. The Addr\# must not
+ point into the MutableByteArray\# (e.g. if the MutableByteArray\# were
pinned), but this is not checked either.}
with
has_side_effects = True
@@ -1437,10 +1715,10 @@ primop CopyMutableByteArrayToAddrOp "copyMutableByteArrayToAddr#" GenPrimOp
primop CopyAddrToByteArrayOp "copyAddrToByteArray#" GenPrimOp
Addr# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s
- {Copy a memory range starting at the Addr# to the specified range in the
- MutableByteArray#. The memory region at Addr# and the ByteArray# must fully
- contain the specified ranges, but this is not checked. The Addr# must not
- point into the MutableByteArray# (e.g. if the MutableByteArray# were pinned),
+ {Copy a memory range starting at the Addr\# to the specified range in the
+ MutableByteArray\#. The memory region at Addr\# and the ByteArray\# must fully
+ contain the specified ranges, but this is not checked. The Addr\# must not
+ point into the MutableByteArray\# (e.g. if the MutableByteArray\# were pinned),
but this is not checked either.}
with
has_side_effects = True
@@ -1620,7 +1898,7 @@ primop WriteArrayArrayOp_MutableArrayArray "writeMutableArrayArrayArray#" GenPr
primop CopyArrayArrayOp "copyArrayArray#" GenPrimOp
ArrayArray# -> Int# -> MutableArrayArray# s -> Int# -> Int# -> State# s -> State# s
- {Copy a range of the ArrayArray# to the specified region in the MutableArrayArray#.
+ {Copy a range of the ArrayArray\# to the specified region in the MutableArrayArray\#.
Both arrays must fully contain the specified ranges, but this is not checked.
The two arrays must not be the same array in different states, but this is not checked either.}
with
@@ -1950,25 +2228,37 @@ primop WriteMutVarOp "writeMutVar#" GenPrimOp
primop SameMutVarOp "sameMutVar#" GenPrimOp
MutVar# s a -> MutVar# s a -> Int#
--- Note [Why not an unboxed tuple in atomicModifyMutVar#?]
+-- Note [Why not an unboxed tuple in atomicModifyMutVar2#?]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
--- Looking at the type of atomicModifyMutVar#, one might wonder why
+-- Looking at the type of atomicModifyMutVar2#, one might wonder why
-- it doesn't return an unboxed tuple. e.g.,
--
--- MutVar# s a -> (a -> (# a, b #)) -> State# s -> (# State# s, b #)
+-- MutVar# s a -> (a -> (# a, b #)) -> State# s -> (# State# s, a, (# a, b #) #)
--
--- The reason is that atomicModifyMutVar# relies on laziness for its atomicity.
--- Given a MutVar# containing x, atomicModifyMutVar# merely replaces the
+-- The reason is that atomicModifyMutVar2# relies on laziness for its atomicity.
+-- Given a MutVar# containing x, atomicModifyMutVar2# merely replaces
-- its contents with a thunk of the form (fst (f x)). This can be done using an
-- atomic compare-and-swap as it is merely replacing a pointer.
-primop AtomicModifyMutVarOp "atomicModifyMutVar#" GenPrimOp
- MutVar# s a -> (a -> b) -> State# s -> (# State# s, c #)
- { Modify the contents of a {\tt MutVar\#}. Note that this isn't strictly
- speaking the correct type for this function, it should really be
- {\tt MutVar# s a -> (a -> (a,b)) -> State# s -> (# State# s, b #)}, however
- we don't know about pairs here. }
+primop AtomicModifyMutVar2Op "atomicModifyMutVar2#" GenPrimOp
+ MutVar# s a -> (a -> c) -> State# s -> (# State# s, a, c #)
+ { Modify the contents of a {\tt MutVar\#}, returning the previous
+ contents and the result of applying the given function to the
+ previous contents. Note that this isn't strictly
+ speaking the correct type for this function; it should really be
+ {\tt MutVar\# s a -> (a -> (a,b)) -> State\# s -> (\# State\# s, a, (a, b) \#)},
+ but we don't know about pairs here. }
+ with
+ out_of_line = True
+ has_side_effects = True
+ can_fail = True
+
+primop AtomicModifyMutVar_Op "atomicModifyMutVar_#" GenPrimOp
+ MutVar# s a -> (a -> a) -> State# s -> (# State# s, a, a #)
+ { Modify the contents of a {\tt MutVar\#}, returning the previous
+ contents and the result of applying the given function to the
+ previous contents. }
with
out_of_line = True
has_side_effects = True
@@ -2094,7 +2384,7 @@ primop AtomicallyOp "atomically#" GenPrimOp
out_of_line = True
has_side_effects = True
--- NB: retry#'s strictness information specifies it to return bottom.
+-- NB: retry#'s strictness information specifies it to throw an exception
-- This lets the compiler perform some extra simplifications, since retry#
-- will technically never return.
--
@@ -2104,10 +2394,13 @@ primop AtomicallyOp "atomically#" GenPrimOp
-- with:
-- retry# s1
-- where 'e' would be unreachable anyway. See Trac #8091.
+--
+-- Note that it *does not* return botRes as the "exception" that is thrown may be
+-- "caught" by catchRetry#. This mistake caused #14171.
primop RetryOp "retry#" GenPrimOp
State# RealWorld -> (# State# RealWorld, a #)
with
- strictness = { \ _arity -> mkClosedStrictSig [topDmd] botRes }
+ strictness = { \ _arity -> mkClosedStrictSig [topDmd] exnRes }
out_of_line = True
has_side_effects = True
@@ -2116,7 +2409,7 @@ primop CatchRetryOp "catchRetry#" GenPrimOp
-> (State# RealWorld -> (# State# RealWorld, a #) )
-> (State# RealWorld -> (# State# RealWorld, a #) )
with
- strictness = { \ _arity -> mkClosedStrictSig [ catchArgDmd
+ strictness = { \ _arity -> mkClosedStrictSig [ lazyApply1Dmd
, lazyApply1Dmd
, topDmd ] topRes }
-- See Note [Strictness for mask/unmask/catch]
@@ -2135,13 +2428,6 @@ primop CatchSTMOp "catchSTM#" GenPrimOp
out_of_line = True
has_side_effects = True
-primop Check "check#" GenPrimOp
- (State# RealWorld -> (# State# RealWorld, a #) )
- -> (State# RealWorld -> State# RealWorld)
- with
- out_of_line = True
- has_side_effects = True
-
primop NewTVarOp "newTVar#" GenPrimOp
a
-> State# s -> (# State# s, TVar# s a #)
@@ -2352,7 +2638,6 @@ primop YieldOp "yield#" GenPrimOp
primop MyThreadIdOp "myThreadId#" GenPrimOp
State# RealWorld -> (# State# RealWorld, ThreadId# #)
with
- out_of_line = True
has_side_effects = True
primop LabelThreadOp "labelThread#" GenPrimOp
@@ -2505,13 +2790,13 @@ primop CompactResizeOp "compactResize#" GenPrimOp
primop CompactContainsOp "compactContains#" GenPrimOp
Compact# -> a -> State# RealWorld -> (# State# RealWorld, Int# #)
- { Returns 1# if the object is contained in the compact, 0# otherwise. }
+ { Returns 1\# if the object is contained in the compact, 0\# otherwise. }
with
out_of_line = True
primop CompactContainsAnyOp "compactContainsAny#" GenPrimOp
a -> State# RealWorld -> (# State# RealWorld, Int# #)
- { Returns 1# if the object is in any compact at all, 0# otherwise. }
+ { Returns 1\# if the object is in any compact at all, 0\# otherwise. }
with
out_of_line = True
@@ -2592,7 +2877,7 @@ section "Unsafe pointer equality"
primop ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp
a -> a -> Int#
- { Returns 1# if the given pointers are equal and 0# otherwise. }
+ { Returns {\texttt 1\#} if the given pointers are equal and {\texttt 0\#} otherwise. }
with
can_fail = True -- See Note [reallyUnsafePtrEquality#]
@@ -2647,13 +2932,7 @@ primop SparkOp "spark#" GenPrimOp
primop SeqOp "seq#" GenPrimOp
a -> State# s -> (# State# s, a #)
-
- -- why return the value? So that we can control sharing of seq'd
- -- values: in
- -- let x = e in x `seq` ... x ...
- -- we don't want to inline x, so better to represent it as
- -- let x = e in case seq# x RW of (# _, x' #) -> ... x' ...
- -- also it matches the type of rseq in the Eval monad.
+ -- See Note [seq# magic] in PrelRules
primop GetSparkOp "getSpark#" GenPrimOp
State# s -> (# State# s, Int#, a #)
@@ -2675,7 +2954,7 @@ section "Tag to enum stuff"
------------------------------------------------------------------------
primop DataToTagOp "dataToTag#" GenPrimOp
- a -> Int#
+ a -> Int# -- Zero-indexed; the first constructor has tag zero
with
can_fail = True -- See Note [dataToTag#]
strictness = { \ _arity -> mkClosedStrictSig [evalDmd] topRes }
@@ -2699,7 +2978,7 @@ binder-swap on the case, to give
\z. case x of y -> let v = dataToTag# x in ...
Now FloatOut might float that v-binding outside the \z. But that is
-bad because that might mean x gest evaluated much too early! (CorePrep
+bad because that might mean x gets evaluated much too early! (CorePrep
adds an eval to a dataToTag# call, to ensure that the argument really is
evaluated; see CorePrep Note [dataToTag magic].)
@@ -2759,12 +3038,11 @@ primop NewBCOOp "newBCO#" GenPrimOp
out_of_line = True
primop UnpackClosureOp "unpackClosure#" GenPrimOp
- a -> (# Addr#, Array# b, ByteArray# #)
- { {\tt unpackClosure\# closure} copies non-pointers and pointers in the
+ a -> (# Addr#, ByteArray#, Array# b #)
+ { {\tt unpackClosure\# closure} copies the closure and pointers in the
payload of the given closure into two new arrays, and returns a pointer to
- the first word of the closure's info table, a pointer array for the
- pointers in the payload, and a non-pointer array for the non-pointers in
- the payload. }
+ the first word of the closure's info table, a non-pointer array for the raw
+ bytes of the closure, and a pointer array for the pointers in the payload. }
with
out_of_line = True
@@ -2785,7 +3063,7 @@ primop GetCurrentCCSOp "getCurrentCCS#" GenPrimOp
a -> State# s -> (# State# s, Addr# #)
{ Returns the current {\tt CostCentreStack} (value is {\tt NULL} if
not profiling). Takes a dummy argument which can be used to
- avoid the call to {\tt getCCCS\#} being floated out by the
+ avoid the call to {\tt getCurrentCCS\#} being floated out by the
simplifier, which would result in an uninformative stack
("CAF"). }
@@ -2817,8 +3095,9 @@ pseudoop "proxy#"
pseudoop "seq"
a -> b -> b
{ The value of {\tt seq a b} is bottom if {\tt a} is bottom, and
- otherwise equal to {\tt b}. {\tt seq} is usually introduced to
- improve performance by avoiding unneeded laziness.
+ otherwise equal to {\tt b}. In other words, it evaluates the first
+ argument {\tt a} to weak head normal form (WHNF). {\tt seq} is usually
+ introduced to improve performance by avoiding unneeded laziness.
A note on evaluation order: the expression {\tt seq a b} does
{\it not} guarantee that {\tt a} will be evaluated before {\tt b}.
@@ -2857,7 +3136,7 @@ pseudoop "unsafeCoerce#"
{\tt unsafeCoerce\#} to cast a T to an algebraic data type D, unless T is also
an algebraic data type. For example, do not cast {\tt Int->Int} to {\tt Bool}, even if
you later cast that {\tt Bool} back to {\tt Int->Int} before applying it. The reasons
- have to do with GHC's internal representation details (for the congnoscenti, data values
+ have to do with GHC's internal representation details (for the cognoscenti, data values
can be entered but function closures cannot). If you want a safe type to cast things
to, use {\tt Any}, which is not an algebraic data type.
@@ -2875,22 +3154,46 @@ primop TraceEventOp "traceEvent#" GenPrimOp
Addr# -> State# s -> State# s
{ Emits an event via the RTS tracing framework. The contents
of the event is the zero-terminated byte string passed as the first
- argument. The event will be emitted either to the .eventlog file,
+ argument. The event will be emitted either to the {\tt .eventlog} file,
or to stderr, depending on the runtime RTS flags. }
with
has_side_effects = True
out_of_line = True
+primop TraceEventBinaryOp "traceBinaryEvent#" GenPrimOp
+ Addr# -> Int# -> State# s -> State# s
+ { Emits an event via the RTS tracing framework. The contents
+ of the event is the binary object passed as the first argument with
+ the the given length passed as the second argument. The event will be
+ emitted to the {\tt .eventlog} file. }
+ with
+ has_side_effects = True
+ out_of_line = True
+
primop TraceMarkerOp "traceMarker#" GenPrimOp
Addr# -> State# s -> State# s
{ Emits a marker event via the RTS tracing framework. The contents
of the event is the zero-terminated byte string passed as the first
- argument. The event will be emitted either to the .eventlog file,
+ argument. The event will be emitted either to the {\tt .eventlog} file,
or to stderr, depending on the runtime RTS flags. }
with
has_side_effects = True
out_of_line = True
+primop GetThreadAllocationCounter "getThreadAllocationCounter#" GenPrimOp
+ State# RealWorld -> (# State# RealWorld, INT64 #)
+ { Retrieves the allocation counter for the current thread. }
+ with
+ has_side_effects = True
+ out_of_line = True
+
+primop SetThreadAllocationCounter "setThreadAllocationCounter#" GenPrimOp
+ INT64 -> State# RealWorld -> State# RealWorld
+ { Sets the allocation counter for the current thread to the given value. }
+ with
+ has_side_effects = True
+ out_of_line = True
+
------------------------------------------------------------------------
section "Safe coercions"
------------------------------------------------------------------------
View Lorry Controller Status