diff options
Diffstat (limited to 'compiler/prelude')
| -rw-r--r-- | compiler/prelude/PrelNames.hs | 2 | ||||
| -rw-r--r-- | compiler/prelude/PrelRules.hs | 48 | ||||
| -rw-r--r-- | compiler/prelude/TysPrim.hs | 7 | ||||
| -rw-r--r-- | compiler/prelude/TysWiredIn.hs | 21 | ||||
| -rw-r--r-- | compiler/prelude/primops.txt.pp | 15 |
5 files changed, 75 insertions, 18 deletions
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index 2acb2a0019..3bcc8670ff 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -2092,6 +2092,7 @@ errorIdKey = mkPreludeMiscIdUnique 5 foldrIdKey = mkPreludeMiscIdUnique 6 recSelErrorIdKey = mkPreludeMiscIdUnique 7 seqIdKey = mkPreludeMiscIdUnique 8 +absentSumFieldErrorIdKey = mkPreludeMiscIdUnique 9 eqStringIdKey = mkPreludeMiscIdUnique 10 noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 11 nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 12 @@ -2107,7 +2108,6 @@ voidPrimIdKey = mkPreludeMiscIdUnique 21 typeErrorIdKey = mkPreludeMiscIdUnique 22 divIntIdKey = mkPreludeMiscIdUnique 23 modIntIdKey = mkPreludeMiscIdUnique 24 -absentSumFieldErrorIdKey = mkPreludeMiscIdUnique 9 unsafeCoerceIdKey, concatIdKey, filterIdKey, zipIdKey, bindIOIdKey, returnIOIdKey, newStablePtrIdKey, diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs index ffee79da36..c6c27f8ffe 100644 --- a/compiler/prelude/PrelRules.hs +++ b/compiler/prelude/PrelRules.hs @@ -191,29 +191,35 @@ primOpRules nm Int2WordOp = mkPrimOpRule nm 1 [ liftLitDynFlags int2WordLit primOpRules nm Narrow8IntOp = mkPrimOpRule nm 1 [ liftLit narrow8IntLit , subsumedByPrimOp Narrow8IntOp , Narrow8IntOp `subsumesPrimOp` Narrow16IntOp - , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp ] + , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp + , narrowSubsumesAnd AndIOp Narrow8IntOp 8 ] primOpRules nm Narrow16IntOp = mkPrimOpRule nm 1 [ liftLit narrow16IntLit , subsumedByPrimOp Narrow8IntOp , subsumedByPrimOp Narrow16IntOp - , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp ] + , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp + , narrowSubsumesAnd AndIOp Narrow16IntOp 16 ] primOpRules nm Narrow32IntOp = mkPrimOpRule nm 1 [ liftLit narrow32IntLit , subsumedByPrimOp Narrow8IntOp , subsumedByPrimOp Narrow16IntOp , subsumedByPrimOp Narrow32IntOp - , removeOp32 ] + , removeOp32 + , narrowSubsumesAnd AndIOp Narrow32IntOp 32 ] primOpRules nm Narrow8WordOp = mkPrimOpRule nm 1 [ liftLit narrow8WordLit , subsumedByPrimOp Narrow8WordOp , Narrow8WordOp `subsumesPrimOp` Narrow16WordOp - , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp ] + , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp + , narrowSubsumesAnd AndOp Narrow8WordOp 8 ] primOpRules nm Narrow16WordOp = mkPrimOpRule nm 1 [ liftLit narrow16WordLit , subsumedByPrimOp Narrow8WordOp , subsumedByPrimOp Narrow16WordOp - , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp ] + , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp + , narrowSubsumesAnd AndOp Narrow16WordOp 16 ] primOpRules nm Narrow32WordOp = mkPrimOpRule nm 1 [ liftLit narrow32WordLit , subsumedByPrimOp Narrow8WordOp , subsumedByPrimOp Narrow16WordOp , subsumedByPrimOp Narrow32WordOp - , removeOp32 ] + , removeOp32 + , narrowSubsumesAnd AndOp Narrow32WordOp 32 ] primOpRules nm OrdOp = mkPrimOpRule nm 1 [ liftLit char2IntLit , inversePrimOp ChrOp ] primOpRules nm ChrOp = mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs @@ -649,6 +655,26 @@ subsumedByPrimOp primop = do matchPrimOpId primop primop_id return e +-- | narrow subsumes bitwise `and` with full mask (cf #16402): +-- +-- narrowN (x .&. m) +-- m .&. (2^N-1) = 2^N-1 +-- ==> narrowN x +-- +-- e.g. narrow16 (x .&. 0xFFFF) +-- ==> narrow16 x +-- +narrowSubsumesAnd :: PrimOp -> PrimOp -> Int -> RuleM CoreExpr +narrowSubsumesAnd and_primop narrw n = do + [Var primop_id `App` x `App` y] <- getArgs + matchPrimOpId and_primop primop_id + let mask = bit n -1 + g v (Lit (LitNumber _ m _)) = do + guard (m .&. mask == mask) + return (Var (mkPrimOpId narrw) `App` v) + g _ _ = mzero + g x y <|> g y x + idempotent :: RuleM CoreExpr idempotent = do [e1, e2] <- getArgs guard $ cheapEqExpr e1 e2 @@ -733,8 +759,8 @@ There are two cases: from the 'integer' library. These are handled by rule_shift_op, and match_Integer_shift_op. - Here we could in principle shift by any amount, but we arbitary - limit the shift to 4 bits; in particualr we do not want shift by a + Here we could in principle shift by any amount, but we arbitrary + limit the shift to 4 bits; in particular we do not want shift by a huge amount, which can happen in code like that above. The two cases are more different in their code paths that is comfortable, @@ -855,7 +881,7 @@ leftIdentityDynFlags id_lit = do 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. +-- addition to the result, we have to indicate that no carry/overflow occurred. leftIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr leftIdentityCDynFlags id_lit = do dflags <- getDynFlags @@ -872,7 +898,7 @@ rightIdentityDynFlags id_lit = do 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. +-- addition to the result, we have to indicate that no carry/overflow occurred. rightIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr rightIdentityCDynFlags id_lit = do dflags <- getDynFlags @@ -886,7 +912,7 @@ 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. +-- to the result, we have to indicate that no carry/overflow occurred. identityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr identityCDynFlags lit = leftIdentityCDynFlags lit `mplus` rightIdentityCDynFlags lit diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs index 79a30482b0..a023c430fe 100644 --- a/compiler/prelude/TysPrim.hs +++ b/compiler/prelude/TysPrim.hs @@ -239,7 +239,7 @@ tVarPrimTyConName = mkPrimTc (fsLit "TVar#") tVarPrimTyConKey tVarPr stablePtrPrimTyConName = mkPrimTc (fsLit "StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon stableNamePrimTyConName = mkPrimTc (fsLit "StableName#") stableNamePrimTyConKey stableNamePrimTyCon compactPrimTyConName = mkPrimTc (fsLit "Compact#") compactPrimTyConKey compactPrimTyCon -bcoPrimTyConName = mkPrimTc (fsLit "BCO#") bcoPrimTyConKey bcoPrimTyCon +bcoPrimTyConName = mkPrimTc (fsLit "BCO") bcoPrimTyConKey bcoPrimTyCon weakPrimTyConName = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon threadIdPrimTyConName = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon @@ -1052,10 +1052,13 @@ compactPrimTy = mkTyConTy compactPrimTyCon ************************************************************************ -} +-- Unlike most other primitive types, BCO is lifted. This is because in +-- general a BCO may be a thunk for the reasons given in Note [Updatable CAF +-- BCOs] in GHCi.CreateBCO. bcoPrimTy :: Type bcoPrimTy = mkTyConTy bcoPrimTyCon bcoPrimTyCon :: TyCon -bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName UnliftedRep +bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName LiftedRep {- ************************************************************************ diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs index b1ba7bf4b2..de7ec7ec81 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -260,6 +260,27 @@ eqTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "~") eqTyConK eqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#") eqDataConKey eqDataCon eqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "eq_sel") eqSCSelIdKey eqSCSelId +{- Note [eqTyCon (~) is built-in syntax] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The (~) type operator used in equality constraints (a~b) is considered built-in +syntax. This has a few consequences: + +* The user is not allowed to define their own type constructors with this name: + + ghci> class a ~ b + <interactive>:1:1: error: Illegal binding of built-in syntax: ~ + +* Writing (a ~ b) does not require enabling -XTypeOperators. It does, however, + require -XGADTs or -XTypeFamilies. + +* The (~) type operator is always in scope. It doesn't need to be be imported, + and it cannot be hidden. + +* We have a bunch of special cases in the compiler to arrange all of the above. + +There's no particular reason for (~) to be special, but fixing this would be a +breaking change. +-} eqTyCon_RDR :: RdrName eqTyCon_RDR = nameRdrName eqTyConName diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index f47880b58d..de7d498da1 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -251,6 +251,13 @@ primop IntMulOp "*#" with commutable = True fixity = infixl 7 +primop IntMul2Op "timesInt2#" GenPrimOp + Int# -> Int# -> (# Int#, Int#, Int# #) + {Return a triple (isHighNeeded,high,low) where high and low are respectively + the high and low bits of the double-word result. isHighNeeded is a cheap way + to test if the high word is a sign-extension of the low word (isHighNeeded = + 0#) or not (isHighNeeded = 1#).} + primop IntMulMayOfloOp "mulIntMayOflo#" Dyadic Int# -> Int# -> Int# {Return non-zero if there is any possibility that the upper word of a @@ -2057,7 +2064,7 @@ primop FetchAddByteArrayOp_Int "fetchAddIntArray#" GenPrimOp primop FetchSubByteArrayOp_Int "fetchSubIntArray#" GenPrimOp MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) {Given an array, and offset in machine words, and a value to subtract, - atomically substract the value to the element. Returns the value of + atomically subtract the value to the element. Returns the value of the element before the operation. Implies a full memory barrier.} with has_side_effects = True can_fail = True @@ -3242,7 +3249,7 @@ section "Bytecode operations" contain a list of instructions and data needed by these instructions.} ------------------------------------------------------------------------ -primtype BCO# +primtype BCO { Primitive bytecode type. } primop AddrToAnyOp "addrToAny#" GenPrimOp @@ -3267,14 +3274,14 @@ primop AnyToAddrOp "anyToAddr#" GenPrimOp code_size = 0 primop MkApUpd0_Op "mkApUpd0#" GenPrimOp - BCO# -> (# a #) + BCO -> (# a #) { Wrap a BCO in a {\tt AP_UPD} thunk which will be updated with the value of the BCO when evaluated. } with out_of_line = True primop NewBCOOp "newBCO#" GenPrimOp - ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s, BCO# #) + ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s, BCO #) { {\tt newBCO\# instrs lits ptrs arity bitmap} creates a new bytecode object. The resulting object encodes a function of the given arity with the instructions encoded in {\tt instrs}, and a static reference table usage bitmap given by |