diff options
34 files changed, 952 insertions, 77 deletions
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs index 11e4df5bf4..a5d1a8e375 100644 --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -99,6 +99,8 @@ primRepCmmType dflags IntRep = bWord dflags primRepCmmType dflags WordRep = bWord dflags primRepCmmType _ Int8Rep = b8 primRepCmmType _ Word8Rep = b8 +primRepCmmType _ Int16Rep = b16 +primRepCmmType _ Word16Rep = b16 primRepCmmType _ Int64Rep = b64 primRepCmmType _ Word64Rep = b64 primRepCmmType dflags AddrRep = bWord dflags @@ -134,9 +136,11 @@ primRepForeignHint LiftedRep = AddrHint primRepForeignHint UnliftedRep = AddrHint primRepForeignHint IntRep = SignedHint primRepForeignHint Int8Rep = SignedHint +primRepForeignHint Int16Rep = SignedHint primRepForeignHint Int64Rep = SignedHint primRepForeignHint WordRep = NoHint primRepForeignHint Word8Rep = NoHint +primRepForeignHint Word16Rep = NoHint primRepForeignHint Word64Rep = NoHint primRepForeignHint AddrRep = AddrHint -- NB! AddrHint, but NonPtrArg primRepForeignHint FloatRep = NoHint diff --git a/compiler/codeGen/StgCmmArgRep.hs b/compiler/codeGen/StgCmmArgRep.hs index 95f96dc16f..7d1962fd09 100644 --- a/compiler/codeGen/StgCmmArgRep.hs +++ b/compiler/codeGen/StgCmmArgRep.hs @@ -72,6 +72,8 @@ toArgRep IntRep = N toArgRep WordRep = N toArgRep Int8Rep = N -- Gets widened to native word width for calls toArgRep Word8Rep = N -- Gets widened to native word width for calls +toArgRep Int16Rep = N -- Gets widened to native word width for calls +toArgRep Word16Rep = N -- Gets widened to native word width for calls toArgRep AddrRep = N toArgRep Int64Rep = L toArgRep Word64Rep = L diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 75d46b5b3a..eb4d681923 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -884,6 +884,11 @@ callishPrimOpSupported dflags op -> Left (MO_S_QuotRem W8) | otherwise -> Right (genericIntQuotRemOp W8) + Int16QuotRemOp | (ncg && x86ish) + || llvm -> Left (MO_S_QuotRem W16) + | otherwise -> Right (genericIntQuotRemOp W16) + + WordQuotRemOp | ncg && (x86ish || ppc) -> Left (MO_U_QuotRem (wordWidth dflags)) | otherwise -> @@ -898,6 +903,10 @@ callishPrimOpSupported dflags op -> Left (MO_U_QuotRem W8) | otherwise -> Right (genericWordQuotRemOp W8) + Word16QuotRemOp| (ncg && x86ish) + || llvm -> Left (MO_U_QuotRem W16) + | otherwise -> Right (genericWordQuotRemOp W16) + WordAdd2Op | (ncg && (x86ish || ppc)) || llvm -> Left (MO_Add2 (wordWidth dflags)) @@ -1356,6 +1365,42 @@ translateOp _ Word8LeOp = Just (MO_U_Le W8) translateOp _ Word8LtOp = Just (MO_U_Lt W8) translateOp _ Word8NeOp = Just (MO_Ne W8) +-- Int16# signed ops + +translateOp dflags Int16Extend = Just (MO_SS_Conv W16 (wordWidth dflags)) +translateOp dflags Int16Narrow = Just (MO_SS_Conv (wordWidth dflags) W16) +translateOp _ Int16NegOp = Just (MO_S_Neg W16) +translateOp _ Int16AddOp = Just (MO_Add W16) +translateOp _ Int16SubOp = Just (MO_Sub W16) +translateOp _ Int16MulOp = Just (MO_Mul W16) +translateOp _ Int16QuotOp = Just (MO_S_Quot W16) +translateOp _ Int16RemOp = Just (MO_S_Rem W16) + +translateOp _ Int16EqOp = Just (MO_Eq W16) +translateOp _ Int16GeOp = Just (MO_S_Ge W16) +translateOp _ Int16GtOp = Just (MO_S_Gt W16) +translateOp _ Int16LeOp = Just (MO_S_Le W16) +translateOp _ Int16LtOp = Just (MO_S_Lt W16) +translateOp _ Int16NeOp = Just (MO_Ne W16) + +-- Word16# unsigned ops + +translateOp dflags Word16Extend = Just (MO_UU_Conv W16 (wordWidth dflags)) +translateOp dflags Word16Narrow = Just (MO_UU_Conv (wordWidth dflags) W16) +translateOp _ Word16NotOp = Just (MO_Not W16) +translateOp _ Word16AddOp = Just (MO_Add W16) +translateOp _ Word16SubOp = Just (MO_Sub W16) +translateOp _ Word16MulOp = Just (MO_Mul W16) +translateOp _ Word16QuotOp = Just (MO_U_Quot W16) +translateOp _ Word16RemOp = Just (MO_U_Rem W16) + +translateOp _ Word16EqOp = Just (MO_Eq W16) +translateOp _ Word16GeOp = Just (MO_U_Ge W16) +translateOp _ Word16GtOp = Just (MO_U_Gt W16) +translateOp _ Word16LeOp = Just (MO_U_Le W16) +translateOp _ Word16LtOp = Just (MO_U_Lt W16) +translateOp _ Word16NeOp = Just (MO_Ne W16) + -- Char# ops translateOp dflags CharEqOp = Just (MO_Eq (wordWidth dflags)) diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index 46d4484e47..5c86f65bb8 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -1682,7 +1682,8 @@ addrPrimTyConKey, arrayPrimTyConKey, arrayArrayPrimTyConKey, boolTyConKey, byteArrayPrimTyConKey, charPrimTyConKey, charTyConKey, doublePrimTyConKey, doubleTyConKey, floatPrimTyConKey, floatTyConKey, funTyConKey, intPrimTyConKey, intTyConKey, int8TyConKey, int16TyConKey, - int8PrimTyConKey, int32PrimTyConKey, int32TyConKey, int64PrimTyConKey, int64TyConKey, + int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int32TyConKey, + int64PrimTyConKey, int64TyConKey, integerTyConKey, naturalTyConKey, listTyConKey, foreignObjPrimTyConKey, maybeTyConKey, weakPrimTyConKey, mutableArrayPrimTyConKey, mutableArrayArrayPrimTyConKey, @@ -1705,36 +1706,37 @@ intPrimTyConKey = mkPreludeTyConUnique 14 intTyConKey = mkPreludeTyConUnique 15 int8PrimTyConKey = mkPreludeTyConUnique 16 int8TyConKey = mkPreludeTyConUnique 17 -int16TyConKey = mkPreludeTyConUnique 18 -int32PrimTyConKey = mkPreludeTyConUnique 19 -int32TyConKey = mkPreludeTyConUnique 20 -int64PrimTyConKey = mkPreludeTyConUnique 21 -int64TyConKey = mkPreludeTyConUnique 22 -integerTyConKey = mkPreludeTyConUnique 23 -naturalTyConKey = mkPreludeTyConUnique 24 - -listTyConKey = mkPreludeTyConUnique 25 -foreignObjPrimTyConKey = mkPreludeTyConUnique 26 -maybeTyConKey = mkPreludeTyConUnique 27 -weakPrimTyConKey = mkPreludeTyConUnique 28 -mutableArrayPrimTyConKey = mkPreludeTyConUnique 29 -mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 30 -orderingTyConKey = mkPreludeTyConUnique 31 -mVarPrimTyConKey = mkPreludeTyConUnique 32 -ratioTyConKey = mkPreludeTyConUnique 33 -rationalTyConKey = mkPreludeTyConUnique 34 -realWorldTyConKey = mkPreludeTyConUnique 35 -stablePtrPrimTyConKey = mkPreludeTyConUnique 36 -stablePtrTyConKey = mkPreludeTyConUnique 37 -eqTyConKey = mkPreludeTyConUnique 39 -heqTyConKey = mkPreludeTyConUnique 40 -arrayArrayPrimTyConKey = mkPreludeTyConUnique 41 -mutableArrayArrayPrimTyConKey = mkPreludeTyConUnique 42 +int16PrimTyConKey = mkPreludeTyConUnique 18 +int16TyConKey = mkPreludeTyConUnique 19 +int32PrimTyConKey = mkPreludeTyConUnique 20 +int32TyConKey = mkPreludeTyConUnique 21 +int64PrimTyConKey = mkPreludeTyConUnique 22 +int64TyConKey = mkPreludeTyConUnique 23 +integerTyConKey = mkPreludeTyConUnique 24 +naturalTyConKey = mkPreludeTyConUnique 25 + +listTyConKey = mkPreludeTyConUnique 26 +foreignObjPrimTyConKey = mkPreludeTyConUnique 27 +maybeTyConKey = mkPreludeTyConUnique 28 +weakPrimTyConKey = mkPreludeTyConUnique 29 +mutableArrayPrimTyConKey = mkPreludeTyConUnique 30 +mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 31 +orderingTyConKey = mkPreludeTyConUnique 32 +mVarPrimTyConKey = mkPreludeTyConUnique 33 +ratioTyConKey = mkPreludeTyConUnique 34 +rationalTyConKey = mkPreludeTyConUnique 35 +realWorldTyConKey = mkPreludeTyConUnique 36 +stablePtrPrimTyConKey = mkPreludeTyConUnique 37 +stablePtrTyConKey = mkPreludeTyConUnique 38 +eqTyConKey = mkPreludeTyConUnique 40 +heqTyConKey = mkPreludeTyConUnique 41 +arrayArrayPrimTyConKey = mkPreludeTyConUnique 42 +mutableArrayArrayPrimTyConKey = mkPreludeTyConUnique 43 statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, mutVarPrimTyConKey, ioTyConKey, wordPrimTyConKey, wordTyConKey, word8PrimTyConKey, word8TyConKey, - word16TyConKey, word32PrimTyConKey, word32TyConKey, + word16PrimTyConKey, word16TyConKey, word32PrimTyConKey, word32TyConKey, word64PrimTyConKey, word64TyConKey, liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey, typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey, @@ -1754,23 +1756,24 @@ wordPrimTyConKey = mkPreludeTyConUnique 59 wordTyConKey = mkPreludeTyConUnique 60 word8PrimTyConKey = mkPreludeTyConUnique 61 word8TyConKey = mkPreludeTyConUnique 62 -word16TyConKey = mkPreludeTyConUnique 63 -word32PrimTyConKey = mkPreludeTyConUnique 64 -word32TyConKey = mkPreludeTyConUnique 65 -word64PrimTyConKey = mkPreludeTyConUnique 66 -word64TyConKey = mkPreludeTyConUnique 67 -liftedConKey = mkPreludeTyConUnique 68 -unliftedConKey = mkPreludeTyConUnique 69 -anyBoxConKey = mkPreludeTyConUnique 70 -kindConKey = mkPreludeTyConUnique 71 -boxityConKey = mkPreludeTyConUnique 72 -typeConKey = mkPreludeTyConUnique 73 -threadIdPrimTyConKey = mkPreludeTyConUnique 74 -bcoPrimTyConKey = mkPreludeTyConUnique 75 -ptrTyConKey = mkPreludeTyConUnique 76 -funPtrTyConKey = mkPreludeTyConUnique 77 -tVarPrimTyConKey = mkPreludeTyConUnique 78 -compactPrimTyConKey = mkPreludeTyConUnique 79 +word16PrimTyConKey = mkPreludeTyConUnique 63 +word16TyConKey = mkPreludeTyConUnique 64 +word32PrimTyConKey = mkPreludeTyConUnique 65 +word32TyConKey = mkPreludeTyConUnique 66 +word64PrimTyConKey = mkPreludeTyConUnique 67 +word64TyConKey = mkPreludeTyConUnique 68 +liftedConKey = mkPreludeTyConUnique 69 +unliftedConKey = mkPreludeTyConUnique 70 +anyBoxConKey = mkPreludeTyConUnique 71 +kindConKey = mkPreludeTyConUnique 72 +boxityConKey = mkPreludeTyConUnique 73 +typeConKey = mkPreludeTyConUnique 74 +threadIdPrimTyConKey = mkPreludeTyConUnique 75 +bcoPrimTyConKey = mkPreludeTyConUnique 76 +ptrTyConKey = mkPreludeTyConUnique 77 +funPtrTyConKey = mkPreludeTyConUnique 78 +tVarPrimTyConKey = mkPreludeTyConUnique 79 +compactPrimTyConKey = mkPreludeTyConUnique 80 -- dotnet interop objectTyConKey :: Unique @@ -2044,7 +2047,7 @@ sumRepDataConKey = mkPreludeDataConUnique 73 runtimeRepSimpleDataConKeys, unliftedSimpleRepDataConKeys, unliftedRepDataConKeys :: [Unique] liftedRepDataConKey :: Unique runtimeRepSimpleDataConKeys@(liftedRepDataConKey : unliftedSimpleRepDataConKeys) - = map mkPreludeDataConUnique [74..84] + = map mkPreludeDataConUnique [74..86] unliftedRepDataConKeys = vecRepDataConKey : tupleRepDataConKey : @@ -2054,29 +2057,29 @@ unliftedRepDataConKeys = vecRepDataConKey : -- See Note [Wiring in RuntimeRep] in TysWiredIn -- VecCount vecCountDataConKeys :: [Unique] -vecCountDataConKeys = map mkPreludeDataConUnique [85..90] +vecCountDataConKeys = map mkPreludeDataConUnique [87..92] -- See Note [Wiring in RuntimeRep] in TysWiredIn -- VecElem vecElemDataConKeys :: [Unique] -vecElemDataConKeys = map mkPreludeDataConUnique [91..100] +vecElemDataConKeys = map mkPreludeDataConUnique [93..102] -- Typeable things kindRepTyConAppDataConKey, kindRepVarDataConKey, kindRepAppDataConKey, kindRepFunDataConKey, kindRepTYPEDataConKey, kindRepTypeLitSDataConKey, kindRepTypeLitDDataConKey :: Unique -kindRepTyConAppDataConKey = mkPreludeDataConUnique 101 -kindRepVarDataConKey = mkPreludeDataConUnique 102 -kindRepAppDataConKey = mkPreludeDataConUnique 103 -kindRepFunDataConKey = mkPreludeDataConUnique 104 -kindRepTYPEDataConKey = mkPreludeDataConUnique 105 -kindRepTypeLitSDataConKey = mkPreludeDataConUnique 106 -kindRepTypeLitDDataConKey = mkPreludeDataConUnique 107 +kindRepTyConAppDataConKey = mkPreludeDataConUnique 103 +kindRepVarDataConKey = mkPreludeDataConUnique 104 +kindRepAppDataConKey = mkPreludeDataConUnique 105 +kindRepFunDataConKey = mkPreludeDataConUnique 106 +kindRepTYPEDataConKey = mkPreludeDataConUnique 107 +kindRepTypeLitSDataConKey = mkPreludeDataConUnique 108 +kindRepTypeLitDDataConKey = mkPreludeDataConUnique 109 typeLitSymbolDataConKey, typeLitNatDataConKey :: Unique -typeLitSymbolDataConKey = mkPreludeDataConUnique 108 -typeLitNatDataConKey = mkPreludeDataConUnique 109 +typeLitSymbolDataConKey = mkPreludeDataConUnique 110 +typeLitNatDataConKey = mkPreludeDataConUnique 111 ---------------- Template Haskell ------------------- diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs index 7d04788d51..4147cff53b 100644 --- a/compiler/prelude/TysPrim.hs +++ b/compiler/prelude/TysPrim.hs @@ -69,6 +69,9 @@ module TysPrim( int8PrimTyCon, int8PrimTy, word8PrimTyCon, word8PrimTy, + int16PrimTyCon, int16PrimTy, + word16PrimTyCon, word16PrimTy, + int32PrimTyCon, int32PrimTy, word32PrimTyCon, word32PrimTy, @@ -91,6 +94,7 @@ import {-# SOURCE #-} TysWiredIn ( runtimeRepTy, unboxedTupleKind, liftedTypeKind , vecRepDataConTyCon, tupleRepDataConTyCon , liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, int8RepDataConTy + , int16RepDataConTy, word16RepDataConTy , wordRepDataConTy, int64RepDataConTy, word8RepDataConTy, word64RepDataConTy , addrRepDataConTy , floatRepDataConTy, doubleRepDataConTy @@ -150,6 +154,7 @@ exposedPrimTyCons , floatPrimTyCon , intPrimTyCon , int8PrimTyCon + , int16PrimTyCon , int32PrimTyCon , int64PrimTyCon , bcoPrimTyCon @@ -171,6 +176,7 @@ exposedPrimTyCons , threadIdPrimTyCon , wordPrimTyCon , word8PrimTyCon + , word16PrimTyCon , word32PrimTyCon , word64PrimTyCon @@ -194,14 +200,16 @@ mkBuiltInPrimTc fs unique tycon BuiltInSyntax -charPrimTyConName, intPrimTyConName, int8PrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, voidPrimTyConName :: Name +charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, voidPrimTyConName :: Name charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon int8PrimTyConName = mkPrimTc (fsLit "Int8#") int8PrimTyConKey int8PrimTyCon +int16PrimTyConName = mkPrimTc (fsLit "Int16#") int16PrimTyConKey int16PrimTyCon int32PrimTyConName = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon int64PrimTyConName = mkPrimTc (fsLit "Int64#") int64PrimTyConKey int64PrimTyCon wordPrimTyConName = mkPrimTc (fsLit "Word#") wordPrimTyConKey wordPrimTyCon word8PrimTyConName = mkPrimTc (fsLit "Word8#") word8PrimTyConKey word8PrimTyCon +word16PrimTyConName = mkPrimTc (fsLit "Word16#") word16PrimTyConKey word16PrimTyCon word32PrimTyConName = mkPrimTc (fsLit "Word32#") word32PrimTyConKey word32PrimTyCon word64PrimTyConName = mkPrimTc (fsLit "Word64#") word64PrimTyConKey word64PrimTyCon addrPrimTyConName = mkPrimTc (fsLit "Addr#") addrPrimTyConKey addrPrimTyCon @@ -522,9 +530,11 @@ primRepToRuntimeRep rep = case rep of UnliftedRep -> unliftedRepDataConTy IntRep -> intRepDataConTy Int8Rep -> int8RepDataConTy + Int16Rep -> int16RepDataConTy WordRep -> wordRepDataConTy Int64Rep -> int64RepDataConTy Word8Rep -> word8RepDataConTy + Word16Rep -> word16RepDataConTy Word64Rep -> word64RepDataConTy AddrRep -> addrRepDataConTy FloatRep -> floatRepDataConTy @@ -571,6 +581,11 @@ int8PrimTy = mkTyConTy int8PrimTyCon int8PrimTyCon :: TyCon int8PrimTyCon = pcPrimTyCon0 int8PrimTyConName Int8Rep +int16PrimTy :: Type +int16PrimTy = mkTyConTy int16PrimTyCon +int16PrimTyCon :: TyCon +int16PrimTyCon = pcPrimTyCon0 int16PrimTyConName Int16Rep + int32PrimTy :: Type int32PrimTy = mkTyConTy int32PrimTyCon int32PrimTyCon :: TyCon @@ -591,6 +606,11 @@ word8PrimTy = mkTyConTy word8PrimTyCon word8PrimTyCon :: TyCon word8PrimTyCon = pcPrimTyCon0 word8PrimTyConName Word8Rep +word16PrimTy :: Type +word16PrimTy = mkTyConTy word16PrimTyCon +word16PrimTyCon :: TyCon +word16PrimTyCon = pcPrimTyCon0 word16PrimTyConName Word16Rep + word32PrimTy :: Type word32PrimTy = mkTyConTy word32PrimTyCon word32PrimTyCon :: TyCon diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs index 7ceeeffd46..a0a043dfa9 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -108,6 +108,7 @@ module TysWiredIn ( vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon, liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, int8RepDataConTy, + int16RepDataConTy, word16RepDataConTy, wordRepDataConTy, int64RepDataConTy, word8RepDataConTy, word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy, @@ -420,8 +421,10 @@ runtimeRepSimpleDataConNames , fsLit "IntRep" , fsLit "WordRep" , fsLit "Int8Rep" + , fsLit "Int16Rep" , fsLit "Int64Rep" , fsLit "Word8Rep" + , fsLit "Word16Rep" , fsLit "Word64Rep" , fsLit "AddrRep" , fsLit "FloatRep" @@ -1179,8 +1182,8 @@ runtimeRepSimpleDataCons :: [DataCon] liftedRepDataCon :: DataCon runtimeRepSimpleDataCons@(liftedRepDataCon : _) = zipWithLazy mk_runtime_rep_dc - [ LiftedRep, UnliftedRep, IntRep, WordRep, Int8Rep, Int64Rep - , Word8Rep, Word64Rep, AddrRep, FloatRep, DoubleRep ] + [ LiftedRep, UnliftedRep, IntRep, WordRep, Int8Rep, Int16Rep, Int64Rep + , Word8Rep, Word16Rep, Word64Rep, AddrRep, FloatRep, DoubleRep ] runtimeRepSimpleDataConNames where mk_runtime_rep_dc primrep name @@ -1188,12 +1191,12 @@ runtimeRepSimpleDataCons@(liftedRepDataCon : _) -- See Note [Wiring in RuntimeRep] liftedRepDataConTy, unliftedRepDataConTy, - intRepDataConTy, int8RepDataConTy, wordRepDataConTy, int64RepDataConTy, - word8RepDataConTy, word64RepDataConTy, addrRepDataConTy, + intRepDataConTy, int8RepDataConTy, int16RepDataConTy, wordRepDataConTy, int64RepDataConTy, + word8RepDataConTy, word16RepDataConTy, word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy :: Type [liftedRepDataConTy, unliftedRepDataConTy, - intRepDataConTy, wordRepDataConTy, int8RepDataConTy, int64RepDataConTy, - word8RepDataConTy, word64RepDataConTy, + intRepDataConTy, wordRepDataConTy, int8RepDataConTy, int16RepDataConTy, int64RepDataConTy, + word8RepDataConTy, word16RepDataConTy, word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy] = map (mkTyConTy . promoteDataCon) runtimeRepSimpleDataCons diff --git a/compiler/prelude/TysWiredIn.hs-boot b/compiler/prelude/TysWiredIn.hs-boot index b853290da3..1481a758b1 100644 --- a/compiler/prelude/TysWiredIn.hs-boot +++ b/compiler/prelude/TysWiredIn.hs-boot @@ -25,6 +25,7 @@ runtimeRepTy :: Type liftedRepDataConTyCon, vecRepDataConTyCon, tupleRepDataConTyCon :: TyCon liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, int8RepDataConTy, + int16RepDataConTy, word16RepDataConTy, wordRepDataConTy, int64RepDataConTy, word8RepDataConTy, word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy :: Type diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 8fceec0107..bf69776166 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -426,6 +426,88 @@ primop Word8LtOp "ltWord8#" Compare Word8# -> Word8# -> Int# primop Word8NeOp "neWord8#" Compare Word8# -> Word8# -> Int# ------------------------------------------------------------------------ +section "Int16#" + {Operations on 16-bit integers.} +------------------------------------------------------------------------ + +primtype Int16# + +primop Int16Extend "extendInt16#" GenPrimOp Int16# -> Int# +primop Int16Narrow "narrowInt16#" GenPrimOp Int# -> Int16# + +primop Int16NegOp "negateInt16#" Monadic Int16# -> Int16# + +primop Int16AddOp "plusInt16#" Dyadic Int16# -> Int16# -> Int16# + with + commutable = True + +primop Int16SubOp "subInt16#" Dyadic Int16# -> Int16# -> Int16# + +primop Int16MulOp "timesInt16#" Dyadic Int16# -> Int16# -> Int16# + with + commutable = True + +primop Int16QuotOp "quotInt16#" Dyadic Int16# -> Int16# -> Int16# + with + can_fail = True + +primop Int16RemOp "remInt16#" Dyadic Int16# -> Int16# -> Int16# + with + can_fail = True + +primop Int16QuotRemOp "quotRemInt16#" GenPrimOp Int16# -> Int16# -> (# Int16#, Int16# #) + with + can_fail = True + +primop Int16EqOp "eqInt16#" Compare Int16# -> Int16# -> Int# +primop Int16GeOp "geInt16#" Compare Int16# -> Int16# -> Int# +primop Int16GtOp "gtInt16#" Compare Int16# -> Int16# -> Int# +primop Int16LeOp "leInt16#" Compare Int16# -> Int16# -> Int# +primop Int16LtOp "ltInt16#" Compare Int16# -> Int16# -> Int# +primop Int16NeOp "neInt16#" Compare Int16# -> Int16# -> Int# + +------------------------------------------------------------------------ +section "Word16#" + {Operations on 16-bit unsigned integers.} +------------------------------------------------------------------------ + +primtype Word16# + +primop Word16Extend "extendWord16#" GenPrimOp Word16# -> Word# +primop Word16Narrow "narrowWord16#" GenPrimOp Word# -> Word16# + +primop Word16NotOp "notWord16#" Monadic Word16# -> Word16# + +primop Word16AddOp "plusWord16#" Dyadic Word16# -> Word16# -> Word16# + with + commutable = True + +primop Word16SubOp "subWord16#" Dyadic Word16# -> Word16# -> Word16# + +primop Word16MulOp "timesWord16#" Dyadic Word16# -> Word16# -> Word16# + with + commutable = True + +primop Word16QuotOp "quotWord16#" Dyadic Word16# -> Word16# -> Word16# + with + can_fail = True + +primop Word16RemOp "remWord16#" Dyadic Word16# -> Word16# -> Word16# + with + can_fail = True + +primop Word16QuotRemOp "quotRemWord16#" GenPrimOp Word16# -> Word16# -> (# Word16#, Word16# #) + with + can_fail = True + +primop Word16EqOp "eqWord16#" Compare Word16# -> Word16# -> Int# +primop Word16GeOp "geWord16#" Compare Word16# -> Word16# -> Int# +primop Word16GtOp "gtWord16#" Compare Word16# -> Word16# -> Int# +primop Word16LeOp "leWord16#" Compare Word16# -> Word16# -> Int# +primop Word16LtOp "ltWord16#" Compare Word16# -> Word16# -> Int# +primop Word16NeOp "neWord16#" Compare Word16# -> Word16# -> Int# + +------------------------------------------------------------------------ section "Word#" {Operations on native-sized unsigned words (32+ bits).} ------------------------------------------------------------------------ diff --git a/compiler/simplStg/RepType.hs b/compiler/simplStg/RepType.hs index a5b8ea67db..eb148b15b4 100644 --- a/compiler/simplStg/RepType.hs +++ b/compiler/simplStg/RepType.hs @@ -259,9 +259,11 @@ primRepSlot LiftedRep = PtrSlot primRepSlot UnliftedRep = PtrSlot primRepSlot IntRep = WordSlot primRepSlot Int8Rep = WordSlot +primRepSlot Int16Rep = WordSlot primRepSlot Int64Rep = Word64Slot primRepSlot WordRep = WordSlot primRepSlot Word8Rep = WordSlot +primRepSlot Word16Rep = WordSlot primRepSlot Word64Rep = Word64Slot primRepSlot AddrRep = WordSlot primRepSlot FloatRep = FloatSlot diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index f4a23851dc..c3e7372278 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -1452,12 +1452,15 @@ gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR, eqChar_RDR , ltChar_RDR , geChar_RDR , gtChar_RDR , leChar_RDR , eqInt_RDR , ltInt_RDR , geInt_RDR , gtInt_RDR , leInt_RDR , eqInt8_RDR , ltInt8_RDR , geInt8_RDR , gtInt8_RDR , leInt8_RDR , + eqInt16_RDR , ltInt16_RDR , geInt16_RDR , gtInt16_RDR , leInt16_RDR , eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR , eqWord8_RDR , ltWord8_RDR , geWord8_RDR , gtWord8_RDR , leWord8_RDR , + eqWord16_RDR, ltWord16_RDR, geWord16_RDR, gtWord16_RDR, leWord16_RDR, eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR , eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR , eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR, - extendWord8_RDR, extendInt8_RDR :: RdrName + extendWord8_RDR, extendInt8_RDR, + extendWord16_RDR, extendInt16_RDR :: RdrName gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl") gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold") toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr") @@ -1492,17 +1495,29 @@ leInt8_RDR = varQual_RDR gHC_PRIM (fsLit "leInt8#") gtInt8_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt8#" ) geInt8_RDR = varQual_RDR gHC_PRIM (fsLit "geInt8#") +eqInt16_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt16#") +ltInt16_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt16#" ) +leInt16_RDR = varQual_RDR gHC_PRIM (fsLit "leInt16#") +gtInt16_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt16#" ) +geInt16_RDR = varQual_RDR gHC_PRIM (fsLit "geInt16#") + eqWord_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord#") ltWord_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord#") leWord_RDR = varQual_RDR gHC_PRIM (fsLit "leWord#") gtWord_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord#") geWord_RDR = varQual_RDR gHC_PRIM (fsLit "geWord#") -eqWord8_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord8#") -ltWord8_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord8#" ) -leWord8_RDR = varQual_RDR gHC_PRIM (fsLit "leWord8#") -gtWord8_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord8#" ) -geWord8_RDR = varQual_RDR gHC_PRIM (fsLit "geWord8#") +eqWord8_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord8#") +ltWord8_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord8#" ) +leWord8_RDR = varQual_RDR gHC_PRIM (fsLit "leWord8#") +gtWord8_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord8#" ) +geWord8_RDR = varQual_RDR gHC_PRIM (fsLit "geWord8#") + +eqWord16_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord16#") +ltWord16_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord16#" ) +leWord16_RDR = varQual_RDR gHC_PRIM (fsLit "leWord16#") +gtWord16_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord16#" ) +geWord16_RDR = varQual_RDR gHC_PRIM (fsLit "geWord16#") eqAddr_RDR = varQual_RDR gHC_PRIM (fsLit "eqAddr#") ltAddr_RDR = varQual_RDR gHC_PRIM (fsLit "ltAddr#") @@ -1525,6 +1540,9 @@ geDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">=##") extendWord8_RDR = varQual_RDR gHC_PRIM (fsLit "extendWord8#") extendInt8_RDR = varQual_RDR gHC_PRIM (fsLit "extendInt8#") +extendWord16_RDR = varQual_RDR gHC_PRIM (fsLit "extendWord16#") +extendInt16_RDR = varQual_RDR gHC_PRIM (fsLit "extendInt16#") + {- ************************************************************************ @@ -2133,8 +2151,10 @@ ordOpTbl = [(charPrimTy , (ltChar_RDR , leChar_RDR , eqChar_RDR , geChar_RDR , gtChar_RDR )) ,(intPrimTy , (ltInt_RDR , leInt_RDR , eqInt_RDR , geInt_RDR , gtInt_RDR )) ,(int8PrimTy , (ltInt8_RDR , leInt8_RDR , eqInt8_RDR , geInt8_RDR , gtInt8_RDR )) + ,(int16PrimTy , (ltInt16_RDR , leInt16_RDR , eqInt16_RDR , geInt16_RDR , gtInt16_RDR )) ,(wordPrimTy , (ltWord_RDR , leWord_RDR , eqWord_RDR , geWord_RDR , gtWord_RDR )) ,(word8PrimTy , (ltWord8_RDR , leWord8_RDR , eqWord8_RDR , geWord8_RDR , gtWord8_RDR )) + ,(word16PrimTy, (ltWord16_RDR, leWord16_RDR, eqWord16_RDR, geWord16_RDR, gtWord16_RDR )) ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR , eqAddr_RDR , geAddr_RDR , gtAddr_RDR )) ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR , eqFloat_RDR , geFloat_RDR , gtFloat_RDR )) ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR, eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ] @@ -2155,6 +2175,12 @@ boxConTbl = , (word8PrimTy, nlHsApp (nlHsVar $ getRdrName wordDataCon) . nlHsApp (nlHsVar extendWord8_RDR)) + , (int16PrimTy, + nlHsApp (nlHsVar $ getRdrName intDataCon) + . nlHsApp (nlHsVar extendInt16_RDR)) + , (word16PrimTy, + nlHsApp (nlHsVar $ getRdrName wordDataCon) + . nlHsApp (nlHsVar extendWord16_RDR)) ] @@ -2168,12 +2194,16 @@ postfixModTbl ,(doublePrimTy, "##") ,(int8PrimTy, "#") ,(word8PrimTy, "##") + ,(int16PrimTy, "#") + ,(word16PrimTy, "##") ] primConvTbl :: [(Type, String)] primConvTbl = [ (int8PrimTy, "narrowInt8#") , (word8PrimTy, "narrowWord8#") + , (int16PrimTy, "narrowInt16#") + , (word16PrimTy, "narrowWord16#") ] litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)] diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs index 29f4b9a2d7..98dbf4b944 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -1326,10 +1326,12 @@ data PrimRep | LiftedRep | UnliftedRep -- ^ Unlifted pointer | Int8Rep -- ^ Signed, 8-bit value + | Int16Rep -- ^ Signed, 16-bit value | IntRep -- ^ Signed, word-sized value | WordRep -- ^ Unsigned, word-sized value | Int64Rep -- ^ Signed, 64 bit value (with 32-bit words only) | Word8Rep -- ^ Unsigned, 8 bit value + | Word16Rep -- ^ Unsigned, 16 bit value | Word64Rep -- ^ Unsigned, 64 bit value (with 32-bit words only) | AddrRep -- ^ A pointer, but /not/ to a Haskell value (use '(Un)liftedRep') | FloatRep @@ -1376,8 +1378,10 @@ primRepSizeB :: DynFlags -> PrimRep -> Int primRepSizeB dflags IntRep = wORD_SIZE dflags primRepSizeB dflags WordRep = wORD_SIZE dflags primRepSizeB _ Int8Rep = 1 +primRepSizeB _ Int16Rep = 2 primRepSizeB _ Int64Rep = wORD64_SIZE primRepSizeB _ Word8Rep = 1 +primRepSizeB _ Word16Rep = 2 primRepSizeB _ Word64Rep = wORD64_SIZE primRepSizeB _ FloatRep = fLOAT_SIZE primRepSizeB dflags DoubleRep = dOUBLE_SIZE dflags diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index 63efd14a5b..9e8133e5e8 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -640,6 +640,8 @@ instance Binary RuntimeRep where #if __GLASGOW_HASKELL__ >= 807 put_ bh Int8Rep = putByte bh 12 put_ bh Word8Rep = putByte bh 13 + put_ bh Int16Rep = putByte bh 14 + put_ bh Word16Rep = putByte bh 15 #endif get bh = do @@ -660,6 +662,8 @@ instance Binary RuntimeRep where #if __GLASGOW_HASKELL__ >= 807 12 -> pure Int8Rep 13 -> pure Word8Rep + 14 -> pure Int16Rep + 15 -> pure Word16Rep #endif _ -> fail "Binary.putRuntimeRep: invalid tag" diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs index cc295b31b8..1be6e27b74 100644 --- a/libraries/base/Data/Typeable/Internal.hs +++ b/libraries/base/Data/Typeable/Internal.hs @@ -665,9 +665,11 @@ runtimeRepTypeRep r = `kApp` buildList (map runtimeRepTypeRep rs) IntRep -> rep @'IntRep Int8Rep -> rep @'Int8Rep + Int16Rep -> rep @'Int16Rep Int64Rep -> rep @'Int64Rep WordRep -> rep @'WordRep Word8Rep -> rep @'Word8Rep + Word16Rep -> rep @'Word16Rep Word64Rep -> rep @'Word64Rep AddrRep -> rep @'AddrRep FloatRep -> rep @'FloatRep diff --git a/libraries/binary b/libraries/binary -Subproject 0318374b832ebe52a8d01bff2dd7bab8e747fbd +Subproject fb461cf048460813a7fac8e040c1004a0d123e4 diff --git a/libraries/ghc-prim/GHC/Types.hs b/libraries/ghc-prim/GHC/Types.hs index 7ab870684d..9f2d3bc15b 100644 --- a/libraries/ghc-prim/GHC/Types.hs +++ b/libraries/ghc-prim/GHC/Types.hs @@ -394,10 +394,12 @@ data RuntimeRep = VecRep VecCount VecElem -- ^ a SIMD vector type | LiftedRep -- ^ lifted; represented by a pointer | UnliftedRep -- ^ unlifted; represented by a pointer | IntRep -- ^ signed, word-sized value - | Int8Rep -- ^ signed, 8-bit value + | Int8Rep -- ^ signed, 8-bit value + | Int16Rep -- ^ signed, 16-bit value | Int64Rep -- ^ signed, 64-bit value (on 32-bit only) | WordRep -- ^ unsigned, word-sized value - | Word8Rep -- ^ unsigned, 8-bit value + | Word8Rep -- ^ unsigned, 8-bit value + | Word16Rep -- ^ unsigned, 16-bit value | Word64Rep -- ^ unsigned, 64-bit value (on 32-bit only) | AddrRep -- ^ A pointer, but /not/ to a Haskell value | FloatRep -- ^ a 32-bit floating point number diff --git a/testsuite/tests/ffi/should_run/PrimFFIInt16.hs b/testsuite/tests/ffi/should_run/PrimFFIInt16.hs new file mode 100644 index 0000000000..6d4eae328f --- /dev/null +++ b/testsuite/tests/ffi/should_run/PrimFFIInt16.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} + +module Main where + +import GHC.Exts + +foreign import ccall "add_all_int16" + add_all_int16 + :: Int16# -> Int16# -> Int16# -> Int16# -> Int16# + -> Int16# -> Int16# -> Int16# -> Int16# -> Int16# + -> Int16# + +main :: IO () +main = do + let a = narrowInt16# 0# + b = narrowInt16# 1# + c = narrowInt16# 2# + d = narrowInt16# 3# + e = narrowInt16# 4# + f = narrowInt16# 5# + g = narrowInt16# 6# + h = narrowInt16# 7# + i = narrowInt16# 8# + j = narrowInt16# 9# + x = I# (extendInt16# (add_all_int16 a b c d e f g h i j)) + print x diff --git a/testsuite/tests/ffi/should_run/PrimFFIInt16.stdout b/testsuite/tests/ffi/should_run/PrimFFIInt16.stdout new file mode 100644 index 0000000000..ea90ee3198 --- /dev/null +++ b/testsuite/tests/ffi/should_run/PrimFFIInt16.stdout @@ -0,0 +1 @@ +45 diff --git a/testsuite/tests/ffi/should_run/PrimFFIInt16_c.c b/testsuite/tests/ffi/should_run/PrimFFIInt16_c.c new file mode 100644 index 0000000000..120c73bc57 --- /dev/null +++ b/testsuite/tests/ffi/should_run/PrimFFIInt16_c.c @@ -0,0 +1,7 @@ +#include <stdint.h> + +int16_t add_all_int16( + int16_t a, int16_t b, int16_t c, int16_t d, int16_t e, + int16_t f, int16_t g, int16_t h, int16_t i, int16_t j) { + return a + b + c + d + e + f + g + h + i + j; +} diff --git a/testsuite/tests/ffi/should_run/PrimFFIWord16.hs b/testsuite/tests/ffi/should_run/PrimFFIWord16.hs new file mode 100644 index 0000000000..0d801433cf --- /dev/null +++ b/testsuite/tests/ffi/should_run/PrimFFIWord16.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} + +module Main where + +import GHC.Exts + +foreign import ccall "add_all_word16" + add_all_word16 + :: Word16# -> Word16# -> Word16# -> Word16# -> Word16# + -> Word16# -> Word16# -> Word16# -> Word16# -> Word16# + -> Word16# + +main :: IO () +main = do + let a = narrowWord16# 0## + b = narrowWord16# 1## + c = narrowWord16# 2## + d = narrowWord16# 3## + e = narrowWord16# 4## + f = narrowWord16# 5## + g = narrowWord16# 6## + h = narrowWord16# 7## + i = narrowWord16# 8## + j = narrowWord16# 9## + x = W# (extendWord16# (add_all_word16 a b c d e f g h i j)) + print x diff --git a/testsuite/tests/ffi/should_run/PrimFFIWord16.stdout b/testsuite/tests/ffi/should_run/PrimFFIWord16.stdout new file mode 100644 index 0000000000..ea90ee3198 --- /dev/null +++ b/testsuite/tests/ffi/should_run/PrimFFIWord16.stdout @@ -0,0 +1 @@ +45 diff --git a/testsuite/tests/ffi/should_run/PrimFFIWord16_c.c b/testsuite/tests/ffi/should_run/PrimFFIWord16_c.c new file mode 100644 index 0000000000..2abf4a0fc3 --- /dev/null +++ b/testsuite/tests/ffi/should_run/PrimFFIWord16_c.c @@ -0,0 +1,7 @@ +#include <stdint.h> + +uint16_t add_all_word16( + uint16_t a, uint16_t b, uint16_t c, uint16_t d, uint16_t e, + uint16_t f, uint16_t g, uint16_t h, uint16_t i, uint16_t j) { + return a + b + c + d + e + f + g + h + i + j; +} diff --git a/testsuite/tests/ffi/should_run/all.T b/testsuite/tests/ffi/should_run/all.T index 9223b3d1b3..7255c91828 100644 --- a/testsuite/tests/ffi/should_run/all.T +++ b/testsuite/tests/ffi/should_run/all.T @@ -192,3 +192,7 @@ test('T12614', [omit_ways(['ghci'])], compile_and_run, ['T12614_c.c']) test('PrimFFIInt8', [omit_ways(['ghci'])], compile_and_run, ['PrimFFIInt8_c.c']) test('PrimFFIWord8', [omit_ways(['ghci'])], compile_and_run, ['PrimFFIWord8_c.c']) + +test('PrimFFIInt16', [omit_ways(['ghci'])], compile_and_run, ['PrimFFIInt16_c.c']) + +test('PrimFFIWord16', [omit_ways(['ghci'])], compile_and_run, ['PrimFFIWord16_c.c'])
\ No newline at end of file diff --git a/testsuite/tests/primops/should_run/ArithInt16.hs b/testsuite/tests/primops/should_run/ArithInt16.hs new file mode 100644 index 0000000000..26d937042e --- /dev/null +++ b/testsuite/tests/primops/should_run/ArithInt16.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module Main where + +import Data.Int +import Data.List +import GHC.Prim +import GHC.Exts + +main :: IO () +main = do + + -- + -- Check if passing Int16# on the stack works (16 parameter function will + -- need to use stack for some of the them) + -- + let input = + [ ( (a + 0), (a + 1), (a + 2), (a + 3), + (a + 4), (a + 5), (a + 6), (a + 7), + (a + 8), (a + 9), (a + 10), (a + 11), + (a + 12), (a + 13), (a + 14), (a + 15) ) + | a <- allInt16 + ] + expected = + [ toInt16 + (a + b + c + d + e + f + g + h + + i + j + k + l + m + n + o + p) + | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) <- input + ] + actual = + [ addMany a b c d e f g h i j k l m n o p + | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) <- input + ] + checkResults "passing Int16# on the stack" input expected actual + + -- + -- negateInt16# + -- + let input = allInt16 + expected = [ toInt16 (negate a) | a <- input ] + actual = [ apply1 negateInt16# a | a <- input ] + checkResults "negateInt16#" input expected actual + + -- + -- plusInt16# + -- + let input = [ (a, b) | a <- allInt16, b <- allInt16 ] + expected = [ toInt16 (a + b) | (a, b) <- input ] + actual = [ apply2 plusInt16# a b | (a, b) <- input ] + checkResults "plusInt16#" input expected actual + + -- -- + -- -- subInt16# + -- -- + let input = [ (a, b) | a <- allInt16, b <- allInt16 ] + expected = [ toInt16 (a - b) | (a, b) <- input ] + actual = [ apply2 subInt16# a b | (a, b) <- input ] + checkResults "subInt16#" input expected actual + + -- + -- timesInt16# + -- + let input = [ (a, b) | a <- allInt16, b <- allInt16 ] + expected = [ toInt16 (a * b) | (a, b) <- input ] + actual = [ apply2 timesInt16# a b | (a, b) <- input ] + checkResults "timesInt16#" input expected actual + + -- + -- remInt16# + -- + let input = + [ (a, b) | a <- allInt16, b <- allInt16 + -- Don't divide by 0 or cause overflow + , b /= 0, not (a == -32768 && b == -1) + ] + expected = [ toInt16 (a `rem` b) | (a, b) <- input ] + actual = [ apply2 remInt16# a b | (a, b) <- input ] + checkResults "remInt16#" input expected actual + + -- + -- quotInt16# + -- + let input = + [ (a, b) | a <- allInt16, b <- allInt16 + , b /= 0, not (a == -32768 && b == -1) + ] + expected = [ toInt16 (a `quot` b) | (a, b) <- input ] + actual = [ apply2 quotInt16# a b | (a, b) <- input ] + checkResults "quotInt16#" input expected actual + + -- + -- quotRemInt16# + -- + let input = + [ (a, b) | a <- allInt16, b <- allInt16 + , b /= 0, not (a == -32768 && b == -1) + ] + expected = + [ (toInt16 q, toInt16 r) | (a, b) <- input + , let (q, r) = a `quotRem` b + ] + actual = [ apply3 quotRemInt16# a b | (a, b) <- input ] + checkResults "quotRemInt16#" input expected actual + + +checkResults + :: (Eq a, Eq b, Show a, Show b) => String -> [a] -> [b] -> [b] -> IO () +checkResults test inputs expected actual = + case findIndex (\(e, a) -> e /= a) (zip expected actual) of + Nothing -> putStrLn $ "Pass: " ++ test + Just i -> error $ + "FAILED: " ++ test ++ " for input: " ++ show (inputs !! i) + ++ " expected: " ++ show (expected !! i) + ++ " but got: " ++ show (actual !! i) + +-- testing across the entire Int16 range blows the memory, +-- hence choosing a smaller range +allInt16 :: [Int] +allInt16 = [ -50 .. 50 ] + +toInt16 :: Int -> Int +toInt16 a = fromIntegral (fromIntegral a :: Int16) + +addMany# + :: Int16# -> Int16# -> Int16# -> Int16# + -> Int16# -> Int16# -> Int16# -> Int16# + -> Int16# -> Int16# -> Int16# -> Int16# + -> Int16# -> Int16# -> Int16# -> Int16# + -> Int16# +addMany# a b c d e f g h i j k l m n o p = + a `plusInt16#` b `plusInt16#` c `plusInt16#` d `plusInt16#` + e `plusInt16#` f `plusInt16#` g `plusInt16#` h `plusInt16#` + i `plusInt16#` j `plusInt16#` k `plusInt16#` l `plusInt16#` + m `plusInt16#` n `plusInt16#` o `plusInt16#` p +{-# NOINLINE addMany# #-} + +addMany + :: Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Int + -> Int +addMany (I# a) (I# b) (I# c) (I# d) + (I# e) (I# f) (I# g) (I# h) + (I# i) (I# j) (I# k) (I# l) + (I# m) (I# n) (I# o) (I# p) + = I# (extendInt16# int16) + where + !int16 = addMany# + (narrowInt16# a) (narrowInt16# b) (narrowInt16# c) (narrowInt16# d) + (narrowInt16# e) (narrowInt16# f) (narrowInt16# g) (narrowInt16# h) + (narrowInt16# i) (narrowInt16# j) (narrowInt16# k) (narrowInt16# l) + (narrowInt16# m) (narrowInt16# n) (narrowInt16# o) (narrowInt16# p) +{-# NOINLINE addMany #-} + +-- Convenient and also tests higher order functions on Int16# +apply1 :: (Int16# -> Int16#) -> Int -> Int +apply1 opToTest (I# a) = I# (extendInt16# (opToTest (narrowInt16# a))) +{-# NOINLINE apply1 #-} + +apply2 :: (Int16# -> Int16# -> Int16#) -> Int -> Int -> Int +apply2 opToTest (I# a) (I# b) = + let (# sa, sb #) = (# narrowInt16# a, narrowInt16# b #) + r = opToTest sa sb + in I# (extendInt16# r) +{-# NOINLINE apply2 #-} + +apply3 :: (Int16# -> Int16# -> (# Int16#, Int16# #)) -> Int -> Int -> (Int, Int) +apply3 opToTest (I# a) (I# b) = + let (# sa, sb #) = (# narrowInt16# a, narrowInt16# b #) + (# ra, rb #) = opToTest sa sb + in (I# (extendInt16# ra), I# (extendInt16# rb)) +{-# NOINLINE apply3 #-} + +instance + (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, + Eq i, Eq j, Eq k, Eq l, Eq m, Eq n, Eq o, Eq p) + => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where + (a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1) == + (a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2) = + a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && + e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && + i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 && + m1 == m2 && n1 == n2 && o1 == o2 && p1 == p2 + +instance + (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, + Show i, Show j, Show k, Show l, Show m, Show n, Show o, Show p) + => Show (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where + show (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) = + "(" ++ show a ++ "," ++ show b ++ "," ++ show c ++ "," ++ show d ++ + "," ++ show e ++ "," ++ show f ++ "," ++ show g ++ "," ++ show h ++ + "," ++ show i ++ "," ++ show j ++ "," ++ show k ++ "," ++ show l ++ + "," ++ show m ++ "," ++ show n ++ "," ++ show o ++ "," ++ show p ++ + ")" diff --git a/testsuite/tests/primops/should_run/ArithInt16.stdout b/testsuite/tests/primops/should_run/ArithInt16.stdout new file mode 100644 index 0000000000..3a8cc45976 --- /dev/null +++ b/testsuite/tests/primops/should_run/ArithInt16.stdout @@ -0,0 +1,8 @@ +Pass: passing Int16# on the stack +Pass: negateInt16# +Pass: plusInt16# +Pass: subInt16# +Pass: timesInt16# +Pass: remInt16# +Pass: quotInt16# +Pass: quotRemInt16# diff --git a/testsuite/tests/primops/should_run/ArithWord16.hs b/testsuite/tests/primops/should_run/ArithWord16.hs new file mode 100644 index 0000000000..ff86d95339 --- /dev/null +++ b/testsuite/tests/primops/should_run/ArithWord16.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module Main where + +import Data.Word +import Data.Bits +import Data.List +import GHC.Prim +import GHC.Exts + +main :: IO () +main = do + + -- + -- Check if passing Word16# on the stack works (16 parameter function will + -- need to use stack for some of the them) + -- + let input = + [ ( (a + 0), (a + 1), (a + 2), (a + 3), + (a + 4), (a + 5), (a + 6), (a + 7), + (a + 8), (a + 9), (a + 10), (a + 11), + (a + 12), (a + 13), (a + 14), (a + 15) ) + | a <- allWord16 + ] + expected = + [ toWord16 + (a + b + c + d + e + f + g + h + + i + j + k + l + m + n + o + p) + | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) <- input + ] + actual = + [ addMany a b c d e f g h i j k l m n o p + | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) <- input + ] + checkResults "passing Word16# on the stack" input expected actual + + -- + -- notWord16# + -- + let input = allWord16 + expected = [ toWord16 (complement a) | a <- input ] + actual = [ apply1 notWord16# a | a <- input ] + checkResults "notWord16#" input expected actual + + -- + -- plusWord16# + -- + let input = [ (a, b) | a <- allWord16, b <- allWord16 ] + expected = [ toWord16 (a + b) | (a, b) <- input ] + actual = [ apply2 plusWord16# a b | (a, b) <- input ] + checkResults "plusWord16#" input expected actual + + -- + -- subWord16# + -- + let input = [ (a, b) | a <- allWord16, b <- allWord16 ] + expected = [ toWord16 (a - b) | (a, b) <- input ] + actual = [ apply2 subWord16# a b | (a, b) <- input ] + checkResults "subWord16#" input expected actual + + -- + -- timesWord16# + -- + let input = [ (a, b) | a <- allWord16, b <- allWord16 ] + expected = [ toWord16 (a * b) | (a, b) <- input ] + actual = [ apply2 timesWord16# a b | (a, b) <- input ] + checkResults "timesWord16#" input expected actual + + -- + -- remWord16# + -- + let input = + -- Don't divide by 0. + [ (a, b) | a <- allWord16, b <- allWord16 , b /= 0 ] + expected = [ toWord16 (a `rem` b) | (a, b) <- input ] + actual = [ apply2 remWord16# a b | (a, b) <- input ] + checkResults "remWord16#" input expected actual + + -- + -- quotWord16# + -- + let input = + [ (a, b) | a <- allWord16, b <- allWord16, b /= 0 ] + expected = [ toWord16 (a `quot` b) | (a, b) <- input ] + actual = [ apply2 quotWord16# a b | (a, b) <- input ] + checkResults "quotWord16#" input expected actual + + -- + -- quotRemWord16# + -- + let input = + [ (a, b) | a <- allWord16, b <- allWord16, b /= 0 ] + expected = + [ (toWord16 q, toWord16 r) | (a, b) <- input + , let (q, r) = a `quotRem` b + ] + actual = [ apply3 quotRemWord16# a b | (a, b) <- input ] + checkResults "quotRemWord16#" input expected actual + + +checkResults + :: (Eq a, Eq b, Show a, Show b) => String -> [a] -> [b] -> [b] -> IO () +checkResults test inputs expected actual = + case findIndex (\(e, a) -> e /= a) (zip expected actual) of + Nothing -> putStrLn $ "Pass: " ++ test + Just i -> error $ + "FAILED: " ++ test ++ " for input: " ++ show (inputs !! i) + ++ " expected: " ++ show (expected !! i) + ++ " but got: " ++ show (actual !! i) + +-- testing across the entire Word16 range blows the memory, +-- hence choosing a smaller range +allWord16 :: [Word] +allWord16 = [ 0 .. 100 ] + +toWord16 :: Word -> Word +toWord16 a = fromIntegral (fromIntegral a :: Word16) + +addMany# + :: Word16# -> Word16# -> Word16# -> Word16# + -> Word16# -> Word16# -> Word16# -> Word16# + -> Word16# -> Word16# -> Word16# -> Word16# + -> Word16# -> Word16# -> Word16# -> Word16# + -> Word16# +addMany# a b c d e f g h i j k l m n o p = + a `plusWord16#` b `plusWord16#` c `plusWord16#` d `plusWord16#` + e `plusWord16#` f `plusWord16#` g `plusWord16#` h `plusWord16#` + i `plusWord16#` j `plusWord16#` k `plusWord16#` l `plusWord16#` + m `plusWord16#` n `plusWord16#` o `plusWord16#` p +{-# NOINLINE addMany# #-} + +addMany + :: Word -> Word -> Word -> Word + -> Word -> Word -> Word -> Word + -> Word -> Word -> Word -> Word + -> Word -> Word -> Word -> Word + -> Word +addMany (W# a) (W# b) (W# c) (W# d) + (W# e) (W# f) (W# g) (W# h) + (W# i) (W# j) (W# k) (W# l) + (W# m) (W# n) (W# o) (W# p) + = W# (extendWord16# word16) + where + !word16 = + addMany# + (narrowWord16# a) (narrowWord16# b) (narrowWord16# c) (narrowWord16# d) + (narrowWord16# e) (narrowWord16# f) (narrowWord16# g) (narrowWord16# h) + (narrowWord16# i) (narrowWord16# j) (narrowWord16# k) (narrowWord16# l) + (narrowWord16# m) (narrowWord16# n) (narrowWord16# o) (narrowWord16# p) +{-# NOINLINE addMany #-} + +-- Convenient and also tests higher order functions on Word16# +apply1 :: (Word16# -> Word16#) -> Word -> Word +apply1 opToTest (W# a) = W# (extendWord16# (opToTest (narrowWord16# a))) +{-# NOINLINE apply1 #-} + +apply2 :: (Word16# -> Word16# -> Word16#) -> Word -> Word -> Word +apply2 opToTest (W# a) (W# b) = + let (# sa, sb #) = (# narrowWord16# a, narrowWord16# b #) + r = opToTest sa sb + in W# (extendWord16# r) +{-# NOINLINE apply2 #-} + +apply3 + :: (Word16# -> Word16# -> (# Word16#, Word16# #)) -> Word -> Word -> (Word, Word) +apply3 opToTest (W# a) (W# b) = + let (# sa, sb #) = (# narrowWord16# a, narrowWord16# b #) + (# ra, rb #) = opToTest sa sb + in (W# (extendWord16# ra), W# (extendWord16# rb)) +{-# NOINLINE apply3 #-} + +instance + (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, + Eq i, Eq j, Eq k, Eq l, Eq m, Eq n, Eq o, Eq p) + => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where + (a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1) == + (a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2) = + a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && + e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && + i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 && + m1 == m2 && n1 == n2 && o1 == o2 && p1 == p2 + +instance + (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, + Show i, Show j, Show k, Show l, Show m, Show n, Show o, Show p) + => Show (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where + show (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) = + "(" ++ show a ++ "," ++ show b ++ "," ++ show c ++ "," ++ show d ++ + "," ++ show e ++ "," ++ show f ++ "," ++ show g ++ "," ++ show h ++ + "," ++ show i ++ "," ++ show j ++ "," ++ show k ++ "," ++ show l ++ + "," ++ show m ++ "," ++ show n ++ "," ++ show o ++ "," ++ show p ++ + ")" diff --git a/testsuite/tests/primops/should_run/ArithWord16.stdout b/testsuite/tests/primops/should_run/ArithWord16.stdout new file mode 100644 index 0000000000..f8ba30ef4f --- /dev/null +++ b/testsuite/tests/primops/should_run/ArithWord16.stdout @@ -0,0 +1,8 @@ +Pass: passing Word16# on the stack +Pass: notWord16# +Pass: plusWord16# +Pass: subWord16# +Pass: timesWord16# +Pass: remWord16# +Pass: quotWord16# +Pass: quotRemWord16# diff --git a/testsuite/tests/primops/should_run/CmpInt16.hs b/testsuite/tests/primops/should_run/CmpInt16.hs new file mode 100644 index 0000000000..79588cb9b3 --- /dev/null +++ b/testsuite/tests/primops/should_run/CmpInt16.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} + +module Main where + +import Data.Int +import Data.List +import GHC.Prim +import GHC.Exts + + +-- Having a wrapper gives us two things: +-- * it's easier to test everything (no need for code using raw primops) +-- * we test the deriving mechanism for Int16# +data TestInt16 = T16 Int16# + deriving (Eq, Ord) + +mkT16 :: Int -> TestInt16 +mkT16 (I# a) = T16 (narrowInt16# a) + +main :: IO () +main = do + let input = [ (a, b) | a <- allInt16, b <- allInt16 ] + + -- + -- (==) + -- + let expected = [ a == b | (a, b) <- input ] + actual = [ mkT16 a == mkT16 b | (a, b) <- input ] + checkResults "(==)" input expected actual + + -- + -- (/=) + -- + let expected = [ a /= b | (a, b) <- input ] + actual = [ mkT16 a /= mkT16 b | (a, b) <- input ] + checkResults "(/=)" input expected actual + + -- + -- (<) + -- + let expected = [ a < b | (a, b) <- input ] + actual = [ mkT16 a < mkT16 b | (a, b) <- input ] + checkResults "(<)" input expected actual + + -- + -- (>) + -- + let expected = [ a > b | (a, b) <- input ] + actual = [ mkT16 a > mkT16 b | (a, b) <- input ] + checkResults "(>)" input expected actual + + -- + -- (<=) + -- + let expected = [ a <= b | (a, b) <- input ] + actual = [ mkT16 a <= mkT16 b | (a, b) <- input ] + checkResults "(<=)" input expected actual + + -- + -- (>=) + -- + let expected = [ a >= b | (a, b) <- input ] + actual = [ mkT16 a >= mkT16 b | (a, b) <- input ] + checkResults "(>=)" input expected actual + +checkResults + :: (Eq a, Eq b, Show a, Show b) => String -> [a] -> [b] -> [b] -> IO () +checkResults test inputs expected actual = + case findIndex (\(e, a) -> e /= a) (zip expected actual) of + Nothing -> putStrLn $ "Pass: " ++ test + Just i -> error $ + "FAILED: " ++ test ++ " for input: " ++ show (inputs !! i) + ++ " expected: " ++ show (expected !! i) + ++ " but got: " ++ show (actual !! i) + +-- testing across the entire Int16 range blows the memory, +-- hence choosing a smaller range +allInt16 :: [Int] +allInt16 = [ -50 .. 50 ] diff --git a/testsuite/tests/primops/should_run/CmpInt16.stdout b/testsuite/tests/primops/should_run/CmpInt16.stdout new file mode 100644 index 0000000000..191d2b4b26 --- /dev/null +++ b/testsuite/tests/primops/should_run/CmpInt16.stdout @@ -0,0 +1,6 @@ +Pass: (==) +Pass: (/=) +Pass: (<) +Pass: (>) +Pass: (<=) +Pass: (>=) diff --git a/testsuite/tests/primops/should_run/CmpWord16.hs b/testsuite/tests/primops/should_run/CmpWord16.hs new file mode 100644 index 0000000000..7adc270afc --- /dev/null +++ b/testsuite/tests/primops/should_run/CmpWord16.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} + +module Main where + +import Data.Word +import Data.List +import GHC.Prim +import GHC.Exts + + +-- Having a wrapper gives us two things: +-- * it's easier to test everything (no need for code using raw primops) +-- * we test the deriving mechanism for Word16# +data TestWord16 = T16 Word16# + deriving (Eq, Ord) + +mkT16 :: Word -> TestWord16 +mkT16 (W# a) = T16 (narrowWord16# a) + +main :: IO () +main = do + let input = [ (a, b) | a <- allWord16, b <- allWord16 ] + + -- + -- (==) + -- + let expected = [ a == b | (a, b) <- input ] + actual = [ mkT16 a == mkT16 b | (a, b) <- input ] + checkResults "(==)" input expected actual + + -- + -- (/=) + -- + let expected = [ a /= b | (a, b) <- input ] + actual = [ mkT16 a /= mkT16 b | (a, b) <- input ] + checkResults "(/=)" input expected actual + + -- + -- (<) + -- + let expected = [ a < b | (a, b) <- input ] + actual = [ mkT16 a < mkT16 b | (a, b) <- input ] + checkResults "(<)" input expected actual + + -- + -- (>) + -- + let expected = [ a > b | (a, b) <- input ] + actual = [ mkT16 a > mkT16 b | (a, b) <- input ] + checkResults "(>)" input expected actual + + -- + -- (<=) + -- + let expected = [ a <= b | (a, b) <- input ] + actual = [ mkT16 a <= mkT16 b | (a, b) <- input ] + checkResults "(<=)" input expected actual + + -- + -- (>=) + -- + let expected = [ a >= b | (a, b) <- input ] + actual = [ mkT16 a >= mkT16 b | (a, b) <- input ] + checkResults "(>=)" input expected actual + +checkResults + :: (Eq a, Eq b, Show a, Show b) => String -> [a] -> [b] -> [b] -> IO () +checkResults test inputs expected actual = + case findIndex (\(e, a) -> e /= a) (zip expected actual) of + Nothing -> putStrLn $ "Pass: " ++ test + Just i -> error $ + "FAILED: " ++ test ++ " for input: " ++ show (inputs !! i) + ++ " expected: " ++ show (expected !! i) + ++ " but got: " ++ show (actual !! i) + +-- testing across the entire Word16 range blows the memory, +-- hence choosing a smaller range +allWord16 :: [Word] +allWord16 = [ 0 .. 100 ] diff --git a/testsuite/tests/primops/should_run/CmpWord16.stdout b/testsuite/tests/primops/should_run/CmpWord16.stdout new file mode 100644 index 0000000000..191d2b4b26 --- /dev/null +++ b/testsuite/tests/primops/should_run/CmpWord16.stdout @@ -0,0 +1,6 @@ +Pass: (==) +Pass: (/=) +Pass: (<) +Pass: (>) +Pass: (<=) +Pass: (>=) diff --git a/testsuite/tests/primops/should_run/ShowPrim.hs b/testsuite/tests/primops/should_run/ShowPrim.hs index 5670032f4a..e11a4934e6 100644 --- a/testsuite/tests/primops/should_run/ShowPrim.hs +++ b/testsuite/tests/primops/should_run/ShowPrim.hs @@ -4,11 +4,19 @@ module Main where import GHC.Exts -data Test = Test Int8# Word8# +data Test1 = Test1 Int8# Word8# deriving (Show) -test1 :: Test -test1 = Test (narrowInt8# 1#) (narrowWord8# 2##) +data Test2 = Test2 Int16# Word16# + deriving (Show) + +test1 :: Test1 +test1 = Test1 (narrowInt8# 1#) (narrowWord8# 2##) + +test2 :: Test2 +test2 = Test2 (narrowInt16# 1#) (narrowWord16# 2##) main :: IO () -main = print test1 +main = do + print test1 + print test2 diff --git a/testsuite/tests/primops/should_run/ShowPrim.stdout b/testsuite/tests/primops/should_run/ShowPrim.stdout index 5720effb8b..e2801b44fb 100644 --- a/testsuite/tests/primops/should_run/ShowPrim.stdout +++ b/testsuite/tests/primops/should_run/ShowPrim.stdout @@ -1 +1,2 @@ -Test (narrowInt8# 1#) (narrowWord8# 2##) +Test1 (narrowInt8# 1#) (narrowWord8# 2##) +Test2 (narrowInt16# 1#) (narrowWord16# 2##) diff --git a/testsuite/tests/primops/should_run/all.T b/testsuite/tests/primops/should_run/all.T index c7cdd348bf..46954e3c58 100644 --- a/testsuite/tests/primops/should_run/all.T +++ b/testsuite/tests/primops/should_run/all.T @@ -18,3 +18,8 @@ test('ArithWord8', omit_ways(['ghci']), compile_and_run, ['']) test('CmpInt8', normal, compile_and_run, ['']) test('CmpWord8', normal, compile_and_run, ['']) test('ShowPrim', normal, compile_and_run, ['']) + +test('ArithInt16', normal, compile_and_run, ['']) +test('ArithWord16', normal, compile_and_run, ['']) +test('CmpInt16', normal, compile_and_run, ['']) +test('CmpWord16', normal, compile_and_run, [''])
\ No newline at end of file diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index e422c1fa58..863a7d239c 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -835,11 +835,13 @@ ppType (TyApp (TyCon "Bool") []) = "boolTy" ppType (TyApp (TyCon "Int#") []) = "intPrimTy" ppType (TyApp (TyCon "Int8#") []) = "int8PrimTy" -ppType (TyApp (TyCon "Word8#") []) = "word8PrimTy" +ppType (TyApp (TyCon "Int16#") []) = "int16PrimTy" ppType (TyApp (TyCon "Int32#") []) = "int32PrimTy" ppType (TyApp (TyCon "Int64#") []) = "int64PrimTy" ppType (TyApp (TyCon "Char#") []) = "charPrimTy" ppType (TyApp (TyCon "Word#") []) = "wordPrimTy" +ppType (TyApp (TyCon "Word8#") []) = "word8PrimTy" +ppType (TyApp (TyCon "Word16#") []) = "word16PrimTy" ppType (TyApp (TyCon "Word32#") []) = "word32PrimTy" ppType (TyApp (TyCon "Word64#") []) = "word64PrimTy" ppType (TyApp (TyCon "Addr#") []) = "addrPrimTy" |