summaryrefslogtreecommitdiff
path: root/compiler/prelude
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/prelude')
-rw-r--r--compiler/prelude/PrelNames.lhs120
-rw-r--r--compiler/prelude/PrelRules.lhs387
-rw-r--r--compiler/prelude/PrimOp.lhs15
-rw-r--r--compiler/prelude/TysPrim.lhs89
-rw-r--r--compiler/prelude/TysWiredIn.lhs4
-rw-r--r--compiler/prelude/primops.txt.pp148
6 files changed, 418 insertions, 345 deletions
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 19acf488e0..3e5384bc5f 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -233,13 +233,13 @@ basicKnownKeyNames
-- Strings and lists
unpackCStringName,
unpackCStringFoldrName, unpackCStringUtf8Name,
-
+
-- Overloaded lists
isListClassName,
fromListName,
fromListNName,
toListName,
-
+
-- List operations
concatName, filterName, mapName,
zipName, foldrName, buildName, augmentName, appendName,
@@ -265,11 +265,11 @@ basicKnownKeyNames
plusIntegerName, timesIntegerName, smallIntegerName,
wordToIntegerName,
integerToWordName, integerToIntName, minusIntegerName,
- negateIntegerName, eqIntegerName, neqIntegerName,
+ negateIntegerName, eqIntegerPrimName, neqIntegerPrimName,
absIntegerName, signumIntegerName,
- leIntegerName, gtIntegerName, ltIntegerName, geIntegerName,
+ leIntegerPrimName, gtIntegerPrimName, ltIntegerPrimName, geIntegerPrimName,
compareIntegerName, quotRemIntegerName, divModIntegerName,
- quotIntegerName, remIntegerName,
+ quotIntegerName, remIntegerName, divIntegerName, modIntegerName,
floatFromIntegerName, doubleFromIntegerName,
encodeFloatIntegerName, encodeDoubleIntegerName,
decodeDoubleIntegerName,
@@ -350,8 +350,7 @@ genericTyConNames = [
pRELUDE :: Module
pRELUDE = mkBaseModule_ pRELUDE_NAME
-gHC_PRIM, gHC_TYPES, gHC_GENERICS,
- gHC_MAGIC,
+gHC_PRIM, gHC_PRIMWRAPPERS, 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_LIST,
gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, dATA_MONOID,
@@ -364,6 +363,7 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS,
cONTROL_EXCEPTION_BASE, gHC_TYPELITS, gHC_IP :: Module
gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values
+gHC_PRIMWRAPPERS = mkPrimModule (fsLit "GHC.PrimWrappers")
gHC_TYPES = mkPrimModule (fsLit "GHC.Types")
gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic")
gHC_CSTRING = mkPrimModule (fsLit "GHC.CString")
@@ -558,9 +558,8 @@ unpackCString_RDR = nameRdrName unpackCStringName
unpackCStringFoldr_RDR = nameRdrName unpackCStringFoldrName
unpackCStringUtf8_RDR = nameRdrName unpackCStringUtf8Name
-newStablePtr_RDR, wordDataCon_RDR :: RdrName
+newStablePtr_RDR :: RdrName
newStablePtr_RDR = nameRdrName newStablePtrName
-wordDataCon_RDR = dataQual_RDR gHC_TYPES (fsLit "W#")
bindIO_RDR, returnIO_RDR :: RdrName
bindIO_RDR = nameRdrName bindIOName
@@ -617,11 +616,12 @@ punc_RDR = dataQual_RDR lEX (fsLit "Punc")
ident_RDR = dataQual_RDR lEX (fsLit "Ident")
symbol_RDR = dataQual_RDR lEX (fsLit "Symbol")
-step_RDR, alt_RDR, reset_RDR, prec_RDR :: RdrName
+step_RDR, alt_RDR, reset_RDR, prec_RDR, pfail_RDR :: RdrName
step_RDR = varQual_RDR rEAD_PREC (fsLit "step")
alt_RDR = varQual_RDR rEAD_PREC (fsLit "+++")
reset_RDR = varQual_RDR rEAD_PREC (fsLit "reset")
prec_RDR = varQual_RDR rEAD_PREC (fsLit "prec")
+pfail_RDR = varQual_RDR rEAD_PREC (fsLit "pfail")
showList_RDR, showList___RDR, showsPrec_RDR, showString_RDR,
showSpace_RDR, showParen_RDR :: RdrName
@@ -798,10 +798,6 @@ stringTyConName = tcQual gHC_BASE (fsLit "String") stringTyConKey
inlineIdName :: Name
inlineIdName = varQual gHC_MAGIC (fsLit "inline") inlineIdKey
--- The 'undefined' function. Used by supercompilation.
-undefinedName :: Name
-undefinedName = varQual gHC_ERR (fsLit "undefined") undefinedKey
-
-- Base classes (Eq, Ord, Functor)
fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name
eqClassName = clsQual gHC_CLASSES (fsLit "Eq") eqClassKey
@@ -885,11 +881,11 @@ integerTyConName, mkIntegerName,
plusIntegerName, timesIntegerName, smallIntegerName,
wordToIntegerName,
integerToWordName, integerToIntName, minusIntegerName,
- negateIntegerName, eqIntegerName, neqIntegerName,
+ negateIntegerName, eqIntegerPrimName, neqIntegerPrimName,
absIntegerName, signumIntegerName,
- leIntegerName, gtIntegerName, ltIntegerName, geIntegerName,
+ leIntegerPrimName, gtIntegerPrimName, ltIntegerPrimName, geIntegerPrimName,
compareIntegerName, quotRemIntegerName, divModIntegerName,
- quotIntegerName, remIntegerName,
+ quotIntegerName, remIntegerName, divIntegerName, modIntegerName,
floatFromIntegerName, doubleFromIntegerName,
encodeFloatIntegerName, encodeDoubleIntegerName,
decodeDoubleIntegerName,
@@ -910,19 +906,21 @@ integerToWordName = varQual gHC_INTEGER_TYPE (fsLit "integerToWord") int
integerToIntName = varQual gHC_INTEGER_TYPE (fsLit "integerToInt") integerToIntIdKey
minusIntegerName = varQual gHC_INTEGER_TYPE (fsLit "minusInteger") minusIntegerIdKey
negateIntegerName = varQual gHC_INTEGER_TYPE (fsLit "negateInteger") negateIntegerIdKey
-eqIntegerName = varQual gHC_INTEGER_TYPE (fsLit "eqInteger") eqIntegerIdKey
-neqIntegerName = varQual gHC_INTEGER_TYPE (fsLit "neqInteger") neqIntegerIdKey
+eqIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "eqInteger#") eqIntegerPrimIdKey
+neqIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "neqInteger#") neqIntegerPrimIdKey
absIntegerName = varQual gHC_INTEGER_TYPE (fsLit "absInteger") absIntegerIdKey
signumIntegerName = varQual gHC_INTEGER_TYPE (fsLit "signumInteger") signumIntegerIdKey
-leIntegerName = varQual gHC_INTEGER_TYPE (fsLit "leInteger") leIntegerIdKey
-gtIntegerName = varQual gHC_INTEGER_TYPE (fsLit "gtInteger") gtIntegerIdKey
-ltIntegerName = varQual gHC_INTEGER_TYPE (fsLit "ltInteger") ltIntegerIdKey
-geIntegerName = varQual gHC_INTEGER_TYPE (fsLit "geInteger") geIntegerIdKey
+leIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "leInteger#") leIntegerPrimIdKey
+gtIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "gtInteger#") gtIntegerPrimIdKey
+ltIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "ltInteger#") ltIntegerPrimIdKey
+geIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "geInteger#") geIntegerPrimIdKey
compareIntegerName = varQual gHC_INTEGER_TYPE (fsLit "compareInteger") compareIntegerIdKey
quotRemIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotRemInteger") quotRemIntegerIdKey
divModIntegerName = varQual gHC_INTEGER_TYPE (fsLit "divModInteger") divModIntegerIdKey
quotIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotInteger") quotIntegerIdKey
remIntegerName = varQual gHC_INTEGER_TYPE (fsLit "remInteger") remIntegerIdKey
+divIntegerName = varQual gHC_INTEGER_TYPE (fsLit "divInteger") divIntegerIdKey
+modIntegerName = varQual gHC_INTEGER_TYPE (fsLit "modInteger") modIntegerIdKey
floatFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "floatFromInteger") floatFromIntegerIdKey
doubleFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "doubleFromInteger") doubleFromIntegerIdKey
encodeFloatIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeFloatInteger") encodeFloatIntegerIdKey
@@ -1336,11 +1334,13 @@ statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey,
word32PrimTyConKey, word32TyConKey, word64PrimTyConKey, word64TyConKey,
liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey,
typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey,
- funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey :: Unique
+ funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey,
+ eqReprPrimTyConKey :: Unique
statePrimTyConKey = mkPreludeTyConUnique 50
stableNamePrimTyConKey = mkPreludeTyConUnique 51
stableNameTyConKey = mkPreludeTyConUnique 52
eqPrimTyConKey = mkPreludeTyConUnique 53
+eqReprPrimTyConKey = mkPreludeTyConUnique 54
mutVarPrimTyConKey = mkPreludeTyConUnique 55
ioTyConKey = mkPreludeTyConUnique 56
wordPrimTyConKey = mkPreludeTyConUnique 58
@@ -1594,10 +1594,10 @@ mkIntegerIdKey, smallIntegerIdKey, wordToIntegerIdKey,
word64ToIntegerIdKey, int64ToIntegerIdKey,
plusIntegerIdKey, timesIntegerIdKey, minusIntegerIdKey,
negateIntegerIdKey,
- eqIntegerIdKey, neqIntegerIdKey, absIntegerIdKey, signumIntegerIdKey,
- leIntegerIdKey, gtIntegerIdKey, ltIntegerIdKey, geIntegerIdKey,
+ eqIntegerPrimIdKey, neqIntegerPrimIdKey, absIntegerIdKey, signumIntegerIdKey,
+ leIntegerPrimIdKey, gtIntegerPrimIdKey, ltIntegerPrimIdKey, geIntegerPrimIdKey,
compareIntegerIdKey, quotRemIntegerIdKey, divModIntegerIdKey,
- quotIntegerIdKey, remIntegerIdKey,
+ quotIntegerIdKey, remIntegerIdKey, divIntegerIdKey, modIntegerIdKey,
floatFromIntegerIdKey, doubleFromIntegerIdKey,
encodeFloatIntegerIdKey, encodeDoubleIntegerIdKey,
decodeDoubleIntegerIdKey,
@@ -1614,44 +1614,46 @@ plusIntegerIdKey = mkPreludeMiscIdUnique 66
timesIntegerIdKey = mkPreludeMiscIdUnique 67
minusIntegerIdKey = mkPreludeMiscIdUnique 68
negateIntegerIdKey = mkPreludeMiscIdUnique 69
-eqIntegerIdKey = mkPreludeMiscIdUnique 70
-neqIntegerIdKey = mkPreludeMiscIdUnique 71
+eqIntegerPrimIdKey = mkPreludeMiscIdUnique 70
+neqIntegerPrimIdKey = mkPreludeMiscIdUnique 71
absIntegerIdKey = mkPreludeMiscIdUnique 72
signumIntegerIdKey = mkPreludeMiscIdUnique 73
-leIntegerIdKey = mkPreludeMiscIdUnique 74
-gtIntegerIdKey = mkPreludeMiscIdUnique 75
-ltIntegerIdKey = mkPreludeMiscIdUnique 76
-geIntegerIdKey = mkPreludeMiscIdUnique 77
+leIntegerPrimIdKey = mkPreludeMiscIdUnique 74
+gtIntegerPrimIdKey = mkPreludeMiscIdUnique 75
+ltIntegerPrimIdKey = mkPreludeMiscIdUnique 76
+geIntegerPrimIdKey = mkPreludeMiscIdUnique 77
compareIntegerIdKey = mkPreludeMiscIdUnique 78
-quotRemIntegerIdKey = mkPreludeMiscIdUnique 79
-divModIntegerIdKey = mkPreludeMiscIdUnique 80
-quotIntegerIdKey = mkPreludeMiscIdUnique 81
-remIntegerIdKey = mkPreludeMiscIdUnique 82
-floatFromIntegerIdKey = mkPreludeMiscIdUnique 83
-doubleFromIntegerIdKey = mkPreludeMiscIdUnique 84
-encodeFloatIntegerIdKey = mkPreludeMiscIdUnique 85
-encodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 86
-gcdIntegerIdKey = mkPreludeMiscIdUnique 87
-lcmIntegerIdKey = mkPreludeMiscIdUnique 88
-andIntegerIdKey = mkPreludeMiscIdUnique 89
-orIntegerIdKey = mkPreludeMiscIdUnique 90
-xorIntegerIdKey = mkPreludeMiscIdUnique 91
-complementIntegerIdKey = mkPreludeMiscIdUnique 92
-shiftLIntegerIdKey = mkPreludeMiscIdUnique 93
-shiftRIntegerIdKey = mkPreludeMiscIdUnique 94
-wordToIntegerIdKey = mkPreludeMiscIdUnique 95
-word64ToIntegerIdKey = mkPreludeMiscIdUnique 96
-int64ToIntegerIdKey = mkPreludeMiscIdUnique 97
-decodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 98
+quotIntegerIdKey = mkPreludeMiscIdUnique 79
+remIntegerIdKey = mkPreludeMiscIdUnique 80
+divIntegerIdKey = mkPreludeMiscIdUnique 81
+modIntegerIdKey = mkPreludeMiscIdUnique 82
+divModIntegerIdKey = mkPreludeMiscIdUnique 83
+quotRemIntegerIdKey = mkPreludeMiscIdUnique 84
+floatFromIntegerIdKey = mkPreludeMiscIdUnique 85
+doubleFromIntegerIdKey = mkPreludeMiscIdUnique 86
+encodeFloatIntegerIdKey = mkPreludeMiscIdUnique 87
+encodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 88
+gcdIntegerIdKey = mkPreludeMiscIdUnique 89
+lcmIntegerIdKey = mkPreludeMiscIdUnique 90
+andIntegerIdKey = mkPreludeMiscIdUnique 91
+orIntegerIdKey = mkPreludeMiscIdUnique 92
+xorIntegerIdKey = mkPreludeMiscIdUnique 93
+complementIntegerIdKey = mkPreludeMiscIdUnique 94
+shiftLIntegerIdKey = mkPreludeMiscIdUnique 95
+shiftRIntegerIdKey = mkPreludeMiscIdUnique 96
+wordToIntegerIdKey = mkPreludeMiscIdUnique 97
+word64ToIntegerIdKey = mkPreludeMiscIdUnique 98
+int64ToIntegerIdKey = mkPreludeMiscIdUnique 99
+decodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 100
rootMainKey, runMainKey :: Unique
-rootMainKey = mkPreludeMiscIdUnique 100
-runMainKey = mkPreludeMiscIdUnique 101
+rootMainKey = mkPreludeMiscIdUnique 101
+runMainKey = mkPreludeMiscIdUnique 102
thenIOIdKey, lazyIdKey, assertErrorIdKey :: Unique
-thenIOIdKey = mkPreludeMiscIdUnique 102
-lazyIdKey = mkPreludeMiscIdUnique 103
-assertErrorIdKey = mkPreludeMiscIdUnique 104
+thenIOIdKey = mkPreludeMiscIdUnique 103
+lazyIdKey = mkPreludeMiscIdUnique 104
+assertErrorIdKey = mkPreludeMiscIdUnique 105
breakpointIdKey, breakpointCondIdKey, breakpointAutoIdKey,
breakpointJumpIdKey, breakpointCondJumpIdKey,
@@ -1690,6 +1692,8 @@ checkDotnetResNameIdKey = mkPreludeMiscIdUnique 154
undefinedKey :: Unique
undefinedKey = mkPreludeMiscIdUnique 155
+magicSingIKey :: Unique
+magicSingIKey = mkPreludeMiscIdUnique 156
\end{code}
Certain class operations from Prelude classes. They get their own
diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index 079ab0cc98..64a9f9b912 100644
--- a/compiler/prelude/PrelRules.lhs
+++ b/compiler/prelude/PrelRules.lhs
@@ -20,17 +20,18 @@ module PrelRules ( primOpRules, builtinRules ) where
#include "HsVersions.h"
#include "../includes/MachDeps.h"
-import {-# SOURCE #-} MkId ( mkPrimOpId )
+import {-# SOURCE #-} MkId ( mkPrimOpId, magicSingIId )
import CoreSyn
import MkCore
import Id
+import Var (setVarType)
import Literal
import CoreSubst ( exprIsLiteral_maybe )
import PrimOp ( PrimOp(..), tagToEnumKey )
import TysWiredIn
import TysPrim
-import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
+import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon, unwrapNewTyCon_maybe )
import DataCon ( dataConTag, dataConTyCon, dataConWorkId )
import CoreUtils ( cheapEqExpr, exprIsHNF )
import CoreUnfold ( exprIsConApp_maybe )
@@ -46,6 +47,7 @@ import BasicTypes
import DynFlags
import Platform
import Util
+import Coercion (mkUnbranchedAxInstCo,mkSymCo,Role(..))
import Control.Monad
import Data.Bits as Bits
@@ -195,7 +197,8 @@ primOpRules nm FloatAddOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+))
primOpRules nm FloatSubOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-))
, rightIdentity zerof ]
primOpRules nm FloatMulOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*))
- , identity onef ]
+ , identity onef
+ , strengthReduction twof FloatAddOp ]
-- zeroElem zerof doesn't hold because of NaN
primOpRules nm FloatDivOp = mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/))
, rightIdentity onef ]
@@ -208,7 +211,8 @@ primOpRules nm DoubleAddOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+))
primOpRules nm DoubleSubOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-))
, rightIdentity zerod ]
primOpRules nm DoubleMulOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*))
- , identity oned ]
+ , identity oned
+ , strengthReduction twod DoubleAddOp ]
-- zeroElem zerod doesn't hold because of NaN
primOpRules nm DoubleDivOp = mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/))
, rightIdentity oned ]
@@ -216,6 +220,7 @@ primOpRules nm DoubleNegOp = mkPrimOpRule nm 1 [ unaryLit negOp
, inversePrimOp DoubleNegOp ]
-- Relational operators
+
primOpRules nm IntEqOp = mkRelOpRule nm (==) [ litEq True ]
primOpRules nm IntNeOp = mkRelOpRule nm (/=) [ litEq False ]
primOpRules nm CharEqOp = mkRelOpRule nm (==) [ litEq True ]
@@ -231,19 +236,19 @@ primOpRules nm CharGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ]
primOpRules nm CharLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ]
primOpRules nm CharLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ]
-primOpRules nm FloatGtOp = mkRelOpRule nm (>) []
-primOpRules nm FloatGeOp = mkRelOpRule nm (>=) []
-primOpRules nm FloatLeOp = mkRelOpRule nm (<=) []
-primOpRules nm FloatLtOp = mkRelOpRule nm (<) []
-primOpRules nm FloatEqOp = mkRelOpRule nm (==) [ litEq True ]
-primOpRules nm FloatNeOp = mkRelOpRule nm (/=) [ litEq False ]
+primOpRules nm FloatGtOp = mkFloatingRelOpRule nm (>) []
+primOpRules nm FloatGeOp = mkFloatingRelOpRule nm (>=) []
+primOpRules nm FloatLeOp = mkFloatingRelOpRule nm (<=) []
+primOpRules nm FloatLtOp = mkFloatingRelOpRule nm (<) []
+primOpRules nm FloatEqOp = mkFloatingRelOpRule nm (==) [ litEq True ]
+primOpRules nm FloatNeOp = mkFloatingRelOpRule nm (/=) [ litEq False ]
-primOpRules nm DoubleGtOp = mkRelOpRule nm (>) []
-primOpRules nm DoubleGeOp = mkRelOpRule nm (>=) []
-primOpRules nm DoubleLeOp = mkRelOpRule nm (<=) []
-primOpRules nm DoubleLtOp = mkRelOpRule nm (<) []
-primOpRules nm DoubleEqOp = mkRelOpRule nm (==) [ litEq True ]
-primOpRules nm DoubleNeOp = mkRelOpRule nm (/=) [ litEq False ]
+primOpRules nm DoubleGtOp = mkFloatingRelOpRule nm (>) []
+primOpRules nm DoubleGeOp = mkFloatingRelOpRule nm (>=) []
+primOpRules nm DoubleLeOp = mkFloatingRelOpRule nm (<=) []
+primOpRules nm DoubleLtOp = mkFloatingRelOpRule nm (<) []
+primOpRules nm DoubleEqOp = mkFloatingRelOpRule nm (==) [ litEq True ]
+primOpRules nm DoubleNeOp = mkFloatingRelOpRule nm (/=) [ litEq False ]
primOpRules nm WordGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ]
primOpRules nm WordGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ]
@@ -278,14 +283,27 @@ mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
mkRelOpRule nm cmp extra
= mkPrimOpRule nm 2 $ rules ++ extra
where
- rules = [ binaryLit (\_ -> cmpOp cmp)
- , equalArgs >>
+ rules = [ binaryCmpLit cmp
+ , do equalArgs
-- x `cmp` x does not depend on x, so
-- compute it for the arbitrary value 'True'
-- and use that result
- return (if cmp True True
- then trueVal
- else falseVal) ]
+ dflags <- getDynFlags
+ return (if cmp True True
+ then trueValInt dflags
+ else falseValInt dflags) ]
+
+-- Note [Rules for floating-point comparisons]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- We need different rules for floating-point values because for floats
+-- it is not true that x = x. The special case when this does not occur
+-- are NaNs.
+
+mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
+ -> [RuleM CoreExpr] -> Maybe CoreRule
+mkFloatingRelOpRule nm cmp extra -- See Note [Rules for floating-point comparisons]
+ = mkPrimOpRule nm 2 $ binaryCmpLit cmp : extra
-- common constants
zeroi, onei, zerow, onew :: DynFlags -> Literal
@@ -294,18 +312,20 @@ onei dflags = mkMachInt dflags 1
zerow dflags = mkMachWord dflags 0
onew dflags = mkMachWord dflags 1
-zerof, onef, zerod, oned :: Literal
+zerof, onef, twof, zerod, oned, twod :: Literal
zerof = mkMachFloat 0.0
onef = mkMachFloat 1.0
+twof = mkMachFloat 2.0
zerod = mkMachDouble 0.0
oned = mkMachDouble 1.0
+twod = mkMachDouble 2.0
-cmpOp :: (forall a . Ord a => a -> a -> Bool)
+cmpOp :: DynFlags -> (forall a . Ord a => a -> a -> Bool)
-> Literal -> Literal -> Maybe CoreExpr
-cmpOp cmp = go
+cmpOp dflags cmp = go
where
- done True = Just trueVal
- done False = Just falseVal
+ done True = Just $ trueValInt dflags
+ done False = Just $ falseValInt dflags
-- These compares are at different types
go (MachChar i1) (MachChar i2) = done (i1 `cmp` i2)
@@ -402,19 +422,22 @@ litEq :: Bool -- True <=> equality, False <=> inequality
-> RuleM CoreExpr
litEq is_eq = msum
[ do [Lit lit, expr] <- getArgs
- do_lit_eq lit expr
+ dflags <- getDynFlags
+ do_lit_eq dflags lit expr
, do [expr, Lit lit] <- getArgs
- do_lit_eq lit expr ]
+ dflags <- getDynFlags
+ do_lit_eq dflags lit expr ]
where
- do_lit_eq lit expr = do
+ do_lit_eq dflags lit expr = do
guard (not (litIsLifted lit))
- return (mkWildCase expr (literalType lit) boolTy
+ return (mkWildCase expr (literalType lit) intPrimTy
[(DEFAULT, [], val_if_neq),
(LitAlt lit, [], val_if_eq)])
- val_if_eq | is_eq = trueVal
- | otherwise = falseVal
- val_if_neq | is_eq = falseVal
- | otherwise = trueVal
+ where
+ val_if_eq | is_eq = trueValInt dflags
+ | otherwise = falseValInt dflags
+ val_if_neq | is_eq = falseValInt dflags
+ | otherwise = trueValInt dflags
-- | Check if there is comparison with minBound or maxBound, that is
@@ -429,14 +452,14 @@ boundsCmp op = do
data Comparison = Gt | Ge | Lt | Le
mkRuleFn :: DynFlags -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr
-mkRuleFn dflags Gt (Lit lit) _ | isMinBound dflags lit = Just falseVal
-mkRuleFn dflags Le (Lit lit) _ | isMinBound dflags lit = Just trueVal
-mkRuleFn dflags Ge _ (Lit lit) | isMinBound dflags lit = Just trueVal
-mkRuleFn dflags Lt _ (Lit lit) | isMinBound dflags lit = Just falseVal
-mkRuleFn dflags Ge (Lit lit) _ | isMaxBound dflags lit = Just trueVal
-mkRuleFn dflags Lt (Lit lit) _ | isMaxBound dflags lit = Just falseVal
-mkRuleFn dflags Gt _ (Lit lit) | isMaxBound dflags lit = Just falseVal
-mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just trueVal
+mkRuleFn dflags Gt (Lit lit) _ | isMinBound dflags lit = Just $ falseValInt dflags
+mkRuleFn dflags Le (Lit lit) _ | isMinBound dflags lit = Just $ trueValInt dflags
+mkRuleFn dflags Ge _ (Lit lit) | isMinBound dflags lit = Just $ trueValInt dflags
+mkRuleFn dflags Lt _ (Lit lit) | isMinBound dflags lit = Just $ falseValInt dflags
+mkRuleFn dflags Ge (Lit lit) _ | isMaxBound dflags lit = Just $ trueValInt dflags
+mkRuleFn dflags Lt (Lit lit) _ | isMaxBound dflags lit = Just $ falseValInt dflags
+mkRuleFn dflags Gt _ (Lit lit) | isMaxBound dflags lit = Just $ falseValInt dflags
+mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just $ trueValInt dflags
mkRuleFn _ _ _ _ = Nothing
isMinBound :: DynFlags -> Literal -> Bool
@@ -512,10 +535,10 @@ mkBasicRule op_name n_args rm
= BuiltinRule { ru_name = occNameFS (nameOccName op_name),
ru_fn = op_name,
ru_nargs = n_args,
- ru_try = \dflags _ -> runRuleM rm dflags }
+ ru_try = \ dflags in_scope _ -> runRuleM rm dflags in_scope }
newtype RuleM r = RuleM
- { runRuleM :: DynFlags -> IdUnfoldingFun -> [CoreExpr] -> Maybe r }
+ { runRuleM :: DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r }
instance Monad RuleM where
return x = RuleM $ \_ _ _ -> Just x
@@ -557,8 +580,8 @@ removeOp32 = mzero
getArgs :: RuleM [CoreExpr]
getArgs = RuleM $ \_ _ args -> Just args
-getIdUnfoldingFun :: RuleM IdUnfoldingFun
-getIdUnfoldingFun = RuleM $ \_ iu _ -> Just iu
+getInScopeEnv :: RuleM InScopeEnv
+getInScopeEnv = RuleM $ \_ iu _ -> Just iu
-- return the n-th argument of this rule, if it is a literal
-- argument indices start from 0
@@ -579,6 +602,11 @@ binaryLit op = do
[Lit l1, Lit l2] <- getArgs
liftMaybe $ op dflags (convFloating dflags l1) (convFloating dflags l2)
+binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr
+binaryCmpLit op = do
+ dflags <- getDynFlags
+ binaryLit (\_ -> cmpOp dflags op)
+
leftIdentity :: Literal -> RuleM CoreExpr
leftIdentity id_lit = leftIdentityDynFlags (const id_lit)
@@ -656,9 +684,40 @@ guardDoubleDiv = do
-- is representable in Float/Double but not in (normalised)
-- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?
-trueVal, falseVal :: Expr CoreBndr
-trueVal = Var trueDataConId
-falseVal = Var falseDataConId
+strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr
+strengthReduction two_lit add_op = do -- Note [Strength reduction]
+ arg <- msum [ do [arg, Lit mult_lit] <- getArgs
+ guard (mult_lit == two_lit)
+ return arg
+ , do [Lit mult_lit, arg] <- getArgs
+ guard (mult_lit == two_lit)
+ return arg ]
+ return $ Var (mkPrimOpId add_op) `App` arg `App` arg
+
+-- Note [Strength reduction]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- This rule turns floating point multiplications of the form 2.0 * x and
+-- x * 2.0 into x + x addition, because addition costs less than multiplication.
+-- See #7116
+
+-- Note [What's true and false]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- trueValInt and falseValInt represent true and false values returned by
+-- comparison primops for Char, Int, Word, Integer, Double, Float and Addr.
+-- True is represented as an unboxed 1# literal, while false is represented
+-- as 0# literal.
+-- We still need Bool data constructors (True and False) to use in a rule
+-- for constant folding of equal Strings
+
+trueValInt, falseValInt :: DynFlags -> Expr CoreBndr
+trueValInt dflags = Lit $ onei dflags -- see Note [What's true and false]
+falseValInt dflags = Lit $ zeroi dflags
+
+trueValBool, falseValBool :: Expr CoreBndr
+trueValBool = Var trueDataConId -- see Note [What's true and false]
+falseValBool = Var falseDataConId
ltVal, eqVal, gtVal :: Expr CoreBndr
ltVal = Var ltDataConId
@@ -719,7 +778,7 @@ tagToEnumRule = do
let tag = fromInteger i
correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
(dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])
- ASSERT (null rest) return ()
+ ASSERT(null rest) return ()
return $ mkTyApps (Var (dataConWorkId dc)) tc_args
-- See Note [tagToEnum#]
@@ -745,8 +804,8 @@ dataToTagRule = a `mplus` b
b = do
dflags <- getDynFlags
[_, val_arg] <- getArgs
- id_unf <- getIdUnfoldingFun
- (dc,_,_) <- liftMaybe $ exprIsConApp_maybe id_unf val_arg
+ in_scope <- getInScopeEnv
+ (dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg
ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return ()
return $ mkIntVal dflags (toInteger (dataConTag dc - fIRST_TAG))
\end{code}
@@ -812,11 +871,14 @@ builtinRules :: [CoreRule]
builtinRules
= [BuiltinRule { ru_name = fsLit "AppendLitString",
ru_fn = unpackCStringFoldrName,
- ru_nargs = 4, ru_try = \_ _ -> match_append_lit },
+ ru_nargs = 4, ru_try = \_ _ _ -> match_append_lit },
BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
- ru_nargs = 2, ru_try = \_ _ -> match_eq_string },
+ ru_nargs = 2, ru_try = \dflags _ _ -> match_eq_string dflags },
BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
- ru_nargs = 2, ru_try = \_ _ -> match_inline }]
+ ru_nargs = 2, ru_try = \_ _ _ -> match_inline },
+ BuiltinRule { ru_name = fsLit "MagicSingI", ru_fn = idName magicSingIId,
+ ru_nargs = 3, ru_try = \_ _ _ -> match_magicSingI }
+ ]
++ builtinIntegerRules
builtinIntegerRules :: [CoreRule]
@@ -833,19 +895,15 @@ builtinIntegerRules =
rule_binop "minusInteger" minusIntegerName (-),
rule_binop "timesInteger" timesIntegerName (*),
rule_unop "negateInteger" negateIntegerName negate,
- rule_binop_Bool "eqInteger" eqIntegerName (==),
- rule_binop_Bool "neqInteger" neqIntegerName (/=),
+ rule_binop_Prim "eqInteger#" eqIntegerPrimName (==),
+ rule_binop_Prim "neqInteger#" neqIntegerPrimName (/=),
rule_unop "absInteger" absIntegerName abs,
rule_unop "signumInteger" signumIntegerName signum,
- rule_binop_Bool "leInteger" leIntegerName (<=),
- rule_binop_Bool "gtInteger" gtIntegerName (>),
- rule_binop_Bool "ltInteger" ltIntegerName (<),
- rule_binop_Bool "geInteger" geIntegerName (>=),
+ rule_binop_Prim "leInteger#" leIntegerPrimName (<=),
+ rule_binop_Prim "gtInteger#" gtIntegerPrimName (>),
+ rule_binop_Prim "ltInteger#" ltIntegerPrimName (<),
+ rule_binop_Prim "geInteger#" geIntegerPrimName (>=),
rule_binop_Ordering "compareInteger" compareIntegerName compare,
- rule_divop_both "divModInteger" divModIntegerName divMod,
- rule_divop_both "quotRemInteger" quotRemIntegerName quotRem,
- rule_divop_one "quotInteger" quotIntegerName quot,
- rule_divop_one "remInteger" remIntegerName rem,
rule_encodeFloat "encodeFloatInteger" encodeFloatIntegerName mkFloatLitFloat,
rule_convert "floatFromInteger" floatFromIntegerName (\_ -> mkFloatLitFloat),
rule_encodeFloat "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble,
@@ -861,6 +919,13 @@ builtinIntegerRules =
rule_unop "complementInteger" complementIntegerName complement,
rule_Int_binop "shiftLInteger" shiftLIntegerName shiftL,
rule_Int_binop "shiftRInteger" shiftRIntegerName shiftR,
+ -- See Note [Integer division constant folding] in libraries/base/GHC/Real.lhs
+ rule_divop_one "quotInteger" quotIntegerName quot,
+ rule_divop_one "remInteger" remIntegerName rem,
+ rule_divop_one "divInteger" divIntegerName div,
+ rule_divop_one "modInteger" modIntegerName mod,
+ rule_divop_both "divModInteger" divModIntegerName divMod,
+ rule_divop_both "quotRemInteger" quotRemIntegerName quotRem,
-- These rules below don't actually have to be built in, but if we
-- put them in the Haskell source then we'd have to duplicate them
-- between all Integer implementations
@@ -902,9 +967,9 @@ builtinIntegerRules =
rule_Int_binop str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
ru_try = match_Integer_Int_binop op }
- rule_binop_Bool str name op
+ rule_binop_Prim str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
- ru_try = match_Integer_binop_Bool op }
+ ru_try = match_Integer_binop_Prim op }
rule_binop_Ordering str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
ru_try = match_Integer_binop_Ordering op }
@@ -929,8 +994,8 @@ builtinIntegerRules =
-- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
-- = unpackFoldrCString# "foobaz" c n
-match_append_lit :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
-match_append_lit _ [Type ty1,
+match_append_lit :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
+match_append_lit [Type ty1,
Lit (MachStr s1),
c1,
Var unpk `App` Type ty2
@@ -946,18 +1011,18 @@ match_append_lit _ [Type ty1,
`App` c1
`App` n)
-match_append_lit _ _ = Nothing
+match_append_lit _ = Nothing
---------------------------------------------------
-- The rule is this:
-- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
-match_eq_string :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
+match_eq_string :: DynFlags -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
match_eq_string _ [Var unpk1 `App` Lit (MachStr s1),
- Var unpk2 `App` Lit (MachStr s2)]
+ Var unpk2 `App` Lit (MachStr s2)]
| unpk1 `hasKey` unpackCStringIdKey,
unpk2 `hasKey` unpackCStringIdKey
- = Just (if s1 == s2 then trueVal else falseVal)
+ = Just (if s1 == s2 then trueValBool else falseValBool)
match_eq_string _ _ = Nothing
@@ -975,41 +1040,47 @@ match_eq_string _ _ = Nothing
-- programmer can't avoid
--
-- Also, don't forget about 'inline's type argument!
-match_inline :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
-match_inline _ (Type _ : e : _)
+match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
+match_inline (Type _ : e : _)
| (Var f, args1) <- collectArgs e,
Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)
-- Ignore the IdUnfoldingFun here!
= Just (mkApps unf args1)
-match_inline _ _ = Nothing
+match_inline _ = Nothing
+
+
+-- See Note [magicSingIId magic] in `basicTypes/MkId.lhs`
+-- for a description of what is going on here.
+match_magicSingI :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
+match_magicSingI (Type t : e : Lam b _ : _)
+ | ((_ : _ : fu : _),_) <- splitFunTys t
+ , (sI_type,_) <- splitFunTy fu
+ , Just (sI_tc,xs) <- splitTyConApp_maybe sI_type
+ , Just (_,_,co) <- unwrapNewTyCon_maybe sI_tc
+ = Just $ let f = setVarType b fu
+ in Lam f $ Var f `App` Cast e (mkSymCo (mkUnbranchedAxInstCo Representational co xs))
+
+match_magicSingI _ = Nothing
-------------------------------------------------
-- Integer rules
--- smallInteger (79::Int#) = 79::Integer
--- wordToInteger (79::Word#) = 79::Integer
+-- smallInteger (79::Int#) = 79::Integer
+-- wordToInteger (79::Word#) = 79::Integer
-- Similarly Int64, Word64
-match_IntToInteger :: DynFlags
- -> Id
- -> IdUnfoldingFun
- -> [Expr CoreBndr]
- -> Maybe (Expr CoreBndr)
-match_IntToInteger _ id id_unf [xl]
+match_IntToInteger :: RuleFun
+match_IntToInteger _ id_unf fn [xl]
| Just (MachInt x) <- exprIsLiteral_maybe id_unf xl
- = case idType id of
+ = case idType fn of
FunTy _ integerTy ->
Just (Lit (LitInteger x integerTy))
_ ->
panic "match_IntToInteger: Id has the wrong type"
match_IntToInteger _ _ _ _ = Nothing
-match_WordToInteger :: DynFlags
- -> Id
- -> IdUnfoldingFun
- -> [Expr CoreBndr]
- -> Maybe (Expr CoreBndr)
-match_WordToInteger _ id id_unf [xl]
+match_WordToInteger :: RuleFun
+match_WordToInteger _ id_unf id [xl]
| Just (MachWord x) <- exprIsLiteral_maybe id_unf xl
= case idType id of
FunTy _ integerTy ->
@@ -1018,12 +1089,8 @@ match_WordToInteger _ id id_unf [xl]
panic "match_WordToInteger: Id has the wrong type"
match_WordToInteger _ _ _ _ = Nothing
-match_Int64ToInteger :: DynFlags
- -> Id
- -> IdUnfoldingFun
- -> [Expr CoreBndr]
- -> Maybe (Expr CoreBndr)
-match_Int64ToInteger _ id id_unf [xl]
+match_Int64ToInteger :: RuleFun
+match_Int64ToInteger _ id_unf id [xl]
| Just (MachInt64 x) <- exprIsLiteral_maybe id_unf xl
= case idType id of
FunTy _ integerTy ->
@@ -1032,12 +1099,8 @@ match_Int64ToInteger _ id id_unf [xl]
panic "match_Int64ToInteger: Id has the wrong type"
match_Int64ToInteger _ _ _ _ = Nothing
-match_Word64ToInteger :: DynFlags
- -> Id
- -> IdUnfoldingFun
- -> [Expr CoreBndr]
- -> Maybe (Expr CoreBndr)
-match_Word64ToInteger _ id id_unf [xl]
+match_Word64ToInteger :: RuleFun
+match_Word64ToInteger _ id_unf id [xl]
| Just (MachWord64 x) <- exprIsLiteral_maybe id_unf xl
= case idType id of
FunTy _ integerTy ->
@@ -1049,47 +1112,29 @@ match_Word64ToInteger _ _ _ _ = Nothing
-------------------------------------------------
match_Integer_convert :: Num a
=> (DynFlags -> a -> Expr CoreBndr)
- -> DynFlags
- -> Id
- -> IdUnfoldingFun
- -> [Expr CoreBndr]
- -> Maybe (Expr CoreBndr)
-match_Integer_convert convert dflags _ id_unf [xl]
+ -> 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_Integer_unop :: (Integer -> Integer)
- -> DynFlags
- -> Id
- -> IdUnfoldingFun
- -> [Expr CoreBndr]
- -> Maybe (Expr CoreBndr)
-match_Integer_unop unop _ _ id_unf [xl]
+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_Integer_binop :: (Integer -> Integer -> Integer)
- -> DynFlags
- -> Id
- -> IdUnfoldingFun
- -> [Expr CoreBndr]
- -> Maybe (Expr CoreBndr)
-match_Integer_binop binop _ _ id_unf [xl,yl]
+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))
match_Integer_binop _ _ _ _ _ = Nothing
-- This helper is used for the quotRem and divMod functions
-match_Integer_divop_both :: (Integer -> Integer -> (Integer, Integer))
- -> DynFlags
- -> Id
- -> IdUnfoldingFun
- -> [Expr CoreBndr]
- -> Maybe (Expr CoreBndr)
-match_Integer_divop_both divop _ _ id_unf [xl,yl]
+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
, y /= 0
@@ -1101,51 +1146,31 @@ match_Integer_divop_both divop _ _ id_unf [xl,yl]
Lit (LitInteger s t)]
match_Integer_divop_both _ _ _ _ _ = Nothing
--- This helper is used for the quotRem and divMod functions
-match_Integer_divop_one :: (Integer -> Integer -> Integer)
- -> DynFlags
- -> Id
- -> IdUnfoldingFun
- -> [Expr CoreBndr]
- -> Maybe (Expr CoreBndr)
-match_Integer_divop_one divop _ _ id_unf [xl,yl]
+-- 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
, y /= 0
= Just (Lit (LitInteger (x `divop` y) i))
match_Integer_divop_one _ _ _ _ _ = Nothing
-match_Integer_Int_binop :: (Integer -> Int -> Integer)
- -> DynFlags
- -> Id
- -> IdUnfoldingFun
- -> [Expr CoreBndr]
- -> Maybe (Expr CoreBndr)
-match_Integer_Int_binop binop _ _ id_unf [xl,yl]
+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))
match_Integer_Int_binop _ _ _ _ _ = Nothing
-match_Integer_binop_Bool :: (Integer -> Integer -> Bool)
- -> DynFlags
- -> Id
- -> IdUnfoldingFun
- -> [Expr CoreBndr]
- -> Maybe (Expr CoreBndr)
-match_Integer_binop_Bool binop _ _ id_unf [xl, yl]
+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 (if x `binop` y then trueVal else falseVal)
-match_Integer_binop_Bool _ _ _ _ _ = Nothing
-
-match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering)
- -> DynFlags
- -> Id
- -> IdUnfoldingFun
- -> [Expr CoreBndr]
- -> Maybe (Expr CoreBndr)
-match_Integer_binop_Ordering binop _ _ id_unf [xl, 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 $ case x `binop` y of
@@ -1156,12 +1181,8 @@ match_Integer_binop_Ordering _ _ _ _ _ = Nothing
match_Integer_Int_encodeFloat :: RealFloat a
=> (a -> Expr CoreBndr)
- -> DynFlags
- -> Id
- -> IdUnfoldingFun
- -> [Expr CoreBndr]
- -> Maybe (Expr CoreBndr)
-match_Integer_Int_encodeFloat mkLit _ _ id_unf [xl,yl]
+ -> 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 (mkLit $ encodeFloat x (fromInteger y))
@@ -1179,24 +1200,16 @@ match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing
-- NaN or +-Inf
match_rationalTo :: RealFloat a
=> (a -> Expr CoreBndr)
- -> DynFlags
- -> Id
- -> IdUnfoldingFun
- -> [Expr CoreBndr]
- -> Maybe (Expr CoreBndr)
-match_rationalTo mkLit _ _ id_unf [xl, yl]
+ -> RuleFun
+match_rationalTo mkLit _ id_unf _ [xl, yl]
| Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
, Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
, y /= 0
= Just (mkLit (fromRational (x % y)))
match_rationalTo _ _ _ _ _ = Nothing
-match_decodeDouble :: DynFlags
- -> Id
- -> IdUnfoldingFun
- -> [Expr CoreBndr]
- -> Maybe (Expr CoreBndr)
-match_decodeDouble _ fn id_unf [xl]
+match_decodeDouble :: RuleFun
+match_decodeDouble _ id_unf fn [xl]
| Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl
= case idType fn of
FunTy _ (TyConApp _ [integerTy, intHashTy]) ->
@@ -1211,23 +1224,13 @@ match_decodeDouble _ fn id_unf [xl]
panic "match_decodeDouble: Id has the wrong type"
match_decodeDouble _ _ _ _ = Nothing
-match_XToIntegerToX :: Name
- -> DynFlags
- -> Id
- -> IdUnfoldingFun
- -> [Expr CoreBndr]
- -> Maybe (Expr CoreBndr)
+match_XToIntegerToX :: Name -> RuleFun
match_XToIntegerToX n _ _ _ [App (Var x) y]
| idName x == n
= Just y
match_XToIntegerToX _ _ _ _ _ = Nothing
-match_smallIntegerTo :: PrimOp
- -> DynFlags
- -> Id
- -> IdUnfoldingFun
- -> [Expr CoreBndr]
- -> Maybe (Expr CoreBndr)
+match_smallIntegerTo :: PrimOp -> RuleFun
match_smallIntegerTo primOp _ _ _ [App (Var x) y]
| idName x == smallIntegerName
= Just $ App (Var (mkPrimOpId primOp)) y
diff --git a/compiler/prelude/PrimOp.lhs b/compiler/prelude/PrimOp.lhs
index 1aaca36274..8b1970c37f 100644
--- a/compiler/prelude/PrimOp.lhs
+++ b/compiler/prelude/PrimOp.lhs
@@ -118,9 +118,8 @@ data PrimOpInfo
Type
| Monadic OccName -- string :: T -> T
Type
- | Compare OccName -- string :: T -> T -> Bool
+ | Compare OccName -- string :: T -> T -> Int#
Type
-
| GenPrimOp OccName -- string :: \/a1..an . T1 -> .. -> Tk -> T
[TyVar]
[Type]
@@ -513,10 +512,10 @@ primOpSig op
arity = length arg_tys
(tyvars, arg_tys, res_ty)
= case (primOpInfo op) of
- Monadic _occ ty -> ([], [ty], ty )
- Dyadic _occ ty -> ([], [ty,ty], ty )
- Compare _occ ty -> ([], [ty,ty], boolTy)
- GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty)
+ Monadic _occ ty -> ([], [ty], ty )
+ Dyadic _occ ty -> ([], [ty,ty], ty )
+ Compare _occ ty -> ([], [ty,ty], intPrimTy)
+ GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty )
\end{code}
\begin{code}
@@ -533,7 +532,7 @@ getPrimOpResultInfo op
= case (primOpInfo op) of
Dyadic _ ty -> ReturnsPrim (typePrimRep ty)
Monadic _ ty -> ReturnsPrim (typePrimRep ty)
- Compare _ _ -> ReturnsAlg boolTyCon
+ Compare _ _ -> ReturnsPrim (tyConPrimRep intPrimTyCon)
GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep tc)
| otherwise -> ReturnsAlg tc
where
@@ -560,7 +559,7 @@ Utils:
dyadic_fun_ty, monadic_fun_ty, compare_fun_ty :: Type -> Type
dyadic_fun_ty ty = mkFunTys [ty, ty] ty
monadic_fun_ty ty = mkFunTy ty ty
-compare_fun_ty ty = mkFunTys [ty, ty] boolTy
+compare_fun_ty ty = mkFunTys [ty, ty] intPrimTy
\end{code}
Output stuff:
diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs
index c59884ba33..f166065b22 100644
--- a/compiler/prelude/TysPrim.lhs
+++ b/compiler/prelude/TysPrim.lhs
@@ -71,6 +71,7 @@ module TysPrim(
word64PrimTyCon, word64PrimTy,
eqPrimTyCon, -- ty1 ~# ty2
+ eqReprPrimTyCon, -- ty1 ~R# ty2 (at role Representational)
-- * Any
anyTy, anyTyCon, anyTypeOfKind,
@@ -134,6 +135,7 @@ primTyCons
, word64PrimTyCon
, anyTyCon
, eqPrimTyCon
+ , eqReprPrimTyCon
, liftedTypeKindTyCon
, unliftedTypeKindTyCon
@@ -155,7 +157,7 @@ mkPrimTc fs unique tycon
(ATyCon tycon) -- Relevant TyCon
UserSyntax -- None are built-in syntax
-charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, floatX4PrimTyConName, doubleX2PrimTyConName, int32X4PrimTyConName, int64X2PrimTyConName :: Name
+charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, floatX4PrimTyConName, doubleX2PrimTyConName, int32X4PrimTyConName, int64X2PrimTyConName :: Name
charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon
intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon
int32PrimTyConName = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon
@@ -168,6 +170,7 @@ floatPrimTyConName = mkPrimTc (fsLit "Float#") floatPrimTyConKey floatP
doublePrimTyConName = mkPrimTc (fsLit "Double#") doublePrimTyConKey doublePrimTyCon
statePrimTyConName = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon
eqPrimTyConName = mkPrimTc (fsLit "~#") eqPrimTyConKey eqPrimTyCon
+eqReprPrimTyConName = mkPrimTc (fsLit "~R#") eqReprPrimTyConKey eqReprPrimTyCon
realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon
arrayPrimTyConName = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon
byteArrayPrimTyConName = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon
@@ -346,7 +349,7 @@ mkPrimTyConName occ key tycon = mkWiredInName gHC_PRIM (mkTcOccFS occ)
\begin{code}
kindTyConType :: TyCon -> Type
-kindTyConType kind = TyConApp kind []
+kindTyConType kind = TyConApp kind [] -- mkTyConApp isn't defined yet
-- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's
anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind, superKind :: Kind
@@ -375,16 +378,16 @@ mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds
\begin{code}
-- only used herein
-pcPrimTyCon :: Name -> Int -> PrimRep -> TyCon
-pcPrimTyCon name arity rep
- = mkPrimTyCon name kind arity rep
+pcPrimTyCon :: Name -> [Role] -> PrimRep -> TyCon
+pcPrimTyCon name roles rep
+ = mkPrimTyCon name kind roles rep
where
- kind = mkArrowKinds (replicate arity liftedTypeKind) result_kind
+ kind = mkArrowKinds (map (const liftedTypeKind) roles) result_kind
result_kind = unliftedTypeKind
pcPrimTyCon0 :: Name -> PrimRep -> TyCon
pcPrimTyCon0 name rep
- = mkPrimTyCon name result_kind 0 rep
+ = mkPrimTyCon name result_kind [] rep
where
result_kind = unliftedTypeKind
@@ -469,19 +472,34 @@ or
where s is a type variable. The only purpose of the type parameter is to
keep different state threads separate. It is represented by nothing at all.
+The type parameter to State# is intended to keep separate threads separate.
+Even though this parameter is not used in the definition of State#, it is
+given role Nominal to enforce its intended use.
+
\begin{code}
mkStatePrimTy :: Type -> Type
-mkStatePrimTy ty = mkNakedTyConApp statePrimTyCon [ty]
+mkStatePrimTy ty = TyConApp statePrimTyCon [ty]
statePrimTyCon :: TyCon -- See Note [The State# TyCon]
-statePrimTyCon = pcPrimTyCon statePrimTyConName 1 VoidRep
+statePrimTyCon = pcPrimTyCon statePrimTyConName [Nominal] VoidRep
eqPrimTyCon :: TyCon -- The representation type for equality predicates
-- See Note [The ~# TyCon]
-eqPrimTyCon = mkPrimTyCon eqPrimTyConName kind 3 VoidRep
+eqPrimTyCon = mkPrimTyCon eqPrimTyConName kind [Nominal, Nominal, Nominal] VoidRep
where kind = ForAllTy kv $ mkArrowKinds [k, k] unliftedTypeKind
kv = kKiVar
k = mkTyVarTy kv
+
+-- like eqPrimTyCon, but the type for *Representational* coercions
+-- this should only ever appear as the type of a covar. Its role is
+-- interpreted in coercionRole
+eqReprPrimTyCon :: TyCon
+eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName kind
+ -- the roles really should be irrelevant!
+ [Nominal, Representational, Representational] VoidRep
+ where kind = ForAllTy kv $ mkArrowKinds [k, k] unliftedTypeKind
+ kv = kKiVar
+ k = mkTyVarTy kv
\end{code}
RealWorld is deeply magical. It is *primitive*, but it is not
@@ -490,7 +508,7 @@ RealWorld; it's only used in the type system, to parameterise State#.
\begin{code}
realWorldTyCon :: TyCon
-realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName liftedTypeKind 0 PtrRep
+realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName liftedTypeKind [] PtrRep
realWorldTy :: Type
realWorldTy = mkTyConTy realWorldTyCon
realWorldStatePrimTy :: Type
@@ -509,25 +527,25 @@ defined in \tr{TysWiredIn.lhs}, not here.
\begin{code}
arrayPrimTyCon, mutableArrayPrimTyCon, mutableByteArrayPrimTyCon,
byteArrayPrimTyCon, arrayArrayPrimTyCon, mutableArrayArrayPrimTyCon :: TyCon
-arrayPrimTyCon = pcPrimTyCon arrayPrimTyConName 1 PtrRep
-mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConName 2 PtrRep
-mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConName 1 PtrRep
-byteArrayPrimTyCon = pcPrimTyCon0 byteArrayPrimTyConName PtrRep
-arrayArrayPrimTyCon = pcPrimTyCon0 arrayArrayPrimTyConName PtrRep
-mutableArrayArrayPrimTyCon = pcPrimTyCon mutableArrayArrayPrimTyConName 1 PtrRep
+arrayPrimTyCon = pcPrimTyCon arrayPrimTyConName [Representational] PtrRep
+mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConName [Nominal, Representational] PtrRep
+mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConName [Nominal] PtrRep
+byteArrayPrimTyCon = pcPrimTyCon0 byteArrayPrimTyConName PtrRep
+arrayArrayPrimTyCon = pcPrimTyCon0 arrayArrayPrimTyConName PtrRep
+mutableArrayArrayPrimTyCon = pcPrimTyCon mutableArrayArrayPrimTyConName [Nominal] PtrRep
mkArrayPrimTy :: Type -> Type
-mkArrayPrimTy elt = mkNakedTyConApp arrayPrimTyCon [elt]
+mkArrayPrimTy elt = TyConApp arrayPrimTyCon [elt]
byteArrayPrimTy :: Type
byteArrayPrimTy = mkTyConTy byteArrayPrimTyCon
mkArrayArrayPrimTy :: Type
mkArrayArrayPrimTy = mkTyConTy arrayArrayPrimTyCon
mkMutableArrayPrimTy :: Type -> Type -> Type
-mkMutableArrayPrimTy s elt = mkNakedTyConApp mutableArrayPrimTyCon [s, elt]
+mkMutableArrayPrimTy s elt = TyConApp mutableArrayPrimTyCon [s, elt]
mkMutableByteArrayPrimTy :: Type -> Type
-mkMutableByteArrayPrimTy s = mkNakedTyConApp mutableByteArrayPrimTyCon [s]
+mkMutableByteArrayPrimTy s = TyConApp mutableByteArrayPrimTyCon [s]
mkMutableArrayArrayPrimTy :: Type -> Type
-mkMutableArrayArrayPrimTy s = mkNakedTyConApp mutableArrayArrayPrimTyCon [s]
+mkMutableArrayArrayPrimTy s = TyConApp mutableArrayArrayPrimTyCon [s]
\end{code}
%************************************************************************
@@ -538,10 +556,10 @@ mkMutableArrayArrayPrimTy s = mkNakedTyConApp mutableArrayArrayPrimTyCon [s]
\begin{code}
mutVarPrimTyCon :: TyCon
-mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName 2 PtrRep
+mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName [Nominal, Representational] PtrRep
mkMutVarPrimTy :: Type -> Type -> Type
-mkMutVarPrimTy s elt = mkNakedTyConApp mutVarPrimTyCon [s, elt]
+mkMutVarPrimTy s elt = TyConApp mutVarPrimTyCon [s, elt]
\end{code}
%************************************************************************
@@ -552,10 +570,10 @@ mkMutVarPrimTy s elt = mkNakedTyConApp mutVarPrimTyCon [s, elt]
\begin{code}
mVarPrimTyCon :: TyCon
-mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName 2 PtrRep
+mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName [Nominal, Representational] PtrRep
mkMVarPrimTy :: Type -> Type -> Type
-mkMVarPrimTy s elt = mkNakedTyConApp mVarPrimTyCon [s, elt]
+mkMVarPrimTy s elt = TyConApp mVarPrimTyCon [s, elt]
\end{code}
%************************************************************************
@@ -566,10 +584,10 @@ mkMVarPrimTy s elt = mkNakedTyConApp mVarPrimTyCon [s, elt]
\begin{code}
tVarPrimTyCon :: TyCon
-tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName 2 PtrRep
+tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName [Nominal, Representational] PtrRep
mkTVarPrimTy :: Type -> Type -> Type
-mkTVarPrimTy s elt = mkNakedTyConApp tVarPrimTyCon [s, elt]
+mkTVarPrimTy s elt = TyConApp tVarPrimTyCon [s, elt]
\end{code}
%************************************************************************
@@ -580,10 +598,10 @@ mkTVarPrimTy s elt = mkNakedTyConApp tVarPrimTyCon [s, elt]
\begin{code}
stablePtrPrimTyCon :: TyCon
-stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName 1 AddrRep
+stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName [Representational] AddrRep
mkStablePtrPrimTy :: Type -> Type
-mkStablePtrPrimTy ty = mkNakedTyConApp stablePtrPrimTyCon [ty]
+mkStablePtrPrimTy ty = TyConApp stablePtrPrimTyCon [ty]
\end{code}
%************************************************************************
@@ -594,10 +612,10 @@ mkStablePtrPrimTy ty = mkNakedTyConApp stablePtrPrimTyCon [ty]
\begin{code}
stableNamePrimTyCon :: TyCon
-stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName 1 PtrRep
+stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName [Representational] PtrRep
mkStableNamePrimTy :: Type -> Type
-mkStableNamePrimTy ty = mkNakedTyConApp stableNamePrimTyCon [ty]
+mkStableNamePrimTy ty = TyConApp stableNamePrimTyCon [ty]
\end{code}
%************************************************************************
@@ -621,10 +639,10 @@ bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName PtrRep
\begin{code}
weakPrimTyCon :: TyCon
-weakPrimTyCon = pcPrimTyCon weakPrimTyConName 1 PtrRep
+weakPrimTyCon = pcPrimTyCon weakPrimTyConName [Representational] PtrRep
mkWeakPrimTy :: Type -> Type
-mkWeakPrimTy v = mkNakedTyConApp weakPrimTyCon [v]
+mkWeakPrimTy v = TyConApp weakPrimTyCon [v]
\end{code}
%************************************************************************
@@ -727,10 +745,11 @@ anyTy :: Type
anyTy = mkTyConTy anyTyCon
anyTyCon :: TyCon
-anyTyCon = mkLiftedPrimTyCon anyTyConName kind 1 PtrRep
+anyTyCon = mkLiftedPrimTyCon anyTyConName kind [Nominal] PtrRep
where kind = ForAllTy kKiVar (mkTyVarTy kKiVar)
{- Can't do this yet without messing up kind proxies
+-- RAE: I think you can now.
anyTyCon :: TyCon
anyTyCon = mkSynTyCon anyTyConName kind [kKiVar]
syn_rhs
@@ -742,7 +761,7 @@ anyTyCon = mkSynTyCon anyTyConName kind [kKiVar]
-}
anyTypeOfKind :: Kind -> Type
-anyTypeOfKind kind = mkNakedTyConApp anyTyCon [kind]
+anyTypeOfKind kind = TyConApp anyTyCon [kind]
\end{code}
%************************************************************************
diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
index b8c0e34174..b563b25cc4 100644
--- a/compiler/prelude/TysWiredIn.lhs
+++ b/compiler/prelude/TysWiredIn.lhs
@@ -236,12 +236,15 @@ pcNonRecDataTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
-- Not an enumeration, not promotable
pcNonRecDataTyCon = pcTyCon False NonRecursive False
+-- This function assumes that the types it creates have all parameters at
+-- Representational role!
pcTyCon :: Bool -> RecFlag -> Bool -> Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
pcTyCon is_enum is_rec is_prom name cType tyvars cons
= tycon
where
tycon = buildAlgTyCon name
tyvars
+ (map (const Representational) tyvars)
cType
[] -- No stupid theta
(DataTyCon cons is_enum)
@@ -425,6 +428,7 @@ eqTyCon :: TyCon
eqTyCon = mkAlgTyCon eqTyConName
(ForAllTy kv $ mkArrowKinds [k, k] constraintKind)
[kv, a, b]
+ [Nominal, Nominal, Nominal]
Nothing
[] -- No stupid theta
(DataTyCon [eqBoxDataCon] False)
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index 45472816c0..e275b23778 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -140,19 +140,19 @@ section "Char#"
primtype Char#
-primop CharGtOp "gtChar#" Compare Char# -> Char# -> Bool
-primop CharGeOp "geChar#" Compare Char# -> Char# -> Bool
+primop CharGtOp "gtCharI#" Compare Char# -> Char# -> Int#
+primop CharGeOp "geCharI#" Compare Char# -> Char# -> Int#
-primop CharEqOp "eqChar#" Compare
- Char# -> Char# -> Bool
+primop CharEqOp "eqCharI#" Compare
+ Char# -> Char# -> Int#
with commutable = True
-primop CharNeOp "neChar#" Compare
- Char# -> Char# -> Bool
+primop CharNeOp "neCharI#" Compare
+ Char# -> Char# -> Int#
with commutable = True
-primop CharLtOp "ltChar#" Compare Char# -> Char# -> Bool
-primop CharLeOp "leChar#" Compare Char# -> Char# -> Bool
+primop CharLtOp "ltCharI#" Compare Char# -> Char# -> Int#
+primop CharLeOp "leCharI#" Compare Char# -> Char# -> Int#
primop OrdOp "ord#" GenPrimOp Char# -> Int#
with code_size = 0
@@ -239,26 +239,26 @@ primop IntSubCOp "subIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #)
second member is 0 iff no overflow occured.}
with code_size = 2
-primop IntGtOp ">#" Compare Int# -> Int# -> Bool
+primop IntGtOp ">$#" Compare Int# -> Int# -> Int#
with fixity = infix 4
-primop IntGeOp ">=#" Compare Int# -> Int# -> Bool
+primop IntGeOp ">=$#" Compare Int# -> Int# -> Int#
with fixity = infix 4
-primop IntEqOp "==#" Compare
- Int# -> Int# -> Bool
+primop IntEqOp "==$#" Compare
+ Int# -> Int# -> Int#
with commutable = True
fixity = infix 4
-primop IntNeOp "/=#" Compare
- Int# -> Int# -> Bool
+primop IntNeOp "/=$#" Compare
+ Int# -> Int# -> Int#
with commutable = True
fixity = infix 4
-primop IntLtOp "<#" Compare Int# -> Int# -> Bool
+primop IntLtOp "<$#" Compare Int# -> Int# -> Int#
with fixity = infix 4
-primop IntLeOp "<=#" Compare Int# -> Int# -> Bool
+primop IntLeOp "<=$#" Compare Int# -> Int# -> Int#
with fixity = infix 4
primop ChrOp "chr#" GenPrimOp Int# -> Char#
@@ -345,12 +345,12 @@ primop SrlOp "uncheckedShiftRL#" GenPrimOp Word# -> Int# -> Word#
primop Word2IntOp "word2Int#" GenPrimOp Word# -> Int#
with code_size = 0
-primop WordGtOp "gtWord#" Compare Word# -> Word# -> Bool
-primop WordGeOp "geWord#" Compare Word# -> Word# -> Bool
-primop WordEqOp "eqWord#" Compare Word# -> Word# -> Bool
-primop WordNeOp "neWord#" Compare Word# -> Word# -> Bool
-primop WordLtOp "ltWord#" Compare Word# -> Word# -> Bool
-primop WordLeOp "leWord#" Compare Word# -> Word# -> Bool
+primop WordGtOp "gtWordI#" Compare Word# -> Word# -> Int#
+primop WordGeOp "geWordI#" Compare Word# -> Word# -> Int#
+primop WordEqOp "eqWordI#" Compare Word# -> Word# -> Int#
+primop WordNeOp "neWordI#" Compare Word# -> Word# -> Int#
+primop WordLtOp "ltWordI#" Compare Word# -> Word# -> Int#
+primop WordLeOp "leWordI#" Compare Word# -> Word# -> Int#
primop PopCnt8Op "popCnt8#" Monadic Word# -> Word#
{Count the number of set bits in the lower 8 bits of a word.}
@@ -363,6 +363,15 @@ primop PopCnt64Op "popCnt64#" GenPrimOp WORD64 -> Word#
primop PopCntOp "popCnt#" Monadic Word# -> Word#
{Count the number of set bits in a word.}
+primop BSwap16Op "byteSwap16#" Monadic Word# -> Word#
+ {Swap bytes in the lower 16 bits of a word. The higher bytes are undefined. }
+primop BSwap32Op "byteSwap32#" Monadic Word# -> Word#
+ {Swap bytes in the lower 32 bits of a word. The higher bytes are undefined. }
+primop BSwap64Op "byteSwap64#" Monadic WORD64 -> WORD64
+ {Swap bytes in a 64 bits of a word.}
+primop BSwapOp "byteSwap#" Monadic Word# -> Word#
+ {Swap bytes in a word.}
+
------------------------------------------------------------------------
section "Narrowings"
{Explicit narrowing of native-sized ints or words.}
@@ -426,26 +435,26 @@ section "Double#"
primtype Double#
-primop DoubleGtOp ">##" Compare Double# -> Double# -> Bool
+primop DoubleGtOp ">$##" Compare Double# -> Double# -> Int#
with fixity = infix 4
-primop DoubleGeOp ">=##" Compare Double# -> Double# -> Bool
+primop DoubleGeOp ">=$##" Compare Double# -> Double# -> Int#
with fixity = infix 4
-primop DoubleEqOp "==##" Compare
- Double# -> Double# -> Bool
+primop DoubleEqOp "==$##" Compare
+ Double# -> Double# -> Int#
with commutable = True
fixity = infix 4
-primop DoubleNeOp "/=##" Compare
- Double# -> Double# -> Bool
+primop DoubleNeOp "/=$##" Compare
+ Double# -> Double# -> Int#
with commutable = True
fixity = infix 4
-primop DoubleLtOp "<##" Compare Double# -> Double# -> Bool
+primop DoubleLtOp "<$##" Compare Double# -> Double# -> Int#
with fixity = infix 4
-primop DoubleLeOp "<=##" Compare Double# -> Double# -> Bool
+primop DoubleLeOp "<=$##" Compare Double# -> Double# -> Int#
with fixity = infix 4
primop DoubleAddOp "+##" Dyadic
@@ -559,19 +568,19 @@ section "Float#"
primtype Float#
-primop FloatGtOp "gtFloat#" Compare Float# -> Float# -> Bool
-primop FloatGeOp "geFloat#" Compare Float# -> Float# -> Bool
+primop FloatGtOp "gtFloatI#" Compare Float# -> Float# -> Int#
+primop FloatGeOp "geFloatI#" Compare Float# -> Float# -> Int#
-primop FloatEqOp "eqFloat#" Compare
- Float# -> Float# -> Bool
+primop FloatEqOp "eqFloatI#" Compare
+ Float# -> Float# -> Int#
with commutable = True
-primop FloatNeOp "neFloat#" Compare
- Float# -> Float# -> Bool
+primop FloatNeOp "neFloatI#" Compare
+ Float# -> Float# -> Int#
with commutable = True
-primop FloatLtOp "ltFloat#" Compare Float# -> Float# -> Bool
-primop FloatLeOp "leFloat#" Compare Float# -> Float# -> Bool
+primop FloatLtOp "ltFloatI#" Compare Float# -> Float# -> Int#
+primop FloatLeOp "leFloatI#" Compare Float# -> Float# -> Int#
primop FloatAddOp "plusFloat#" Dyadic
Float# -> Float# -> Float#
@@ -689,7 +698,7 @@ primop NewArrayOp "newArray#" GenPrimOp
has_side_effects = True
primop SameMutableArrayOp "sameMutableArray#" GenPrimOp
- MutableArray# s a -> MutableArray# s a -> Bool
+ MutableArray# s a -> MutableArray# s a -> Int#
primop ReadArrayOp "readArray#" GenPrimOp
MutableArray# s a -> Int# -> State# s -> (# State# s, a #)
@@ -828,7 +837,7 @@ primop ByteArrayContents_Char "byteArrayContents#" GenPrimOp
{Intended for use with pinned arrays; otherwise very unsafe!}
primop SameMutableByteArrayOp "sameMutableByteArray#" GenPrimOp
- MutableByteArray# s -> MutableByteArray# s -> Bool
+ MutableByteArray# s -> MutableByteArray# s -> Int#
primop UnsafeFreezeByteArrayOp "unsafeFreezeByteArray#" GenPrimOp
MutableByteArray# s -> State# s -> (# State# s, ByteArray# #)
@@ -1124,7 +1133,7 @@ primop NewArrayArrayOp "newArrayArray#" GenPrimOp
has_side_effects = True
primop SameMutableArrayArrayOp "sameMutableArrayArray#" GenPrimOp
- MutableArrayArray# s -> MutableArrayArray# s -> Bool
+ MutableArrayArray# s -> MutableArrayArray# s -> Int#
primop UnsafeFreezeArrayArrayOp "unsafeFreezeArrayArray#" GenPrimOp
MutableArrayArray# s -> State# s -> (# State# s, ArrayArray# #)
@@ -1235,12 +1244,12 @@ primop Int2AddrOp "int2Addr#" GenPrimOp Int# -> Addr#
with code_size = 0
#endif
-primop AddrGtOp "gtAddr#" Compare Addr# -> Addr# -> Bool
-primop AddrGeOp "geAddr#" Compare Addr# -> Addr# -> Bool
-primop AddrEqOp "eqAddr#" Compare Addr# -> Addr# -> Bool
-primop AddrNeOp "neAddr#" Compare Addr# -> Addr# -> Bool
-primop AddrLtOp "ltAddr#" Compare Addr# -> Addr# -> Bool
-primop AddrLeOp "leAddr#" Compare Addr# -> Addr# -> Bool
+primop AddrGtOp "gtAddrI#" Compare Addr# -> Addr# -> Int#
+primop AddrGeOp "geAddrI#" Compare Addr# -> Addr# -> Int#
+primop AddrEqOp "eqAddrI#" Compare Addr# -> Addr# -> Int#
+primop AddrNeOp "neAddrI#" Compare Addr# -> Addr# -> Int#
+primop AddrLtOp "ltAddrI#" Compare Addr# -> Addr# -> Int#
+primop AddrLeOp "leAddrI#" Compare Addr# -> Addr# -> Int#
primop IndexOffAddrOp_Char "indexCharOffAddr#" GenPrimOp
Addr# -> Int# -> Char#
@@ -1501,7 +1510,7 @@ primop WriteMutVarOp "writeMutVar#" GenPrimOp
can_fail = True
primop SameMutVarOp "sameMutVar#" GenPrimOp
- MutVar# s a -> MutVar# s a -> Bool
+ MutVar# s a -> MutVar# s a -> Int#
-- not really the right type, but we don't know about pairs here. The
-- correct type is
@@ -1602,9 +1611,20 @@ primop AtomicallyOp "atomically#" GenPrimOp
out_of_line = True
has_side_effects = True
+-- NB: retry#'s strictness information specifies it to return bottom.
+-- This lets the compiler perform some extra simplifications, since retry#
+-- will technically never return.
+--
+-- This allows the simplifier to replace things like:
+-- case retry# s1
+-- (# s2, a #) -> e
+-- with:
+-- retry# s1
+-- where 'e' would be unreachable anyway. See Trac #8091.
primop RetryOp "retry#" GenPrimOp
State# RealWorld -> (# State# RealWorld, a #)
with
+ strictness = { \ _arity -> mkStrictSig (mkTopDmdType [topDmd] botRes) }
out_of_line = True
has_side_effects = True
@@ -1665,7 +1685,7 @@ primop WriteTVarOp "writeTVar#" GenPrimOp
has_side_effects = True
primop SameTVarOp "sameTVar#" GenPrimOp
- TVar# s a -> TVar# s a -> Bool
+ TVar# s a -> TVar# s a -> Int#
------------------------------------------------------------------------
@@ -1717,8 +1737,25 @@ primop TryPutMVarOp "tryPutMVar#" GenPrimOp
out_of_line = True
has_side_effects = True
+primop ReadMVarOp "readMVar#" GenPrimOp
+ MVar# s a -> State# s -> (# State# s, a #)
+ {If {\tt MVar\#} is empty, block until it becomes full.
+ Then read its contents without modifying the MVar, without possibility
+ of intervention from other threads.}
+ with
+ out_of_line = True
+ has_side_effects = True
+
+primop TryReadMVarOp "tryReadMVar#" GenPrimOp
+ MVar# s a -> State# s -> (# State# s, Int#, a #)
+ {If {\tt MVar\#} is empty, immediately return with integer 0 and value undefined.
+ Otherwise, return with integer 1 and contents of {\tt MVar\#}.}
+ with
+ out_of_line = True
+ has_side_effects = True
+
primop SameMVarOp "sameMVar#" GenPrimOp
- MVar# s a -> MVar# s a -> Bool
+ MVar# s a -> MVar# s a -> Int#
primop IsEmptyMVarOp "isEmptyMVar#" GenPrimOp
MVar# s a -> State# s -> (# State# s, Int# #)
@@ -1871,8 +1908,15 @@ primop MkWeakNoFinalizerOp "mkWeakNoFinalizer#" GenPrimOp
has_side_effects = True
out_of_line = True
-primop MkWeakForeignEnvOp "mkWeakForeignEnv#" GenPrimOp
- o -> b -> Addr# -> Addr# -> Int# -> Addr# -> State# RealWorld -> (# State# RealWorld, Weak# b #)
+primop AddCFinalizerToWeakOp "addCFinalizerToWeak#" GenPrimOp
+ Addr# -> Addr# -> Int# -> Addr# -> Weak# b
+ -> State# RealWorld -> (# State# RealWorld, Int# #)
+ { {\tt addCFinalizerToWeak# fptr ptr flag eptr w} attaches a C
+ function pointer {\tt fptr} to a weak pointer {\tt w} as a finalizer. If
+ {\tt flag} is zero, {\tt fptr} will be called with one argument,
+ {\tt ptr}. Otherwise, it will be called with two arguments,
+ {\tt eptr} and {\tt ptr}. {\tt addCFinalizerToWeak#} returns
+ 1 on success, or 0 if {\tt w} is already dead. }
with
has_side_effects = True
out_of_line = True
View Lorry Controller Status