[Git][ghc/ghc][wip/ttg/lits] 3 commits: ci: RISCV64 cross-compile testing
Hassan Al-Awwadi (@hassan.awwadi)
gitlab at gitlab.haskell.org
Wed Oct 9 10:20:03 UTC 2024
Hassan Al-Awwadi pushed to branch wip/ttg/lits at Glasgow Haskell Compiler / GHC
Commits:
a1ecc826 by Sven Tennie at 2024-10-08T13:36:03-04:00
ci: RISCV64 cross-compile testing
This adds a validation job which tests that we can build a riscv64 cross
compiler and build a simple program using it. We do not currently run
the whole testsuite.
Towards #25254
Co-authored-by: Matthew Pickering <matthewtpickering at gmail.com>
- - - - -
d5c2577f by Arnaud Spiwack at 2024-10-08T13:36:44-04:00
Remove unused accumulators in partition_errors
- - - - -
a12ea597 by Hassan Al-Awwadi at 2024-10-09T10:19:28+00:00
Move HsInteger and HsRat to an extension constructor
- - - - -
21 changed files:
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Lit.hs
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match/Literal.hs
- compiler/GHC/HsToCore/Pmc/Desugar.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/Language/Haskell/Syntax/Lit.hs
- testsuite/tests/ghc-api/annotations-literals/parsed.hs
- utils/check-exact/ExactPrint.hs
Changes:
=====================================
.gitlab/generate-ci/gen_ci.hs
=====================================
@@ -106,6 +106,7 @@ data Opsys
data LinuxDistro
= Debian12
+ | Debian12Riscv
| Debian11
| Debian11Js
| Debian10
@@ -303,6 +304,7 @@ distroName :: LinuxDistro -> String
distroName Debian12 = "deb12"
distroName Debian11 = "deb11"
distroName Debian11Js = "deb11-emsdk-closure"
+distroName Debian12Riscv = "deb12-riscv"
distroName Debian10 = "deb10"
distroName Debian9 = "deb9"
distroName Fedora33 = "fedora33"
@@ -626,6 +628,7 @@ data ValidateRule =
FullCI -- ^ Run this job when the "full-ci" label is present.
| LLVMBackend -- ^ Run this job when the "LLVM backend" label is present
| JSBackend -- ^ Run this job when the "javascript" label is present
+ | RiscV -- ^ Run this job when the "RISC-V" label is present
| WasmBackend -- ^ Run this job when the "wasm" label is present
| FreeBSDLabel -- ^ Run this job when the "FreeBSD" label is set.
| NonmovingGc -- ^ Run this job when the "non-moving GC" label is set.
@@ -674,6 +677,7 @@ validateRuleString FullCI = or_all ([ labelString "full-ci"
validateRuleString LLVMBackend = labelString "LLVM backend"
validateRuleString JSBackend = labelString "javascript"
+validateRuleString RiscV = labelString "RISC-V"
validateRuleString WasmBackend = labelString "wasm"
validateRuleString FreeBSDLabel = labelString "FreeBSD"
validateRuleString NonmovingGc = labelString "non-moving GC"
@@ -1125,6 +1129,9 @@ cross_jobs = [
-- x86 -> aarch64
validateBuilds Amd64 (Linux Debian11) (crossConfig "aarch64-linux-gnu" (Emulator "qemu-aarch64 -L /usr/aarch64-linux-gnu") Nothing)
+ -- x86_64 -> riscv
+ , addValidateRule RiscV (validateBuilds Amd64 (Linux Debian12Riscv) (crossConfig "riscv64-linux-gnu" (Emulator "qemu-riscv64 -L /usr/riscv64-linux-gnu") Nothing))
+
-- Javascript
, addValidateRule JSBackend (validateBuilds Amd64 (Linux Debian11Js) javascriptConfig)
=====================================
.gitlab/jobs.yaml
=====================================
@@ -1854,6 +1854,71 @@
"XZ_OPT": "-9"
}
},
+ "nightly-x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-validate": {
+ "after_script": [
+ ".gitlab/ci.sh save_cache",
+ ".gitlab/ci.sh save_test_output",
+ ".gitlab/ci.sh clean",
+ "cat ci_timings"
+ ],
+ "allow_failure": false,
+ "artifacts": {
+ "expire_in": "8 weeks",
+ "paths": [
+ "ghc-x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-validate.tar.xz",
+ "junit.xml",
+ "unexpected-test-output.tar.gz"
+ ],
+ "reports": {
+ "junit": "junit.xml"
+ },
+ "when": "always"
+ },
+ "cache": {
+ "key": "x86_64-linux-deb12-riscv-$CACHE_REV",
+ "paths": [
+ "cabal-cache",
+ "toolchain"
+ ]
+ },
+ "dependencies": [],
+ "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb12-riscv:$DOCKER_REV",
+ "needs": [
+ {
+ "artifacts": false,
+ "job": "hadrian-ghc-in-ghci"
+ }
+ ],
+ "rules": [
+ {
+ "if": "(\"true\" == \"true\") && ($RELEASE_JOB != \"yes\") && ($NIGHTLY)",
+ "when": "on_success"
+ }
+ ],
+ "script": [
+ "sudo chown ghc:ghc -R .",
+ ".gitlab/ci.sh setup",
+ ".gitlab/ci.sh configure",
+ ".gitlab/ci.sh build_hadrian",
+ ".gitlab/ci.sh test_hadrian"
+ ],
+ "stage": "full-build",
+ "tags": [
+ "x86_64-linux"
+ ],
+ "variables": {
+ "BIGNUM_BACKEND": "gmp",
+ "BIN_DIST_NAME": "ghc-x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-validate",
+ "BUILD_FLAVOUR": "validate",
+ "CONFIGURE_ARGS": "--with-intree-gmp --enable-strict-ghc-toolchain-check",
+ "CROSS_EMULATOR": "qemu-riscv64 -L /usr/riscv64-linux-gnu",
+ "CROSS_TARGET": "riscv64-linux-gnu",
+ "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
+ "RUNTEST_ARGS": "",
+ "TEST_ENV": "x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-validate",
+ "XZ_OPT": "-9"
+ }
+ },
"nightly-x86_64-linux-deb12-unreg-validate": {
"after_script": [
".gitlab/ci.sh save_cache",
@@ -5348,6 +5413,70 @@
"TEST_ENV": "x86_64-linux-deb12-numa-slow-validate"
}
},
+ "x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-validate": {
+ "after_script": [
+ ".gitlab/ci.sh save_cache",
+ ".gitlab/ci.sh save_test_output",
+ ".gitlab/ci.sh clean",
+ "cat ci_timings"
+ ],
+ "allow_failure": false,
+ "artifacts": {
+ "expire_in": "2 weeks",
+ "paths": [
+ "ghc-x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-validate.tar.xz",
+ "junit.xml",
+ "unexpected-test-output.tar.gz"
+ ],
+ "reports": {
+ "junit": "junit.xml"
+ },
+ "when": "always"
+ },
+ "cache": {
+ "key": "x86_64-linux-deb12-riscv-$CACHE_REV",
+ "paths": [
+ "cabal-cache",
+ "toolchain"
+ ]
+ },
+ "dependencies": [],
+ "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb12-riscv:$DOCKER_REV",
+ "needs": [
+ {
+ "artifacts": false,
+ "job": "hadrian-ghc-in-ghci"
+ }
+ ],
+ "rules": [
+ {
+ "if": "((($CI_MERGE_REQUEST_LABELS =~ /.*full-ci.*/) || ($CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/) || ($CI_COMMIT_BRANCH == \"master\") || ($CI_COMMIT_BRANCH =~ /ghc-[0-9]+\\.[0-9]+/)) || ($CI_MERGE_REQUEST_LABELS =~ /.*RISC-V.*/)) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)",
+ "when": "on_success"
+ }
+ ],
+ "script": [
+ "sudo chown ghc:ghc -R .",
+ ".gitlab/ci.sh setup",
+ ".gitlab/ci.sh configure",
+ ".gitlab/ci.sh build_hadrian",
+ ".gitlab/ci.sh test_hadrian"
+ ],
+ "stage": "full-build",
+ "tags": [
+ "x86_64-linux"
+ ],
+ "variables": {
+ "BIGNUM_BACKEND": "gmp",
+ "BIN_DIST_NAME": "ghc-x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-validate",
+ "BUILD_FLAVOUR": "validate",
+ "CONFIGURE_ARGS": "--with-intree-gmp --enable-strict-ghc-toolchain-check",
+ "CROSS_EMULATOR": "qemu-riscv64 -L /usr/riscv64-linux-gnu",
+ "CROSS_TARGET": "riscv64-linux-gnu",
+ "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
+ "RUNTEST_ARGS": "",
+ "TEST_ENV": "x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-validate"
+ }
+ },
"x86_64-linux-deb12-unreg-validate": {
"after_script": [
".gitlab/ci.sh save_cache",
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -432,6 +432,8 @@ deriving instance Data XBindStmtTc
-- deriving instance (DataId p) => Data (HsLit p)
deriving instance Data (HsLit GhcPs)
deriving instance Data (HsLit GhcRn)
+
+deriving instance Data HsLitTc
deriving instance Data (HsLit GhcTc)
-- deriving instance (DataIdLR p p) => Data (HsOverLit p)
=====================================
compiler/GHC/Hs/Lit.hs
=====================================
@@ -62,11 +62,26 @@ type instance XHsWord8Prim (GhcPass _) = SourceText
type instance XHsWord16Prim (GhcPass _) = SourceText
type instance XHsWord32Prim (GhcPass _) = SourceText
type instance XHsWord64Prim (GhcPass _) = SourceText
-type instance XHsInteger (GhcPass _) = SourceText
-type instance XHsRat (GhcPass _) = NoExtField
type instance XHsFloatPrim (GhcPass _) = NoExtField
type instance XHsDoublePrim (GhcPass _) = NoExtField
-type instance XXLit (GhcPass _) = DataConCantHappen
+
+type instance XXLit GhcPs = DataConCantHappen
+type instance XXLit GhcRn = DataConCantHappen
+type instance XXLit GhcTc = HsLitTc
+
+data HsLitTc
+ = HsInteger SourceText Integer Type
+ -- ^ Genuinely an integer; arises only
+ -- from TRANSLATION (overloaded
+ -- literals are done with HsOverLit)
+ | HsRat FractionalLit Type
+ -- ^ Genuinely a rational; arises only from
+ -- TRANSLATION (overloaded literals are
+ -- done with HsOverLit)
+instance Eq HsLitTc where
+ (HsInteger _ x _) == (HsInteger _ y _) = x==y
+ (HsRat x _) == (HsRat y _) = x==y
+ _ == _ = False
data OverLitRn
= OverLitRn {
@@ -130,7 +145,7 @@ hsOverLitNeedsParens _ (XOverLit { }) = False
--
-- See Note [Printing of literals in Core] in GHC.Types.Literal
-- for the reasoning.
-hsLitNeedsParens :: PprPrec -> HsLit x -> Bool
+hsLitNeedsParens :: forall x. IsPass x => PprPrec -> HsLit (GhcPass x) -> Bool
hsLitNeedsParens p = go
where
go (HsChar {}) = False
@@ -139,8 +154,6 @@ hsLitNeedsParens p = go
go (HsMultilineString {}) = False
go (HsStringPrim {}) = False
go (HsInt _ x) = p > topPrec && il_neg x
- go (HsInteger _ x _) = p > topPrec && x < 0
- go (HsRat _ x _) = p > topPrec && fl_neg x
go (HsFloatPrim {}) = False
go (HsDoublePrim {}) = False
go (HsIntPrim {}) = False
@@ -153,30 +166,72 @@ hsLitNeedsParens p = go
go (HsWord16Prim {}) = False
go (HsWord64Prim {}) = False
go (HsWord32Prim {}) = False
- go (XLit _) = False
+ go (XLit x) = case ghcPass @x of
+ GhcTc -> case x of
+ (HsInteger _ x _) -> p > topPrec && x < 0
+ (HsRat x _) -> p > topPrec && fl_neg x
+
-- | Convert a literal from one index type to another
-convertLit :: HsLit (GhcPass p1) -> HsLit (GhcPass p2)
-convertLit (HsChar a x) = HsChar a x
-convertLit (HsCharPrim a x) = HsCharPrim a x
-convertLit (HsString a x) = HsString a x
-convertLit (HsMultilineString a x) = HsMultilineString a x
-convertLit (HsStringPrim a x) = HsStringPrim a x
-convertLit (HsInt a x) = HsInt a x
-convertLit (HsIntPrim a x) = HsIntPrim a x
-convertLit (HsWordPrim a x) = HsWordPrim a x
-convertLit (HsInt8Prim a x) = HsInt8Prim a x
-convertLit (HsInt16Prim a x) = HsInt16Prim a x
-convertLit (HsInt32Prim a x) = HsInt32Prim a x
-convertLit (HsInt64Prim a x) = HsInt64Prim a x
-convertLit (HsWord8Prim a x) = HsWord8Prim a x
-convertLit (HsWord16Prim a x) = HsWord16Prim a x
-convertLit (HsWord32Prim a x) = HsWord32Prim a x
-convertLit (HsWord64Prim a x) = HsWord64Prim a x
-convertLit (HsInteger a x b) = HsInteger a x b
-convertLit (HsRat a x b) = HsRat a x b
-convertLit (HsFloatPrim a x) = HsFloatPrim a x
-convertLit (HsDoublePrim a x) = HsDoublePrim a x
+convertLitPsRn :: HsLit GhcPs -> HsLit GhcRn
+convertLitPsRn (HsChar a x) = HsChar a x
+convertLitPsRn (HsCharPrim a x) = HsCharPrim a x
+convertLitPsRn (HsString a x) = HsString a x
+convertLitPsRn (HsMultilineString a x) = HsMultilineString a x
+convertLitPsRn (HsStringPrim a x) = HsStringPrim a x
+convertLitPsRn (HsInt a x) = HsInt a x
+convertLitPsRn (HsIntPrim a x) = HsIntPrim a x
+convertLitPsRn (HsWordPrim a x) = HsWordPrim a x
+convertLitPsRn (HsInt8Prim a x) = HsInt8Prim a x
+convertLitPsRn (HsInt16Prim a x) = HsInt16Prim a x
+convertLitPsRn (HsInt32Prim a x) = HsInt32Prim a x
+convertLitPsRn (HsInt64Prim a x) = HsInt64Prim a x
+convertLitPsRn (HsWord8Prim a x) = HsWord8Prim a x
+convertLitPsRn (HsWord16Prim a x) = HsWord16Prim a x
+convertLitPsRn (HsWord32Prim a x) = HsWord32Prim a x
+convertLitPsRn (HsWord64Prim a x) = HsWord64Prim a x
+convertLitPsRn (HsFloatPrim a x) = HsFloatPrim a x
+convertLitPsRn (HsDoublePrim a x) = HsDoublePrim a x
+
+convertLitPsTc :: HsLit GhcPs -> HsLit GhcTc
+convertLitPsTc (HsChar a x) = HsChar a x
+convertLitPsTc (HsCharPrim a x) = HsCharPrim a x
+convertLitPsTc (HsString a x) = HsString a x
+convertLitPsTc (HsMultilineString a x) = HsMultilineString a x
+convertLitPsTc (HsStringPrim a x) = HsStringPrim a x
+convertLitPsTc (HsInt a x) = HsInt a x
+convertLitPsTc (HsIntPrim a x) = HsIntPrim a x
+convertLitPsTc (HsWordPrim a x) = HsWordPrim a x
+convertLitPsTc (HsInt8Prim a x) = HsInt8Prim a x
+convertLitPsTc (HsInt16Prim a x) = HsInt16Prim a x
+convertLitPsTc (HsInt32Prim a x) = HsInt32Prim a x
+convertLitPsTc (HsInt64Prim a x) = HsInt64Prim a x
+convertLitPsTc (HsWord8Prim a x) = HsWord8Prim a x
+convertLitPsTc (HsWord16Prim a x) = HsWord16Prim a x
+convertLitPsTc (HsWord32Prim a x) = HsWord32Prim a x
+convertLitPsTc (HsWord64Prim a x) = HsWord64Prim a x
+convertLitPsTc (HsFloatPrim a x) = HsFloatPrim a x
+convertLitPsTc (HsDoublePrim a x) = HsDoublePrim a x
+
+convertLitRnTc :: HsLit GhcRn -> HsLit GhcTc
+convertLitRnTc (HsChar a x) = HsChar a x
+convertLitRnTc (HsCharPrim a x) = HsCharPrim a x
+convertLitRnTc (HsString a x) = HsString a x
+convertLitRnTc (HsMultilineString a x) = HsMultilineString a x
+convertLitRnTc (HsStringPrim a x) = HsStringPrim a x
+convertLitRnTc (HsInt a x) = HsInt a x
+convertLitRnTc (HsIntPrim a x) = HsIntPrim a x
+convertLitRnTc (HsWordPrim a x) = HsWordPrim a x
+convertLitRnTc (HsInt8Prim a x) = HsInt8Prim a x
+convertLitRnTc (HsInt16Prim a x) = HsInt16Prim a x
+convertLitRnTc (HsInt32Prim a x) = HsInt32Prim a x
+convertLitRnTc (HsInt64Prim a x) = HsInt64Prim a x
+convertLitRnTc (HsWord8Prim a x) = HsWord8Prim a x
+convertLitRnTc (HsWord16Prim a x) = HsWord16Prim a x
+convertLitRnTc (HsWord32Prim a x) = HsWord32Prim a x
+convertLitRnTc (HsWord64Prim a x) = HsWord64Prim a x
+convertLitRnTc (HsFloatPrim a x) = HsFloatPrim a x
+convertLitRnTc (HsDoublePrim a x) = HsDoublePrim a x
{-
Note [ol_rebindable]
@@ -194,7 +249,7 @@ Equivalently it's True if
-}
-- Instance specific to GhcPs, need the SourceText
-instance Outputable (HsLit (GhcPass p)) where
+instance IsPass p => Outputable (HsLit (GhcPass p)) where
ppr (HsChar st c) = pprWithSourceText st (pprHsChar c)
ppr (HsCharPrim st c) = pprWithSourceText st (pprPrimChar c)
ppr (HsString st s) = pprWithSourceText st (pprHsString s)
@@ -205,8 +260,6 @@ instance Outputable (HsLit (GhcPass p)) where
ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s)
ppr (HsInt _ i)
= pprWithSourceText (il_text i) (integer (il_value i))
- ppr (HsInteger st i _) = pprWithSourceText st (integer i)
- ppr (HsRat _ f _) = ppr f
ppr (HsFloatPrim _ f) = ppr f <> primFloatSuffix
ppr (HsDoublePrim _ d) = ppr d <> primDoubleSuffix
ppr (HsIntPrim st i) = pprWithSourceText st (pprPrimInt i)
@@ -219,6 +272,10 @@ instance Outputable (HsLit (GhcPass p)) where
ppr (HsWord16Prim st w) = pprWithSourceText st (pprPrimWord16 w)
ppr (HsWord32Prim st w) = pprWithSourceText st (pprPrimWord32 w)
ppr (HsWord64Prim st w) = pprWithSourceText st (pprPrimWord64 w)
+ ppr (XLit x) = case ghcPass @p of
+ GhcTc -> case x of
+ (HsInteger st i _) -> pprWithSourceText st (integer i)
+ (HsRat f _) -> ppr f
-- in debug mode, print the expression that it's resolved to, too
instance OutputableBndrId p
@@ -237,7 +294,7 @@ instance Outputable OverLitVal where
-- mainly for too reasons:
-- * We do not want to expose their internal representation
-- * The warnings become too messy
-pmPprHsLit :: HsLit (GhcPass x) -> SDoc
+pmPprHsLit :: forall p. IsPass p => HsLit (GhcPass p) -> SDoc
pmPprHsLit (HsChar _ c) = pprHsChar c
pmPprHsLit (HsCharPrim _ c) = pprHsChar c
pmPprHsLit (HsString st s) = pprWithSourceText st (pprHsString s)
@@ -254,10 +311,12 @@ pmPprHsLit (HsWord8Prim _ w) = integer w
pmPprHsLit (HsWord16Prim _ w) = integer w
pmPprHsLit (HsWord32Prim _ w) = integer w
pmPprHsLit (HsWord64Prim _ w) = integer w
-pmPprHsLit (HsInteger _ i _) = integer i
-pmPprHsLit (HsRat _ f _) = ppr f
pmPprHsLit (HsFloatPrim _ f) = ppr f
pmPprHsLit (HsDoublePrim _ d) = ppr d
+pmPprHsLit (XLit x) = case ghcPass @p of
+ GhcTc -> case x of
+ (HsInteger _ i _) -> integer i
+ (HsRat f _) -> ppr f
negateOverLitVal :: OverLitVal -> OverLitVal
negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i)
=====================================
compiler/GHC/Hs/Syn/Type.hs
=====================================
@@ -7,8 +7,7 @@ module GHC.Hs.Syn.Type (
-- * Extracting types from HsExpr
lhsExprType, hsExprType, hsWrapperType,
-- * Extracting types from HsSyn
- hsLitType, hsPatType, hsLPatType
-
+ hsLitType, hsPatType, hsLPatType,
) where
import GHC.Prelude
@@ -72,7 +71,7 @@ hsPatType (XPat ext) =
ExpansionPat _ pat -> hsPatType pat
hsPatType (SplicePat v _) = dataConCantHappen v
-hsLitType :: HsLit (GhcPass p) -> Type
+hsLitType :: forall p. IsPass p => HsLit (GhcPass p) -> Type
hsLitType (HsChar _ _) = charTy
hsLitType (HsCharPrim _ _) = charPrimTy
hsLitType (HsString _ _) = stringTy
@@ -89,10 +88,12 @@ hsLitType (HsWord8Prim _ _) = word8PrimTy
hsLitType (HsWord16Prim _ _) = word16PrimTy
hsLitType (HsWord32Prim _ _) = word32PrimTy
hsLitType (HsWord64Prim _ _) = word64PrimTy
-hsLitType (HsInteger _ _ ty) = ty
-hsLitType (HsRat _ _ ty) = ty
hsLitType (HsFloatPrim _ _) = floatPrimTy
hsLitType (HsDoublePrim _ _) = doublePrimTy
+hsLitType (XLit x) = case ghcPass @p of
+ GhcTc -> case x of
+ (HsInteger _ _ ty) -> ty
+ (HsRat _ ty) -> ty
-- | Compute the 'Type' of an @'LHsExpr' 'GhcTc'@ in a pure fashion.
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -305,7 +305,7 @@ dsExpr (HsProjection x _) = dataConCantHappen x
dsExpr (HsLit _ lit)
= do { warnAboutOverflowedLit lit
- ; dsLit (convertLit lit) }
+ ; dsLit lit }
dsExpr (HsOverLit _ lit)
= do { warnAboutOverflowedOverLit lit
=====================================
compiler/GHC/HsToCore/Match/Literal.hs
=====================================
@@ -97,7 +97,7 @@ For numeric literals, we try to detect there use at a standard type
See also below where we look for @DictApps@ for \tr{plusInt}, etc.
-}
-dsLit :: HsLit GhcRn -> DsM CoreExpr
+dsLit :: forall p. IsPass p => HsLit (GhcPass p) -> DsM CoreExpr
dsLit l = do
dflags <- getDynFlags
let platform = targetPlatform dflags
@@ -122,9 +122,11 @@ dsLit l = do
HsChar _ c -> return (mkCharExpr c)
HsString _ str -> mkStringExprFS str
HsMultilineString _ str -> mkStringExprFS str
- HsInteger _ i _ -> return (mkIntegerExpr platform i)
HsInt _ i -> return (mkIntExpr platform (il_value i))
- HsRat _ fl ty -> dsFractionalLitToRational fl ty
+ XLit x -> case ghcPass @p of
+ GhcTc -> case x of
+ HsInteger _ i _ -> return (mkIntegerExpr platform i)
+ HsRat fl ty -> dsFractionalLitToRational fl ty
{-
Note [FractionalLit representation]
@@ -460,24 +462,24 @@ getIntegralLit _ = Nothing
-- | If 'Integral', extract the value and type of the non-overloaded literal.
getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Type)
getSimpleIntegralLit (HsInt _ IL{ il_value = i }) = Just (i, intTy)
-getSimpleIntegralLit (HsIntPrim _ i) = Just (i, intPrimTy)
-getSimpleIntegralLit (HsWordPrim _ i) = Just (i, wordPrimTy)
-getSimpleIntegralLit (HsInt8Prim _ i) = Just (i, int8PrimTy)
-getSimpleIntegralLit (HsInt16Prim _ i) = Just (i, int16PrimTy)
-getSimpleIntegralLit (HsInt32Prim _ i) = Just (i, int32PrimTy)
-getSimpleIntegralLit (HsInt64Prim _ i) = Just (i, int64PrimTy)
-getSimpleIntegralLit (HsWord8Prim _ i) = Just (i, word8PrimTy)
-getSimpleIntegralLit (HsWord16Prim _ i) = Just (i, word16PrimTy)
-getSimpleIntegralLit (HsWord32Prim _ i) = Just (i, word32PrimTy)
-getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTy)
-getSimpleIntegralLit (HsInteger _ i ty) = Just (i, ty)
+getSimpleIntegralLit (HsIntPrim _ i) = Just (i, intPrimTy)
+getSimpleIntegralLit (HsWordPrim _ i) = Just (i, wordPrimTy)
+getSimpleIntegralLit (HsInt8Prim _ i) = Just (i, int8PrimTy)
+getSimpleIntegralLit (HsInt16Prim _ i) = Just (i, int16PrimTy)
+getSimpleIntegralLit (HsInt32Prim _ i) = Just (i, int32PrimTy)
+getSimpleIntegralLit (HsInt64Prim _ i) = Just (i, int64PrimTy)
+getSimpleIntegralLit (HsWord8Prim _ i) = Just (i, word8PrimTy)
+getSimpleIntegralLit (HsWord16Prim _ i) = Just (i, word16PrimTy)
+getSimpleIntegralLit (HsWord32Prim _ i) = Just (i, word32PrimTy)
+getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTy)
+getSimpleIntegralLit (XLit (HsInteger _ i ty)) = Just (i, ty)
getSimpleIntegralLit HsChar{} = Nothing
getSimpleIntegralLit HsCharPrim{} = Nothing
getSimpleIntegralLit HsString{} = Nothing
getSimpleIntegralLit HsMultilineString{} = Nothing
getSimpleIntegralLit HsStringPrim{} = Nothing
-getSimpleIntegralLit HsRat{} = Nothing
+getSimpleIntegralLit (XLit (HsRat{})) = Nothing
getSimpleIntegralLit HsFloatPrim{} = Nothing
getSimpleIntegralLit HsDoublePrim{} = Nothing
=====================================
compiler/GHC/HsToCore/Pmc/Desugar.hs
=====================================
@@ -225,7 +225,7 @@ desugarPat x pat = case pat of
mkPmLitGrds x lit'
LitPat _ lit -> do
- core_expr <- dsLit (convertLit lit)
+ core_expr <- dsLit lit
let lit = expectJust "failed to detect Lit" (coreExprAsPmLit core_expr)
mkPmLitGrds x lit
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -3001,7 +3001,7 @@ repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr]
----------------------------------------------------------
-- Literals
-repLiteral :: HsLit GhcRn -> MetaM (Core TH.Lit)
+repLiteral :: HsLit GhcRn -> MetaM (Core TH.Lit)
repLiteral (HsStringPrim _ bs)
= do word8_ty <- lookupType word8TyConName
let w8s = unpack bs
@@ -3010,20 +3010,19 @@ repLiteral (HsStringPrim _ bs)
rep2_nw stringPrimLName [mkListExpr word8_ty w8s_expr]
repLiteral lit
= do lit' <- case lit of
- HsIntPrim _ i -> mk_integer i
- HsWordPrim _ w -> mk_integer w
- HsInt _ i -> mk_integer (il_value i)
- HsFloatPrim _ r -> mk_rational r
- HsDoublePrim _ r -> mk_rational r
- HsCharPrim _ c -> mk_char c
- _ -> return lit
- lit_expr <- lift $ dsLit lit'
+ HsIntPrim _ i -> dsLit <$> mk_integer i
+ HsWordPrim _ w -> dsLit <$> mk_integer w
+ HsInt _ i -> dsLit <$> mk_integer (il_value i)
+ HsFloatPrim _ r -> dsLit <$> mk_rational r
+ HsDoublePrim _ r -> dsLit <$> mk_rational r
+ HsCharPrim _ c -> dsLit <$> mk_char c
+ _ -> return $ dsLit lit
+ lit_expr <- lift lit'
case mb_lit_name of
Just lit_name -> rep2_nw lit_name [lit_expr]
Nothing -> notHandled (ThExoticLiteral lit)
where
mb_lit_name = case lit of
- HsInteger _ _ _ -> Just integerLName
HsInt _ _ -> Just integerLName
HsIntPrim _ _ -> Just intPrimLName
HsWordPrim _ _ -> Just wordPrimLName
@@ -3033,32 +3032,41 @@ repLiteral lit
HsCharPrim _ _ -> Just charPrimLName
HsString _ _ -> Just stringLName
HsMultilineString _ _ -> Just stringLName
- HsRat _ _ _ -> Just rationalLName
_ -> Nothing
-mk_integer :: Integer -> MetaM (HsLit GhcRn)
-mk_integer i = return $ HsInteger NoSourceText i integerTy
+mk_integer :: Integer -> MetaM (HsLit GhcTc)
+mk_integer i = return $ XLit $ HsInteger NoSourceText i integerTy
-mk_rational :: FractionalLit -> MetaM (HsLit GhcRn)
+mk_rational :: FractionalLit -> MetaM (HsLit GhcTc)
mk_rational r = do rat_ty <- lookupType rationalTyConName
- return $ HsRat noExtField r rat_ty
-mk_string :: FastString -> MetaM (HsLit GhcRn)
+ return $ XLit $ HsRat r rat_ty
+mk_string :: FastString -> MetaM (HsLit GhcTc)
mk_string s = return $ HsString NoSourceText s
-mk_char :: Char -> MetaM (HsLit GhcRn)
+mk_char :: Char -> MetaM (HsLit GhcTc)
mk_char c = return $ HsChar NoSourceText c
repOverloadedLiteral :: HsOverLit GhcRn -> MetaM (Core TH.Lit)
repOverloadedLiteral (OverLit { ol_val = val})
- = do { lit <- mk_lit val; repLiteral lit }
- -- The type Rational will be in the environment, because
- -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
- -- and rationalL is sucked in when any TH stuff is used
-
-mk_lit :: OverLitVal -> MetaM (HsLit GhcRn)
-mk_lit (HsIntegral i) = mk_integer (il_value i)
-mk_lit (HsFractional f) = mk_rational f
-mk_lit (HsIsString _ s) = mk_string s
+ = repOverLiteralVal val
+ -- The type Rational will be in the environment, because
+ -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
+ -- and rationalL is sucked in when any TH stuff is used
+
+repOverLiteralVal :: OverLitVal -> MetaM (Core TH.Lit)
+repOverLiteralVal lit = do
+ lit' <- case lit of
+ (HsIntegral i) -> mk_integer (il_value i)
+ (HsFractional f) -> mk_rational f
+ (HsIsString _ s) -> mk_string s
+ lit_expr <- lift $ dsLit lit'
+
+ let lit_name = case lit of
+ (HsIntegral _ ) -> integerLName
+ (HsFractional _) -> rationalLName
+ (HsIsString _ _) -> stringLName
+
+ rep2_nw lit_name [lit_expr]
repRdrName :: RdrName -> MetaM (Core TH.Name)
repRdrName rdr_name = do
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -374,7 +374,7 @@ rnExpr (HsLit x lit) | Just (src, s) <- stringLike lit
rnExpr (HsOverLit x (mkHsIsString src s))
else do {
; rnLit lit
- ; return (HsLit x (convertLit lit), emptyFVs) } }
+ ; return (HsLit x (convertLitPsRn lit), emptyFVs) } }
where
stringLike = \case
HsString src s -> Just (src, s)
@@ -383,7 +383,7 @@ rnExpr (HsLit x lit) | Just (src, s) <- stringLike lit
rnExpr (HsLit x lit)
= do { rnLit lit
- ; return (HsLit x(convertLit lit), emptyFVs) }
+ ; return (HsLit x(convertLitPsRn lit), emptyFVs) }
rnExpr (HsOverLit x lit)
= do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero]
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -572,7 +572,7 @@ rnPatAndThen mk (LitPat x lit)
else normal_lit }
| otherwise = normal_lit
where
- normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLit lit)) }
+ normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLitPsRn lit)) }
rnPatAndThen _ (NPat x (L l lit) mb_neg _eq)
= do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit
=====================================
compiler/GHC/Tc/Errors.hs
=====================================
@@ -580,22 +580,20 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics
tidy_errs = bagToList (mapBag (tidyDelayedError env) errs)
partition_errors :: [DelayedError] -> ([Hole], [Hole], [NotConcreteError], [(TcCoercion, CtLoc)])
- partition_errors = go [] [] [] []
- where
- go out_of_scope other_holes syn_eqs mult_co_errs []
- = (out_of_scope, other_holes, syn_eqs, mult_co_errs)
- go es1 es2 es3 es4 (err:errs)
- | (es1, es2, es3, es4) <- go es1 es2 es3 es4 errs
- = case err of
- DE_Hole hole
- | isOutOfScopeHole hole
- -> (hole : es1, es2, es3, es4)
- | otherwise
- -> (es1, hole : es2, es3, es4)
- DE_NotConcrete err
- -> (es1, es2, err : es3, es4)
- DE_Multiplicity mult_co loc
- -> (es1, es2, es3, (mult_co, loc):es4)
+ partition_errors []
+ = ([], [], [], [])
+ partition_errors (err:errs)
+ | (es1, es2, es3, es4) <- partition_errors errs
+ = case err of
+ DE_Hole hole
+ | isOutOfScopeHole hole
+ -> (hole : es1, es2, es3, es4)
+ | otherwise
+ -> (es1, hole : es2, es3, es4)
+ DE_NotConcrete err
+ -> (es1, es2, err : es3, es4)
+ DE_Multiplicity mult_co loc
+ -> (es1, es2, es3, (mult_co, loc):es4)
-- See Note [Suppressing confusing errors]
suppress :: ErrorItem -> Bool
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -317,7 +317,7 @@ tcExpr (HsUnboundVar _ occ) res_ty
tcExpr e@(HsLit x lit) res_ty
= do { let lit_ty = hsLitType lit
- ; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty }
+ ; tcWrapResult e (HsLit x (convertLitRnTc lit)) lit_ty res_ty }
tcExpr (HsPar x expr) res_ty
= do { expr' <- tcMonoExprNC expr res_ty
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -829,7 +829,7 @@ Fortunately that's what matchActualFunTy returns anyway.
; wrap <- tc_sub_type penv (scaledThing pat_ty) lit_ty
; res <- thing_inside
; pat_ty <- readExpType (scaledThing pat_ty)
- ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty
+ ; return ( mkHsWrapPat wrap (LitPat x (convertLitRnTc simple_lit)) pat_ty
, res) }
------------------------
=====================================
compiler/GHC/Tc/Utils/Instantiate.hs
=====================================
@@ -807,15 +807,14 @@ newNonTrivialOverloadedLit
orig = LiteralOrigin lit
------------
-mkOverLit :: OverLitVal -> TcM (HsLit (GhcPass p))
+mkOverLit :: OverLitVal -> TcM (HsLit GhcTc)
mkOverLit (HsIntegral i)
= do { integer_ty <- tcMetaTy integerTyConName
- ; return (HsInteger (il_text i)
- (il_value i) integer_ty) }
+ ; return (XLit $ HsInteger (il_text i) (il_value i) integer_ty) }
mkOverLit (HsFractional r)
= do { rat_ty <- tcMetaTy rationalTyConName
- ; return (HsRat noExtField r rat_ty) }
+ ; return (XLit $ HsRat r rat_ty) }
mkOverLit (HsIsString src s) = return (HsString src s)
=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -2368,7 +2368,7 @@ shortCutLit platform val res_ty
| isWordTy res_ty && platformInWordRange platform i
= Just (mkLit wordDataCon (HsWordPrim src i))
| isIntegerTy res_ty
- = Just (HsLit noExtField (HsInteger src i res_ty))
+ = Just (HsLit noExtField (XLit $ HsInteger src i res_ty))
| otherwise
= go_fractional (integralFractionalLit neg i)
-- The 'otherwise' case is important
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -943,9 +943,9 @@ zonkExpr (HsIPVar x _) = dataConCantHappen x
zonkExpr (HsOverLabel x _) = dataConCantHappen x
-zonkExpr (HsLit x (HsRat e f ty))
+zonkExpr (HsLit x (XLit (HsRat f ty)))
= do new_ty <- zonkTcTypeToTypeX ty
- return (HsLit x (HsRat e f new_ty))
+ return (HsLit x (XLit $ HsRat f new_ty))
zonkExpr (HsLit x lit)
= return (HsLit x lit)
=====================================
compiler/Language/Haskell/Syntax/Extension.hs
=====================================
@@ -569,8 +569,6 @@ type family XHsWord8Prim x
type family XHsWord16Prim x
type family XHsWord32Prim x
type family XHsWord64Prim x
-type family XHsInteger x
-type family XHsRat x
type family XHsFloatPrim x
type family XHsDoublePrim x
type family XXLit x
=====================================
compiler/Language/Haskell/Syntax/Lit.hs
=====================================
@@ -21,7 +21,6 @@ module Language.Haskell.Syntax.Lit where
import Language.Haskell.Syntax.Extension
import GHC.Types.SourceText (IntegralLit, FractionalLit, SourceText)
-import GHC.Core.Type (Type)
import GHC.Data.FastString (FastString, lexicalCompareFS)
@@ -80,22 +79,13 @@ data HsLit x
-- ^ literal @Word32#@
| HsWord64Prim (XHsWord64Prim x) {- SourceText -} Integer
-- ^ literal @Word64#@
- | HsInteger (XHsInteger x) {- SourceText -} Integer Type
- -- ^ Genuinely an integer; arises only
- -- from TRANSLATION (overloaded
- -- literals are done with HsOverLit)
- | HsRat (XHsRat x) FractionalLit Type
- -- ^ Genuinely a rational; arises only from
- -- TRANSLATION (overloaded literals are
- -- done with HsOverLit)
| HsFloatPrim (XHsFloatPrim x) FractionalLit
-- ^ Unboxed Float
| HsDoublePrim (XHsDoublePrim x) FractionalLit
-- ^ Unboxed Double
-
| XLit !(XXLit x)
-instance Eq (HsLit x) where
+instance (Eq (XXLit x)) => Eq (HsLit x) where
(HsChar _ x1) == (HsChar _ x2) = x1==x2
(HsCharPrim _ x1) == (HsCharPrim _ x2) = x1==x2
(HsString _ x1) == (HsString _ x2) = x1==x2
@@ -105,10 +95,9 @@ instance Eq (HsLit x) where
(HsWordPrim _ x1) == (HsWordPrim _ x2) = x1==x2
(HsInt64Prim _ x1) == (HsInt64Prim _ x2) = x1==x2
(HsWord64Prim _ x1) == (HsWord64Prim _ x2) = x1==x2
- (HsInteger _ x1 _) == (HsInteger _ x2 _) = x1==x2
- (HsRat _ x1 _) == (HsRat _ x2 _) = x1==x2
(HsFloatPrim _ x1) == (HsFloatPrim _ x2) = x1==x2
(HsDoublePrim _ x1) == (HsDoublePrim _ x2) = x1==x2
+ (XLit x1) == (XLit x2) = x1==x2
_ == _ = False
-- | Haskell Overloaded Literal
=====================================
testsuite/tests/ghc-api/annotations-literals/parsed.hs
=====================================
@@ -64,8 +64,6 @@ testOneFile libdir fileName = do
= ["HsInt64Prim [" ++ unpackFS src ++ "] " ++ show c]
doHsLit (HsWord64Prim (SourceText src) c)
= ["HsWord64Prim [" ++ unpackFS src ++ "] " ++ show c]
- doHsLit (HsInteger (SourceText src) c _)
- = ["HsInteger [" ++ unpackFS src ++ "] " ++ show c]
doHsLit _ = []
doOverLit :: OverLitVal -> [String]
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -4948,8 +4948,6 @@ hsLit2String lit =
HsWord16Prim src v -> toSourceTextWithSuffix src v ""
HsWord32Prim src v -> toSourceTextWithSuffix src v ""
HsWord64Prim src v -> toSourceTextWithSuffix src v ""
- HsInteger src v _ -> toSourceTextWithSuffix src v ""
- HsRat _ fl@(FL{fl_text = src }) _ -> toSourceTextWithSuffix src fl ""
HsFloatPrim _ fl@(FL{fl_text = src }) -> toSourceTextWithSuffix src fl "#"
HsDoublePrim _ fl@(FL{fl_text = src }) -> toSourceTextWithSuffix src fl "##"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/65d7019b7137c6851b3b2ea76d6c9dccd0ccfb43...a12ea597f3876dcdcabecc12aa21ca732832949f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/65d7019b7137c6851b3b2ea76d6c9dccd0ccfb43...a12ea597f3876dcdcabecc12aa21ca732832949f
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241009/5af3c14c/attachment-0001.html>
More information about the ghc-commits
mailing list