[commit: ghc] wip/T9281: [WIP] fixup wired-in BigNat (13cb42b)
git at git.haskell.org
git at git.haskell.org
Sun Aug 17 13:04:45 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/T9281
Link : http://ghc.haskell.org/trac/ghc/changeset/13cb42bc8b6b26d3893d4ddcc22eeab36d39a0c7/ghc
>---------------------------------------------------------------
commit 13cb42bc8b6b26d3893d4ddcc22eeab36d39a0c7
Author: Herbert Valerio Riedel <hvr at gnu.org>
Date: Sat Aug 16 23:18:17 2014 +0200
[WIP] fixup wired-in BigNat
Note, this still results in a core lint-error due to unpacking:
HC [stage 1] libraries/integer-gmp2/dist-install/build/GHC/Integer/Logarithms.o
ghc-stage1: panic! (the 'impossible' happened)
(GHC version 7.9.20140817 for x86_64-unknown-linux):
Iface Lint failure
In interface for GHC.Integer.Type
Unfolding of sqrInteger
<no location info>: Warning:
In the expression: $wsqrBigNat dt
Argument value doesn't match argument type:
Fun type: ByteArray# -> BigNat
Arg type: BigNat
Arg: dt
sqrInteger = \ (ds :: Integer) ->
case ds of wild {
SI# ds1 ->
case ds1 of ds2 {
__DEFAULT ->
let {
nsign :: Int#
[LclId, Str=DmdType]
nsign = uncheckedIShiftRA# ds2 63 } in
case tagToEnum#
@ Bool (<=# (-# (xorI# ds2 nsign) nsign) 3037000499)
of wild1 {
False -> timesInt2Integer ds2 ds2;
True -> SI# (*# ds2 ds2)
};
(-9223372036854775808) -> sqrInteger1
};
Jp# dt -> case $wsqrBigNat dt of dt1 { BN# dt2 -> Jp# dt2 };
Jn# dt -> case $wsqrBigNat dt of dt1 { BN# dt2 -> Jp# dt2 }
}
Iface expr = \ ds :: Integer ->
case ds of wild {
SI# ds1
-> case ds1 of ds2 {
DEFAULT
-> let {
nsign :: Int# = uncheckedIShiftRA# ds2 63
} in
case tagToEnum#
@ Bool
(<=# (-# (xorI# ds2 nsign) nsign) 3037000499) of wild1 {
False -> timesInt2Integer ds2 ds2 True -> SI# (*# ds2 ds2) }
(-9223372036854775808) -> sqrInteger1 }
Jp# dt -> case $wsqrBigNat dt of dt1 { BN# dt2 -> Jp# dt2 }
Jn# dt -> case $wsqrBigNat dt of dt1 { BN# dt2 -> Jp# dt2 } }
Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug
>---------------------------------------------------------------
13cb42bc8b6b26d3893d4ddcc22eeab36d39a0c7
compiler/prelude/PrelNames.lhs | 9 +++++----
compiler/prelude/TysWiredIn.lhs | 45 +++++++++++++++++++++++++++++++----------
2 files changed, 39 insertions(+), 15 deletions(-)
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 6a30a3f..ddf1c39 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -1328,7 +1328,7 @@ addrPrimTyConKey, arrayPrimTyConKey, arrayArrayPrimTyConKey, boolTyConKey, byteA
floatPrimTyConKey, floatTyConKey, funTyConKey, intPrimTyConKey,
intTyConKey, int8TyConKey, int16TyConKey, int32PrimTyConKey,
int32TyConKey, int64PrimTyConKey, int64TyConKey,
- integerTyConKey,
+ integerTyConKey, bigNatTyConKey,
listTyConKey, foreignObjPrimTyConKey, weakPrimTyConKey,
mutableArrayPrimTyConKey, mutableArrayArrayPrimTyConKey, mutableByteArrayPrimTyConKey,
orderingTyConKey, mVarPrimTyConKey, ratioTyConKey, rationalTyConKey,
@@ -1355,7 +1355,7 @@ int32TyConKey = mkPreludeTyConUnique 19
int64PrimTyConKey = mkPreludeTyConUnique 20
int64TyConKey = mkPreludeTyConUnique 21
integerTyConKey = mkPreludeTyConUnique 22
-
+bigNatTyConKey = mkPreludeTyConUnique 23
listTyConKey = mkPreludeTyConUnique 24
foreignObjPrimTyConKey = mkPreludeTyConUnique 25
weakPrimTyConKey = mkPreludeTyConUnique 27
@@ -1594,12 +1594,13 @@ integerGmpJDataConKey = mkPreludeDataConUnique 31
-- For integer-gmp2 only
integerGmp2SIDataConKey, integerGmp2JpDataConKey,
- integerGmp2JnDataConKey :: Unique
+ integerGmp2JnDataConKey, bigNatDataConKey :: Unique
integerGmp2SIDataConKey = mkPreludeDataConUnique 32
integerGmp2JpDataConKey = mkPreludeDataConUnique 33
integerGmp2JnDataConKey = mkPreludeDataConUnique 34
+bigNatDataConKey = mkPreludeDataConUnique 35
-coercibleDataConKey = mkPreludeDataConUnique 35
+coercibleDataConKey = mkPreludeDataConUnique 36
\end{code}
%************************************************************************
diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
index d09c9dc..9393b46 100644
--- a/compiler/prelude/TysWiredIn.lhs
+++ b/compiler/prelude/TysWiredIn.lhs
@@ -165,7 +165,7 @@ wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because
]
++ (case cIntegerLibraryType of
IntegerGMP -> [integerTyCon]
- IntegerGMP2 -> [integerTyCon]
+ IntegerGMP2 -> [integerTyCon, bigNatTyCon]
_ -> [])
\end{code}
@@ -237,6 +237,11 @@ integerGmp2SIDataConName = mkWiredInDataConName UserSyntax gHC_INTEGER_TYPE (fsL
integerGmp2JpDataConName = mkWiredInDataConName UserSyntax gHC_INTEGER_TYPE (fsLit "Jp#") integerGmp2JpDataConKey integerGmp2JpDataCon
integerGmp2JnDataConName = mkWiredInDataConName UserSyntax gHC_INTEGER_TYPE (fsLit "Jn#") integerGmp2JnDataConKey integerGmp2JnDataCon
+-- GHC.Integer.Type.BigNat
+bigNatTyConName, bigNatDataConName :: Name
+bigNatTyConName = mkWiredInTyConName UserSyntax gHC_INTEGER_TYPE (fsLit "BigNat") bigNatTyConKey bigNatTyCon
+bigNatDataConName = mkWiredInDataConName UserSyntax gHC_INTEGER_TYPE (fsLit "BN#") bigNatDataConKey bigNatDataCon
+
parrTyConName, parrDataConName :: Name
parrTyConName = mkWiredInTyConName BuiltInSyntax
gHC_PARR' (fsLit "[::]") parrTyConKey parrTyCon
@@ -288,8 +293,11 @@ pcTyCon is_enum is_rec is_prom name cType tyvars cons
pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon
pcDataCon = pcDataConWithFixity False
+pcDataConWithBangs :: [HsBang] -> Name -> [TyVar] -> [Type] -> TyCon -> DataCon
+pcDataConWithBangs bangs n = pcDataConWithFixity' False n (incrUnique (nameUnique n)) bangs
+
pcDataConWithFixity :: Bool -> Name -> [TyVar] -> [Type] -> TyCon -> DataCon
-pcDataConWithFixity infx n = pcDataConWithFixity' infx n (incrUnique (nameUnique n))
+pcDataConWithFixity infx n = pcDataConWithFixity' infx n (incrUnique (nameUnique n)) []
-- The Name's unique is the first of two free uniques;
-- the first is used for the datacon itself,
-- the second is used for the "worker name"
@@ -297,15 +305,15 @@ pcDataConWithFixity infx n = pcDataConWithFixity' infx n (incrUnique (nameUnique
-- To support this the mkPreludeDataConUnique function "allocates"
-- one DataCon unique per pair of Ints.
-pcDataConWithFixity' :: Bool -> Name -> Unique -> [TyVar] -> [Type] -> TyCon -> DataCon
+pcDataConWithFixity' :: Bool -> Name -> Unique -> [HsBang] -> [TyVar] -> [Type] -> TyCon -> DataCon
-- The Name should be in the DataName name space; it's the name
-- of the DataCon itself.
-pcDataConWithFixity' declared_infix dc_name wrk_key tyvars arg_tys tycon
+pcDataConWithFixity' declared_infix dc_name wrk_key arg_bangs tyvars arg_tys tycon
= data_con
where
data_con = mkDataCon dc_name declared_infix
- (map (const HsNoBang) arg_tys)
+ bangs
[] -- No labelled fields
tyvars
[] -- No existential type variables
@@ -322,6 +330,8 @@ pcDataConWithFixity' declared_infix dc_name wrk_key tyvars arg_tys tycon
wrk_occ = mkDataConWorkerOcc (nameOccName dc_name)
wrk_name = mkWiredInName modu wrk_occ wrk_key
(AnId (dataConWorkId data_con)) UserSyntax
+ bangs | null arg_bangs = map (const HsNoBang) arg_tys
+ | otherwise = arg_bangs
\end{code}
@@ -613,14 +623,27 @@ integerGmpJDataCon = pcDataCon integerGmpJDataConName []
integerTyCon
integerGmp2JpDataCon :: DataCon
-integerGmp2JpDataCon = pcDataCon integerGmp2JpDataConName []
- [byteArrayPrimTy]
- integerTyCon
+integerGmp2JpDataCon = pcDataConWithBangs
+ [HsUserBang (Just True) True]
+ integerGmp2JpDataConName []
+ [bigNatTy]
+ integerTyCon
integerGmp2JnDataCon :: DataCon
-integerGmp2JnDataCon = pcDataCon integerGmp2JnDataConName []
- [byteArrayPrimTy]
- integerTyCon
+integerGmp2JnDataCon = pcDataConWithBangs
+ [HsUserBang (Just True) True]
+ integerGmp2JnDataConName []
+ [bigNatTy]
+ integerTyCon
+
+bigNatTy :: Type
+bigNatTy = mkTyConTy bigNatTyCon
+
+bigNatTyCon :: TyCon
+bigNatTyCon = pcNonRecDataTyCon bigNatTyConName Nothing [] [bigNatDataCon]
+
+bigNatDataCon :: DataCon
+bigNatDataCon = pcDataCon bigNatDataConName [] [byteArrayPrimTy] bigNatTyCon
\end{code}
More information about the ghc-commits
mailing list