[Git][ghc/ghc][wip/9.2.6-backports] 13 commits: Fix shadowing lacuna in OccurAnal
Zubin (@wz1000)
gitlab at gitlab.haskell.org
Thu Feb 2 18:44:52 UTC 2023
Zubin pushed to branch wip/9.2.6-backports at Glasgow Haskell Compiler / GHC
Commits:
400f86ab by Simon Peyton Jones at 2023-02-03T00:13:00+05:30
Fix shadowing lacuna in OccurAnal
Issue #22623 demonstrated another lacuna in the implementation
of wrinkle (BS3) in Note [The binder-swap substitution] in
the occurrence analyser.
I was failing to add TyVar lambda binders using
addInScope/addOneInScope and that led to a totally bogus binder-swap
transformation.
Very easy to fix.
(cherry picked from commit e193e53790dd5886feea3cf4c9c17625d188291b)
- - - - -
bc460408 by Sebastian Graf at 2023-02-03T00:13:00+05:30
DmdAnal: Don't panic in addCaseBndrDmd (#22039)
Rather conservatively return Top.
See Note [Untyped demand on case-alternative binders].
I also factored `addCaseBndrDmd` into two separate functions `scrutSubDmd` and
`fieldBndrDmds`.
Fixes #22039.
(cherry picked from commit d2be80fd9b222963e8dd09a30f78c106e00da7f9)
- - - - -
302649f1 by Matthew Pickering at 2023-02-03T00:13:00+05:30
ApplicativeDo: Set pattern location before running exhaustiveness checker
This improves the error messages of the exhaustiveness checker when
checking statements which have been moved around with ApplicativeDo.
Before:
Test.hs:2:3: warning: [GHC-62161] [-Wincomplete-uni-patterns]
Pattern match(es) are non-exhaustive
In a pattern binding:
Patterns of type ‘Maybe ()’ not matched: Nothing
|
2 | let x = ()
| ^^^^^^^^^^
After:
Test.hs:4:3: warning: [GHC-62161] [-Wincomplete-uni-patterns]
Pattern match(es) are non-exhaustive
In a pattern binding:
Patterns of type ‘Maybe ()’ not matched: Nothing
|
4 | ~(Just res1) <- seq x (pure $ Nothing @())
|
Fixes #22483
(cherry picked from commit 74c767df770766d8d52e87b9ff7da10f94620a91)
(cherry picked from commit 51c6051bcc405bc1dbddd450ade949acd70db6b8)
- - - - -
99e23ab1 by Andreas Klebinger at 2023-02-03T00:13:00+05:30
ghc-the-library: Retain cafs in both static in dynamic builds.
We use keepCAFsForGHCi.c to force -fkeep-cafs behaviour by using a
__attribute__((constructor)) function.
This broke for static builds where the linker discarded the object file
since it was not reverenced from any exported code. We fix this by
asserting that the flag is enabled using a function in the same module
as the constructor. Which causes the object file to be retained by the
linker, which in turn causes the constructor the be run in static builds.
This changes nothing for dynamic builds using the ghc library. But causes
static to also retain CAFs (as we expect them to).
Fixes #22417.
-------------------------
Metric Decrease:
T21839r
-------------------------
(cherry picked from commit 08ba87200ff068aa37cac082e61ee7e2d534daf5)
- - - - -
279f67b3 by Matthew Pickering at 2023-02-03T00:13:00+05:30
T10955: Set DYLD_LIBRARY_PATH for darwin
The correct path to direct the dynamic linker on darwin is
DYLD_LIBRARY_PATH rather than LD_LIBRARY_PATH. On recent versions of OSX
using LD_LIBRARY_PATH seems to have stopped working.
For more reading see:
https://stackoverflow.com/questions/3146274/is-it-ok-to-use-dyld-library-path-on-mac-os-x-and-whats-the-dynamic-library-s
(cherry picked from commit a960ca817d6ad0109ea6edda50da3902cc538e86)
- - - - -
ebc4bc25 by Matthew Pickering at 2023-02-03T00:13:00+05:30
Skip T18623 on darwin (to add to the long list of OSs)
On recent versions of OSX, running `ulimit -v` results in
```
ulimit: setrlimit failed: invalid argument
```
Time is too short to work out what random stuff Apple has been doing
with ulimit, so just skip the test like we do for other platforms.
(cherry picked from commit 734847108420cf826a807c30ad54651659cf3a08)
- - - - -
4d5a0917 by Matthew Pickering at 2023-02-03T00:13:00+05:30
Pass -Wl,-no_fixup_chains to ld64 when appropiate
Recent versions of MacOS use a version of ld where `-fixup_chains` is on by default.
This is incompatible with our usage of `-undefined dynamic_lookup`. Therefore we
explicitly disable `fixup-chains` by passing `-no_fixup_chains` to the linker on
darwin. This results in a warning of the form:
ld: warning: -undefined dynamic_lookup may not work with chained fixups
The manual explains the incompatible nature of these two flags:
-undefined treatment
Specifies how undefined symbols are to be treated. Options are: error, warning,
suppress, or dynamic_lookup. The default is error. Note: dynamic_lookup that
depends on lazy binding will not work with chained fixups.
A relevant ticket is #22429
Here are also a few other links which are relevant to the issue:
Official comment: https://developer.apple.com/forums/thread/719961
More relevant links:
https://openradar.appspot.com/radar?id=5536824084660224
https://github.com/python/cpython/issues/97524
Note in release notes: https://developer.apple.com/documentation/xcode-release-notes/xcode-13-releas e-notes
(cherry picked from commit 8c0ea25fb4a27d4729aabf73f4c00b912bb0c58d)
- - - - -
02c1af60 by Cheng Shao at 2023-02-03T00:13:00+05:30
Fix typo in recent darwin tests fix
Corrects a typo in !9647. Otherwise T18623 will still fail on darwin
and stall other people's work.
(cherry picked from commit c45a5fffef2c76efbf5d3a009c3f6d0244a63f0d)
- - - - -
2aa7d46a by Ben Gamari at 2023-02-03T00:13:00+05:30
nativeGen/AArch64: Fix debugging output
Previously various panics would rely on a half-written Show
instance, leading to very unhelpful errors. Fix this.
See #22798.
(cherry picked from commit be417a47c7695998dea0adc05489a7b8838a78b6)
- - - - -
c55f5640 by Ben Gamari at 2023-02-03T00:13:00+05:30
nativeGen: Teach graph-colouring allocator that x18 is unusable
Previously trivColourable for AArch64 claimed that at 18 registers were
trivially-colourable. This is incorrect as x18 is reserved by the platform on
AArch64/Darwin.
See #22798.
(cherry picked from commit 30989d137b8f3a8fddbfd116e04b48f23c24f86c)
- - - - -
0d59b877 by Ben Gamari at 2023-02-03T00:13:00+05:30
nativeGen/AArch64: Fix graph-colouring allocator
Previously various `Instr` queries used by the graph-colouring allocator
failed to handle a few pseudo-instructions. This manifested in compiler
panicks while compiling `SHA`, which uses `-fregs-graph`.
Fixes #22798.
(cherry picked from commit 7566fd9de38c67360c090f828923d41587af519c)
- - - - -
3fd01fe2 by Ben Gamari at 2023-02-03T00:13:40+05:30
testsuite: Add regression test for #22798
(cherry picked from commit 2cb500a5ee1a31dfe1a2cdd71f175442026eb082)
- - - - -
9c35e76f by Zubin Duggal at 2023-02-03T00:13:40+05:30
hadrian: enable -haddock in perf flavour (#22734)
- - - - -
23 changed files:
- compiler/GHC.hs
- compiler/GHC/CmmToAsm/AArch64/Instr.hs
- compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/cbits/keepCAFsForGHCi.c
- configure.ac
- hadrian/src/Settings/Flavours/Performance.hs
- + m4/fp_ld_no_fixup_chains.m4
- + testsuite/tests/ado/T22483.hs
- + testsuite/tests/ado/T22483.stderr
- testsuite/tests/ado/all.T
- + testsuite/tests/codeGen/should_run/T22798.hs
- testsuite/tests/codeGen/should_run/all.T
- testsuite/tests/ghci/T16392/T16392.script
- testsuite/tests/ghci/linking/dyn/Makefile
- testsuite/tests/rts/T18623/all.T
- + testsuite/tests/simplCore/should_compile/T22623.hs
- + testsuite/tests/simplCore/should_compile/T22623a.hs
- testsuite/tests/simplCore/should_compile/all.T
- + testsuite/tests/stranal/should_compile/T22039.hs
- testsuite/tests/stranal/should_compile/all.T
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -358,6 +358,7 @@ import GHC.Utils.Monad
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Utils.Logger
import GHC.Core.Predicate
@@ -554,7 +555,12 @@ withCleanupSession ghc = ghc `MC.finally` cleanup
initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
initGhcMonad mb_top_dir
- = do { env <- liftIO $
+ = do { -- The call to c_keepCAFsForGHCi must not be optimized away. Even in non-debug builds.
+ -- So we can't use assertM here.
+ -- See Note [keepCAFsForGHCi] in keepCAFsForGHCi.c for details about why.
+ !keep_cafs <- liftIO $ c_keepCAFsForGHCi
+ ; MASSERT( keep_cafs )
+ ; env <- liftIO $
do { top_dir <- findTopDir mb_top_dir
; mySettings <- initSysTools top_dir
; myLlvmConfig <- lazyInitLlvmConfig top_dir
@@ -600,7 +606,6 @@ checkBrokenTablesNextToCode' logger dflags
arch = platformArch platform
tablesNextToCode = platformTablesNextToCode platform
-
-- %************************************************************************
-- %* *
-- Flags & settings
@@ -1931,3 +1936,5 @@ instance Exception GhcApiError
mkApiErr :: DynFlags -> SDoc -> GhcApiError
mkApiErr dflags msg = GhcApiError (showSDoc dflags msg)
+foreign import ccall unsafe "keepCAFsForGHCi"
+ c_keepCAFsForGHCi :: IO Bool
=====================================
compiler/GHC/CmmToAsm/AArch64/Instr.hs
=====================================
@@ -73,6 +73,11 @@ instance Outputable RegUsage where
regUsageOfInstr :: Platform -> Instr -> RegUsage
regUsageOfInstr platform instr = case instr of
ANN _ i -> regUsageOfInstr platform i
+ COMMENT{} -> usage ([], [])
+ PUSH_STACK_FRAME -> usage ([], [])
+ POP_STACK_FRAME -> usage ([], [])
+ DELTA{} -> usage ([], [])
+
-- 1. Arithmetic Instructions ------------------------------------------------
ADD dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
CMN l r -> usage (regOp l ++ regOp r, [])
@@ -137,7 +142,7 @@ regUsageOfInstr platform instr = case instr of
FCVTZS dst src -> usage (regOp src, regOp dst)
FABS dst src -> usage (regOp src, regOp dst)
- _ -> panic "regUsageOfInstr"
+ _ -> panic $ "regUsageOfInstr: " ++ instrCon instr
where
-- filtering the usage is necessary, otherwise the register
@@ -203,7 +208,11 @@ callerSavedRegisters
patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr
patchRegsOfInstr instr env = case instr of
-- 0. Meta Instructions
- ANN d i -> ANN d (patchRegsOfInstr i env)
+ ANN d i -> ANN d (patchRegsOfInstr i env)
+ COMMENT{} -> instr
+ PUSH_STACK_FRAME -> instr
+ POP_STACK_FRAME -> instr
+ DELTA{} -> instr
-- 1. Arithmetic Instructions ----------------------------------------------
ADD o1 o2 o3 -> ADD (patchOp o1) (patchOp o2) (patchOp o3)
CMN o1 o2 -> CMN (patchOp o1) (patchOp o2)
@@ -269,8 +278,7 @@ patchRegsOfInstr instr env = case instr of
SCVTF o1 o2 -> SCVTF (patchOp o1) (patchOp o2)
FCVTZS o1 o2 -> FCVTZS (patchOp o1) (patchOp o2)
FABS o1 o2 -> FABS (patchOp o1) (patchOp o2)
-
- _ -> pprPanic "patchRegsOfInstr" (text $ show instr)
+ _ -> panic $ "patchRegsOfInstr: " ++ instrCon instr
where
patchOp :: Operand -> Operand
patchOp (OpReg w r) = OpReg w (env r)
@@ -326,7 +334,7 @@ patchJumpInstr instr patchF
B (TBlock bid) -> B (TBlock (patchF bid))
BL (TBlock bid) ps rs -> BL (TBlock (patchF bid)) ps rs
BCOND c (TBlock bid) -> BCOND c (TBlock (patchF bid))
- _ -> pprPanic "patchJumpInstr" (text $ show instr)
+ _ -> panic $ "patchJumpInstr: " ++ instrCon instr
-- -----------------------------------------------------------------------------
-- Note [Spills and Reloads]
@@ -638,10 +646,69 @@ data Instr
-- Float ABSolute value
| FABS Operand Operand
-instance Show Instr where
- show (LDR _f o1 o2) = "LDR " ++ show o1 ++ ", " ++ show o2
- show (MOV o1 o2) = "MOV " ++ show o1 ++ ", " ++ show o2
- show _ = "missing"
+instrCon :: Instr -> String
+instrCon i =
+ case i of
+ COMMENT{} -> "COMMENT"
+ MULTILINE_COMMENT{} -> "COMMENT"
+ ANN{} -> "ANN"
+ LOCATION{} -> "LOCATION"
+ LDATA{} -> "LDATA"
+ NEWBLOCK{} -> "NEWBLOCK"
+ DELTA{} -> "DELTA"
+ SXTB{} -> "SXTB"
+ UXTB{} -> "UXTB"
+ SXTH{} -> "SXTH"
+ UXTH{} -> "UXTH"
+ PUSH_STACK_FRAME{} -> "PUSH_STACK_FRAME"
+ POP_STACK_FRAME{} -> "POP_STACK_FRAME"
+ ADD{} -> "ADD"
+ CMN{} -> "CMN"
+ CMP{} -> "CMP"
+ MSUB{} -> "MSUB"
+ MUL{} -> "MUL"
+ NEG{} -> "NEG"
+ SDIV{} -> "SDIV"
+ SMULH{} -> "SMULH"
+ SMULL{} -> "SMULL"
+ SUB{} -> "SUB"
+ UDIV{} -> "UDIV"
+ SBFM{} -> "SBFM"
+ UBFM{} -> "UBFM"
+ SBFX{} -> "SBFX"
+ UBFX{} -> "UBFX"
+ AND{} -> "AND"
+ ANDS{} -> "ANDS"
+ ASR{} -> "ASR"
+ BIC{} -> "BIC"
+ BICS{} -> "BICS"
+ EON{} -> "EON"
+ EOR{} -> "EOR"
+ LSL{} -> "LSL"
+ LSR{} -> "LSR"
+ MOV{} -> "MOV"
+ MOVK{} -> "MOVK"
+ MVN{} -> "MVN"
+ ORN{} -> "ORN"
+ ORR{} -> "ORR"
+ ROR{} -> "ROR"
+ TST{} -> "TST"
+ STR{} -> "STR"
+ LDR{} -> "LDR"
+ STP{} -> "STP"
+ LDP{} -> "LDP"
+ CSET{} -> "CSET"
+ CBZ{} -> "CBZ"
+ CBNZ{} -> "CBNZ"
+ J{} -> "J"
+ B{} -> "B"
+ BL{} -> "BL"
+ BCOND{} -> "BCOND"
+ DMBSY{} -> "DMBSY"
+ FCVT{} -> "FCVT"
+ SCVTF{} -> "SCVTF"
+ FCVTZS{} -> "FCVTZS"
+ FABS{} -> "FABS"
data Target
= TBlock BlockId
@@ -769,11 +836,11 @@ opRegUExt W64 r = OpRegExt W64 r EUXTX 0
opRegUExt W32 r = OpRegExt W32 r EUXTW 0
opRegUExt W16 r = OpRegExt W16 r EUXTH 0
opRegUExt W8 r = OpRegExt W8 r EUXTB 0
-opRegUExt w _r = pprPanic "opRegUExt" (text $ show w)
+opRegUExt w _r = pprPanic "opRegUExt" (ppr w)
opRegSExt :: Width -> Reg -> Operand
opRegSExt W64 r = OpRegExt W64 r ESXTX 0
opRegSExt W32 r = OpRegExt W32 r ESXTW 0
opRegSExt W16 r = OpRegExt W16 r ESXTH 0
opRegSExt W8 r = OpRegExt W8 r ESXTB 0
-opRegSExt w _r = pprPanic "opRegSExt" (text $ show w)
+opRegSExt w _r = pprPanic "opRegSExt" (ppr w)
=====================================
compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs
=====================================
@@ -115,10 +115,8 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts excl
ArchSPARC64 -> panic "trivColorable ArchSPARC64"
ArchPPC_64 _ -> 15
ArchARM _ _ _ -> panic "trivColorable ArchARM"
- -- We should be able to allocate *a lot* more in princple.
- -- essentially all 32 - SP, so 31, we'd trash the link reg
- -- as well as the platform and all others though.
- ArchAArch64 -> 18
+ -- N.B. x18 is reserved by the platform on AArch64/Darwin
+ ArchAArch64 -> 17
ArchAlpha -> panic "trivColorable ArchAlpha"
ArchMipseb -> panic "trivColorable ArchMipseb"
ArchMipsel -> panic "trivColorable ArchMipsel"
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -439,10 +439,11 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs])
-- whole DmdEnv
!(!bndrs', !scrut_sd)
| DataAlt _ <- alt
- , id_dmds <- addCaseBndrDmd case_bndr_sd dmds
- -- See Note [Demand on scrutinee of a product case]
- = let !new_info = setBndrsDemandInfo bndrs id_dmds
- !new_prod = mkProd id_dmds
+ -- See Note [Demand on the scrutinee of a product case]
+ , let !scrut_sd = scrutSubDmd case_bndr_sd dmds
+ , let !fld_dmds' = fieldBndrDmds scrut_sd (length dmds)
+ = let !new_info = setBndrsDemandInfo bndrs fld_dmds'
+ !new_prod = mkProd fld_dmds'
in (new_info, new_prod)
| otherwise
-- __DEFAULT and literal alts. Simply add demands and discard the
@@ -556,11 +557,32 @@ dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs)
, WithDmdType rhs_ty rhs' <- dmdAnal rhs_env dmd rhs
, WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs
, let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr
- -- See Note [Demand on scrutinee of a product case]
- id_dmds = addCaseBndrDmd case_bndr_sd dmds
+ -- See Note [Demand on case-alternative binders]
+ -- we can't use the scrut_sd, because it says 'Prod' and we'll use
+ -- topSubDmd anyway for scrutinees of sum types.
+ scrut_sd = scrutSubDmd case_bndr_sd dmds
+ id_dmds = fieldBndrDmds scrut_sd (length dmds)
-- Do not put a thunk into the Alt
- !new_ids = setBndrsDemandInfo bndrs id_dmds
- = WithDmdType alt_ty (Alt con new_ids rhs')
+ !new_ids = setBndrsDemandInfo bndrs id_dmds
+ = -- pprTrace "dmdAnalSumAlt" (ppr con $$ ppr case_bndr $$ ppr dmd $$ ppr alt_ty) $
+ WithDmdType alt_ty (Alt con new_ids rhs')
+
+-- See Note [Demand on the scrutinee of a product case]
+scrutSubDmd :: SubDemand -> [Demand] -> SubDemand
+scrutSubDmd case_sd fld_dmds =
+ -- pprTraceWith "scrutSubDmd" (\scrut_sd -> ppr case_sd $$ ppr fld_dmds $$ ppr scrut_sd) $
+ case_sd `plusSubDmd` mkProd fld_dmds
+
+-- See Note [Demand on case-alternative binders]
+fieldBndrDmds :: SubDemand -- on the scrutinee
+ -> Arity
+ -> [Demand] -- Final demands for the components of the DataCon
+fieldBndrDmds scrut_sd n_flds =
+ case viewProd n_flds scrut_sd of
+ Just ds -> ds
+ Nothing -> replicate n_flds topDmd
+ -- Either an arity mismatch or scrut_sd was a call demand.
+ -- See Note [Untyped demand on case-alternative binders]
{-
Note [Analysing with absent demand]
@@ -672,6 +694,89 @@ worker, so the worker will rebuild
x = (a, absent-error)
and that'll crash.
+Note [Demand on case-alternative binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The demand on a binder in a case alternative comes
+ (a) From the demand on the binder itself
+ (b) From the demand on the case binder
+Forgetting (b) led directly to #10148.
+
+Example. Source code:
+ f x@(p,_) = if p then foo x else True
+
+ foo (p,True) = True
+ foo (p,q) = foo (q,p)
+
+After strictness analysis, forgetting (b):
+ f = \ (x_an1 [Dmd=1P(1L,ML)] :: (Bool, Bool)) ->
+ case x_an1
+ of wild_X7 [Dmd=MP(ML,ML)]
+ { (p_an2 [Dmd=1L], ds_dnz [Dmd=A]) ->
+ case p_an2 of _ {
+ False -> GHC.Types.True;
+ True -> foo wild_X7 }
+
+Note that ds_dnz is syntactically dead, but the expression bound to it is
+reachable through the case binder wild_X7. Now watch what happens if we inline
+foo's wrapper:
+ f = \ (x_an1 [Dmd=1P(1L,ML)] :: (Bool, Bool)) ->
+ case x_an1
+ of _ [Dmd=MP(ML,ML)]
+ { (p_an2 [Dmd=1L], ds_dnz [Dmd=A]) ->
+ case p_an2 of _ {
+ False -> GHC.Types.True;
+ True -> $wfoo_soq GHC.Types.True ds_dnz }
+
+Look at that! ds_dnz has come back to life in the call to $wfoo_soq! A second
+run of demand analysis would no longer infer ds_dnz to be absent.
+But unlike occurrence analysis, which infers properties of the *syntactic*
+shape of the program, the results of demand analysis describe expressions
+*semantically* and are supposed to be mostly stable across Simplification.
+That's why we should better account for (b).
+In #10148, we ended up emitting a single-entry thunk instead of an updateable
+thunk for a let binder that was an an absent case-alt binder during DmdAnal.
+
+This is needed even for non-product types, in case the case-binder
+is used but the components of the case alternative are not.
+
+Note [Untyped demand on case-alternative binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+With unsafeCoerce, #8037 and #22039 taught us that the demand on the case binder
+may be a call demand or have a different number of fields than the constructor
+of the case alternative it is used in. From T22039:
+
+ blarg :: (Int, Int) -> Int
+ blarg (x,y) = x+y
+ -- blarg :: <1!P(1L,1L)>
+
+ f :: Either Int Int -> Int
+ f Left{} = 0
+ f e = blarg (unsafeCoerce e)
+ ==> { desugars to }
+ f = \ (ds_d1nV :: Either Int Int) ->
+ case ds_d1nV of wild_X1 {
+ Left ds_d1oV -> lvl_s1Q6;
+ Right ipv_s1Pl ->
+ blarg
+ (case unsafeEqualityProof @(*) @(Either Int Int) @(Int, Int) of
+ { UnsafeRefl co_a1oT ->
+ wild_X1 `cast` (Sub (Sym co_a1oT) :: Either Int Int ~R# (Int, Int))
+ })
+ }
+
+The case binder `e`/`wild_X1` has demand 1!P(1L,1L), with two fields, from the call
+to `blarg`, but `Right` only has one field. Although the code will crash when
+executed, we must be able to analyse it in 'fieldBndrDmds' and conservatively
+approximate with Top instead of panicking because of the mismatch.
+In #22039, this kind of code was guarded behind a safe `cast` and thus dead
+code, but nevertheless led to a panic of the compiler.
+
+You might wonder why the same problem doesn't come up when scrutinising a
+product type instead of a sum type. It appears that for products, `wild_X1`
+will be inlined before DmdAnal.
+
+See also Note [mkWWstr and unsafeCoerce] for a related issue.
+
Note [Aggregated demand for cardinality]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
FIXME: This Note should be named [LetUp vs. LetDown] and probably predates
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -1725,7 +1725,7 @@ occAnalRhs :: OccEnv -> RecFlag -> Maybe JoinArity
-> CoreExpr -- RHS
-> (UsageDetails, CoreExpr)
occAnalRhs env is_rec mb_join_arity rhs
- = case occAnalLamOrRhs env bndrs body of { (body_usage, bndrs', body') ->
+ = case occAnalLamOrRhs env1 bndrs body of { (body_usage, bndrs', body') ->
let final_bndrs | isRec is_rec = bndrs'
| otherwise = markJoinOneShots mb_join_arity bndrs'
-- For a /non-recursive/ join point we can mark all
@@ -1737,6 +1737,7 @@ occAnalRhs env is_rec mb_join_arity rhs
in (rhs_usage, mkLams final_bndrs body') }
where
(bndrs, body) = collectBinders rhs
+ env1 = addInScope env bndrs
occAnalUnfolding :: OccEnv
-> RecFlag
@@ -2005,7 +2006,7 @@ partially applying lambdas. See the calls to zapLamBndrs in
occAnal env expr@(Lam _ _)
= -- See Note [Occurrence analysis for lambda binders]
- case occAnalLamOrRhs env bndrs body of { (usage, tagged_bndrs, body') ->
+ case occAnalLamOrRhs env1 bndrs body of { (usage, tagged_bndrs, body') ->
let
expr' = mkLams tagged_bndrs body'
usage1 = markAllNonTail usage
@@ -2015,6 +2016,7 @@ occAnal env expr@(Lam _ _)
(final_usage, expr') }
where
(bndrs, body) = collectBinders expr
+ env1 = addInScope env bndrs
occAnal env (Case scrut bndr ty alts)
= case occAnal (scrutCtxt env alts) scrut of { (scrut_usage, scrut') ->
@@ -2284,12 +2286,13 @@ data OccEnv
-- See Note [The binder-swap substitution]
-- If x :-> (y, co) is in the env,
- -- then please replace x by (y |> sym mco)
- -- Invariant of course: idType x = exprType (y |> sym mco)
- , occ_bs_env :: VarEnv (OutId, MCoercion)
- , occ_bs_rng :: VarSet -- Vars free in the range of occ_bs_env
+ -- then please replace x by (y |> mco)
+ -- Invariant of course: idType x = exprType (y |> mco)
+ , occ_bs_env :: !(IdEnv (OutId, MCoercion))
-- Domain is Global and Local Ids
-- Range is just Local Ids
+ , occ_bs_rng :: !VarSet
+ -- Vars (TyVars and Ids) free in the range of occ_bs_env
}
@@ -2578,25 +2581,29 @@ Some tricky corners:
(BS3) We need care when shadowing. Suppose [x :-> b] is in occ_bs_env,
and we encounter:
- - \x. blah
- Here we want to delete the x-binding from occ_bs_env
-
- - \b. blah
- This is harder: we really want to delete all bindings that
- have 'b' free in the range. That is a bit tiresome to implement,
- so we compromise. We keep occ_bs_rng, which is the set of
- free vars of rng(occc_bs_env). If a binder shadows any of these
- variables, we discard all of occ_bs_env. Safe, if a bit
- brutal. NB, however: the simplifer de-shadows the code, so the
- next time around this won't happen.
+ (i) \x. blah
+ Here we want to delete the x-binding from occ_bs_env
+
+ (ii) \b. blah
+ This is harder: we really want to delete all bindings that
+ have 'b' free in the range. That is a bit tiresome to implement,
+ so we compromise. We keep occ_bs_rng, which is the set of
+ free vars of rng(occc_bs_env). If a binder shadows any of these
+ variables, we discard all of occ_bs_env. Safe, if a bit
+ brutal. NB, however: the simplifer de-shadows the code, so the
+ next time around this won't happen.
These checks are implemented in addInScope.
-
- The occurrence analyser itself does /not/ do cloning. It could, in
- principle, but it'd make it a bit more complicated and there is no
- great benefit. The simplifer uses cloning to get a no-shadowing
- situation, the care-when-shadowing behaviour above isn't needed for
- long.
+ (i) is needed only for Ids, but (ii) is needed for tyvars too (#22623)
+ because if occ_bs_env has [x :-> ...a...] where `a` is a tyvar, we
+ must not replace `x` by `...a...` under /\a. ...x..., or similarly
+ under a case pattern match that binds `a`.
+
+ An alternative would be for the occurrence analyser to do cloning as
+ it goes. In principle it could do so, but it'd make it a bit more
+ complicated and there is no great benefit. The simplifer uses
+ cloning to get a no-shadowing situation, the care-when-shadowing
+ behaviour above isn't needed for long.
(BS4) The domain of occ_bs_env can include GlobaIds. Eg
case M.foo of b { alts }
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -984,7 +984,8 @@ dsDo ctx stmts
; body' <- dsLExpr $ noLocA $ HsDo body_ty ctx (noLocA stmts)
; let match_args (pat, fail_op) (vs,body)
- = do { var <- selectSimpleMatchVarL Many pat
+ = putSrcSpanDs (getLocA pat) $
+ do { var <- selectSimpleMatchVarL Many pat
; match <- matchSinglePatVar var Nothing (StmtCtxt ctx) pat
body_ty (cantFailMatchResult body)
; match_code <- dsHandleMonadicFailure ctx pat match fail_op
=====================================
compiler/cbits/keepCAFsForGHCi.c
=====================================
@@ -1,15 +1,35 @@
#include <Rts.h>
+#include <ghcversion.h>
+// Note [keepCAFsForGHCi]
+// ~~~~~~~~~~~~~~~~~~~~~~
// This file is only included in the dynamic library.
// It contains an __attribute__((constructor)) function (run prior to main())
// which sets the keepCAFs flag in the RTS, before any Haskell code is run.
// This is required so that GHCi can use dynamic libraries instead of HSxyz.o
// files.
+//
+// For static builds we have to guarantee that the linker loads this object file
+// to ensure the constructor gets run and not discarded. If the object is part of
+// an archive and not otherwise referenced the linker would ignore the object.
+// To avoid this:
+// * When initializing a GHC session in initGhcMonad we assert keeping cafs has been
+// enabled by calling keepCAFsForGHCi.
+// * This causes the GHC module from the ghc package to carry a reference to this object
+// file.
+// * Which in turn ensures the linker doesn't discard this object file, causing
+// the constructor to be run, allowing the assertion to succeed in the first place
+// as keepCAFs will have been set already during initialization of constructors.
-static void keepCAFsForGHCi(void) __attribute__((constructor));
-static void keepCAFsForGHCi(void)
+
+bool keepCAFsForGHCi(void) __attribute__((constructor));
+
+bool keepCAFsForGHCi(void)
{
- keepCAFs = 1;
+ bool was_set = keepCAFs;
+ setKeepCAFs();
+ return was_set;
}
+
=====================================
configure.ac
=====================================
@@ -780,6 +780,10 @@ FPTOOLS_SET_C_LD_FLAGS([target],[CONF_CC_OPTS_STAGE1],[CONF_GCC_LINKER_OPTS_STAG
FPTOOLS_SET_C_LD_FLAGS([target],[CONF_CC_OPTS_STAGE2],[CONF_GCC_LINKER_OPTS_STAGE2],[CONF_LD_LINKER_OPTS_STAGE2],[CONF_CPP_OPTS_STAGE2])
# Stage 3 won't be supported by cross-compilation
+FP_LD_NO_FIXUP_CHAINS([target], [LDFLAGS])
+FP_LD_NO_FIXUP_CHAINS([build], [CONF_GCC_LINKER_OPTS_STAGE0])
+FP_LD_NO_FIXUP_CHAINS([target], [CONF_GCC_LINKER_OPTS_STAGE1])
+FP_LD_NO_FIXUP_CHAINS([target], [CONF_GCC_LINKER_OPTS_STAGE2])
dnl ** See whether cc supports --target=<triple> and set
dnl CONF_CC_OPTS_STAGE[12] accordingly.
FP_CC_SUPPORTS_TARGET
=====================================
hadrian/src/Settings/Flavours/Performance.hs
=====================================
@@ -13,6 +13,6 @@ performanceFlavour = defaultFlavour
performanceArgs :: Args
performanceArgs = sourceArgs SourceArgs
{ hsDefault = pure ["-O", "-H64m"]
- , hsLibrary = notStage0 ? arg "-O2"
+ , hsLibrary = mconcat [notStage0 ? arg "-O2", notStage0 ? arg "-haddock"]
, hsCompiler = pure ["-O2"]
, hsGhc = mconcat [stage0 ? arg "-O", notStage0 ? arg "-O2"] }
=====================================
m4/fp_ld_no_fixup_chains.m4
=====================================
@@ -0,0 +1,24 @@
+# FP_LD_NO_FIXUP_CHAINS
+# --------------------
+# See if whether we are using a version of ld64 on darwin platforms which
+# requires us to pass -no_fixup_chains
+#
+# $1 = the platform
+# $2 = the name of the linker flags variable when linking with $CC
+AC_DEFUN([FP_LD_NO_FIXUP_CHAINS], [
+ case $$1 in
+ *-darwin)
+ AC_MSG_CHECKING([whether ld64 requires -no_fixup_chains])
+ echo 'int main(void) {return 0;}' > conftest.c
+ if $CC -o conftest.o -Wl,-no_fixup_chains conftest.c > /dev/null 2>&1
+ then
+ $2="-Wl,-no_fixup_chains"
+ AC_MSG_RESULT([yes])
+ else
+ AC_MSG_RESULT([no])
+ fi
+ rm -f conftest.c conftest.o
+ ;;
+
+ esac
+])
=====================================
testsuite/tests/ado/T22483.hs
=====================================
@@ -0,0 +1,7 @@
+main = do
+ let x = ()
+ res2 <- pure ()
+ ~(Just res1) <- seq x (pure $ Nothing @())
+ print res1
+ print res2
+ pure ()
=====================================
testsuite/tests/ado/T22483.stderr
=====================================
@@ -0,0 +1,8 @@
+
+T22483.hs:1:1: warning: [-Wmissing-signatures (in -Wall)]
+ Top-level binding with no type signature: main :: IO ()
+
+T22483.hs:4:3: warning: [-Wincomplete-uni-patterns (in -Wall)]
+ Pattern match(es) are non-exhaustive
+ In a pattern binding:
+ Patterns of type ‘Maybe ()’ not matched: Nothing
=====================================
testsuite/tests/ado/all.T
=====================================
@@ -18,3 +18,4 @@ test('T14163', normal, compile_and_run, [''])
test('T15344', normal, compile_and_run, [''])
test('T16628', normal, compile_fail, [''])
test('T17835', normal, compile, [''])
+test('T22483', normal, compile, ['-Wall'])
=====================================
testsuite/tests/codeGen/should_run/T22798.hs
=====================================
@@ -0,0 +1,375 @@
+-- Derived from SHA-1.5.0.0
+-- This previously uncovered cases left unhandled in the AArch64 NCG (#22798).
+
+{-# LANGUAGE BangPatterns, CPP, FlexibleInstances #-}
+module Main (main) where
+
+import Data.Binary
+import Data.Binary.Get
+import Data.Binary.Put
+import Data.Bits
+import Data.ByteString.Lazy(ByteString)
+import Data.ByteString.Lazy.Char8 as BSC (pack)
+import qualified Data.ByteString.Lazy as BS
+import Data.Char (intToDigit)
+import Control.Monad
+
+newtype Digest t = Digest ByteString
+
+data SHA512State = SHA512S !Word64 !Word64 !Word64 !Word64
+ !Word64 !Word64 !Word64 !Word64
+
+initialSHA512State :: SHA512State
+initialSHA512State = SHA512S 0x6a09e667f3bcc908 0xbb67ae8584caa73b
+ 0x3c6ef372fe94f82b 0xa54ff53a5f1d36f1
+ 0x510e527fade682d1 0x9b05688c2b3e6c1f
+ 0x1f83d9abfb41bd6b 0x5be0cd19137e2179
+
+
+synthesizeSHA512 :: SHA512State -> Put
+synthesizeSHA512 (SHA512S a b c d e f g h) = do
+ putWord64be a
+ putWord64be b
+ putWord64be c
+ putWord64be d
+ putWord64be e
+ putWord64be f
+ putWord64be g
+ putWord64be h
+
+getSHA512 :: Get SHA512State
+getSHA512 = do
+ a <- getWord64be
+ b <- getWord64be
+ c <- getWord64be
+ d <- getWord64be
+ e <- getWord64be
+ f <- getWord64be
+ g <- getWord64be
+ h <- getWord64be
+ return $ SHA512S a b c d e f g h
+
+instance Binary SHA512State where
+ put = synthesizeSHA512
+ get = getSHA512
+
+padSHA512 :: ByteString -> ByteString
+padSHA512 = generic_pad 896 1024 128
+
+generic_pad :: Word64 -> Word64 -> Int -> ByteString -> ByteString
+generic_pad a b lSize bs = BS.concat [bs, pad_bytes, pad_length]
+ where
+ l = fromIntegral $ BS.length bs * 8
+ k = calc_k a b l
+ -- INVARIANT: k is necessarily > 0, and (k + 1) is a multiple of 8.
+ k_bytes = (k + 1) `div` 8
+ pad_bytes = BS.singleton 0x80 `BS.append` BS.replicate nZeroBytes 0
+ nZeroBytes = fromIntegral $ k_bytes - 1
+ pad_length = toBigEndianBS lSize l
+
+-- Given a, b, and l, calculate the smallest k such that (l + 1 + k) mod b = a.
+calc_k :: Word64 -> Word64 -> Word64 -> Word64
+calc_k a b l =
+ if r <= -1
+ then fromIntegral r + b
+ else fromIntegral r
+ where
+ r = toInteger a - toInteger l `mod` toInteger b - 1
+
+toBigEndianBS :: (Integral a, Bits a) => Int -> a -> ByteString
+toBigEndianBS s val = BS.pack $ map getBits [s - 8, s - 16 .. 0]
+ where
+ getBits x = fromIntegral $ (val `shiftR` x) .&. 0xFF
+
+{-# SPECIALIZE ch :: Word64 -> Word64 -> Word64 -> Word64 #-}
+ch :: Bits a => a -> a -> a -> a
+ch x y z = (x .&. y) `xor` (complement x .&. z)
+
+{-# SPECIALIZE maj :: Word64 -> Word64 -> Word64 -> Word64 #-}
+maj :: Bits a => a -> a -> a -> a
+maj x y z = (x .&. (y .|. z)) .|. (y .&. z)
+-- note:
+-- the original functions is (x & y) ^ (x & z) ^ (y & z)
+-- if you fire off truth tables, this is equivalent to
+-- (x & y) | (x & z) | (y & z)
+-- which you can the use distribution on:
+-- (x & (y | z)) | (y & z)
+-- which saves us one operation.
+
+bsig512_0 :: Word64 -> Word64
+bsig512_0 x = rotate x (-28) `xor` rotate x (-34) `xor` rotate x (-39)
+
+bsig512_1 :: Word64 -> Word64
+bsig512_1 x = rotate x (-14) `xor` rotate x (-18) `xor` rotate x (-41)
+
+lsig512_0 :: Word64 -> Word64
+lsig512_0 x = rotate x (-1) `xor` rotate x (-8) `xor` shiftR x 7
+
+lsig512_1 :: Word64 -> Word64
+lsig512_1 x = rotate x (-19) `xor` rotate x (-61) `xor` shiftR x 6
+
+data SHA512Sched = SHA512Sched !Word64 !Word64 !Word64 !Word64 !Word64 -- 0- 4
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 5- 9
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 10-14
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 15-19
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 20-24
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 25-29
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 30-34
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 35-39
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 40-44
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 45-49
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 50-54
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 55-59
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 60-64
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 65-69
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 70-74
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 75-79
+
+getSHA512Sched :: Get SHA512Sched
+getSHA512Sched = do
+ w00 <- getWord64be
+ w01 <- getWord64be
+ w02 <- getWord64be
+ w03 <- getWord64be
+ w04 <- getWord64be
+ w05 <- getWord64be
+ w06 <- getWord64be
+ w07 <- getWord64be
+ w08 <- getWord64be
+ w09 <- getWord64be
+ w10 <- getWord64be
+ w11 <- getWord64be
+ w12 <- getWord64be
+ w13 <- getWord64be
+ w14 <- getWord64be
+ w15 <- getWord64be
+ let w16 = lsig512_1 w14 + w09 + lsig512_0 w01 + w00
+ w17 = lsig512_1 w15 + w10 + lsig512_0 w02 + w01
+ w18 = lsig512_1 w16 + w11 + lsig512_0 w03 + w02
+ w19 = lsig512_1 w17 + w12 + lsig512_0 w04 + w03
+ w20 = lsig512_1 w18 + w13 + lsig512_0 w05 + w04
+ w21 = lsig512_1 w19 + w14 + lsig512_0 w06 + w05
+ w22 = lsig512_1 w20 + w15 + lsig512_0 w07 + w06
+ w23 = lsig512_1 w21 + w16 + lsig512_0 w08 + w07
+ w24 = lsig512_1 w22 + w17 + lsig512_0 w09 + w08
+ w25 = lsig512_1 w23 + w18 + lsig512_0 w10 + w09
+ w26 = lsig512_1 w24 + w19 + lsig512_0 w11 + w10
+ w27 = lsig512_1 w25 + w20 + lsig512_0 w12 + w11
+ w28 = lsig512_1 w26 + w21 + lsig512_0 w13 + w12
+ w29 = lsig512_1 w27 + w22 + lsig512_0 w14 + w13
+ w30 = lsig512_1 w28 + w23 + lsig512_0 w15 + w14
+ w31 = lsig512_1 w29 + w24 + lsig512_0 w16 + w15
+ w32 = lsig512_1 w30 + w25 + lsig512_0 w17 + w16
+ w33 = lsig512_1 w31 + w26 + lsig512_0 w18 + w17
+ w34 = lsig512_1 w32 + w27 + lsig512_0 w19 + w18
+ w35 = lsig512_1 w33 + w28 + lsig512_0 w20 + w19
+ w36 = lsig512_1 w34 + w29 + lsig512_0 w21 + w20
+ w37 = lsig512_1 w35 + w30 + lsig512_0 w22 + w21
+ w38 = lsig512_1 w36 + w31 + lsig512_0 w23 + w22
+ w39 = lsig512_1 w37 + w32 + lsig512_0 w24 + w23
+ w40 = lsig512_1 w38 + w33 + lsig512_0 w25 + w24
+ w41 = lsig512_1 w39 + w34 + lsig512_0 w26 + w25
+ w42 = lsig512_1 w40 + w35 + lsig512_0 w27 + w26
+ w43 = lsig512_1 w41 + w36 + lsig512_0 w28 + w27
+ w44 = lsig512_1 w42 + w37 + lsig512_0 w29 + w28
+ w45 = lsig512_1 w43 + w38 + lsig512_0 w30 + w29
+ w46 = lsig512_1 w44 + w39 + lsig512_0 w31 + w30
+ w47 = lsig512_1 w45 + w40 + lsig512_0 w32 + w31
+ w48 = lsig512_1 w46 + w41 + lsig512_0 w33 + w32
+ w49 = lsig512_1 w47 + w42 + lsig512_0 w34 + w33
+ w50 = lsig512_1 w48 + w43 + lsig512_0 w35 + w34
+ w51 = lsig512_1 w49 + w44 + lsig512_0 w36 + w35
+ w52 = lsig512_1 w50 + w45 + lsig512_0 w37 + w36
+ w53 = lsig512_1 w51 + w46 + lsig512_0 w38 + w37
+ w54 = lsig512_1 w52 + w47 + lsig512_0 w39 + w38
+ w55 = lsig512_1 w53 + w48 + lsig512_0 w40 + w39
+ w56 = lsig512_1 w54 + w49 + lsig512_0 w41 + w40
+ w57 = lsig512_1 w55 + w50 + lsig512_0 w42 + w41
+ w58 = lsig512_1 w56 + w51 + lsig512_0 w43 + w42
+ w59 = lsig512_1 w57 + w52 + lsig512_0 w44 + w43
+ w60 = lsig512_1 w58 + w53 + lsig512_0 w45 + w44
+ w61 = lsig512_1 w59 + w54 + lsig512_0 w46 + w45
+ w62 = lsig512_1 w60 + w55 + lsig512_0 w47 + w46
+ w63 = lsig512_1 w61 + w56 + lsig512_0 w48 + w47
+ w64 = lsig512_1 w62 + w57 + lsig512_0 w49 + w48
+ w65 = lsig512_1 w63 + w58 + lsig512_0 w50 + w49
+ w66 = lsig512_1 w64 + w59 + lsig512_0 w51 + w50
+ w67 = lsig512_1 w65 + w60 + lsig512_0 w52 + w51
+ w68 = lsig512_1 w66 + w61 + lsig512_0 w53 + w52
+ w69 = lsig512_1 w67 + w62 + lsig512_0 w54 + w53
+ w70 = lsig512_1 w68 + w63 + lsig512_0 w55 + w54
+ w71 = lsig512_1 w69 + w64 + lsig512_0 w56 + w55
+ w72 = lsig512_1 w70 + w65 + lsig512_0 w57 + w56
+ w73 = lsig512_1 w71 + w66 + lsig512_0 w58 + w57
+ w74 = lsig512_1 w72 + w67 + lsig512_0 w59 + w58
+ w75 = lsig512_1 w73 + w68 + lsig512_0 w60 + w59
+ w76 = lsig512_1 w74 + w69 + lsig512_0 w61 + w60
+ w77 = lsig512_1 w75 + w70 + lsig512_0 w62 + w61
+ w78 = lsig512_1 w76 + w71 + lsig512_0 w63 + w62
+ w79 = lsig512_1 w77 + w72 + lsig512_0 w64 + w63
+ return $ SHA512Sched w00 w01 w02 w03 w04 w05 w06 w07 w08 w09
+ w10 w11 w12 w13 w14 w15 w16 w17 w18 w19
+ w20 w21 w22 w23 w24 w25 w26 w27 w28 w29
+ w30 w31 w32 w33 w34 w35 w36 w37 w38 w39
+ w40 w41 w42 w43 w44 w45 w46 w47 w48 w49
+ w50 w51 w52 w53 w54 w55 w56 w57 w58 w59
+ w60 w61 w62 w63 w64 w65 w66 w67 w68 w69
+ w70 w71 w72 w73 w74 w75 w76 w77 w78 w79
+
+processSHA512Block :: SHA512State -> Get SHA512State
+processSHA512Block !s00@(SHA512S a00 b00 c00 d00 e00 f00 g00 h00) = do
+ (SHA512Sched w00 w01 w02 w03 w04 w05 w06 w07 w08 w09
+ w10 w11 w12 w13 w14 w15 w16 w17 w18 w19
+ w20 w21 w22 w23 w24 w25 w26 w27 w28 w29
+ w30 w31 w32 w33 w34 w35 w36 w37 w38 w39
+ w40 w41 w42 w43 w44 w45 w46 w47 w48 w49
+ w50 w51 w52 w53 w54 w55 w56 w57 w58 w59
+ w60 w61 w62 w63 w64 w65 w66 w67 w68 w69
+ w70 w71 w72 w73 w74 w75 w76 w77 w78 w79) <- getSHA512Sched
+ let s01 = step512 s00 0x428a2f98d728ae22 w00
+ s02 = step512 s01 0x7137449123ef65cd w01
+ s03 = step512 s02 0xb5c0fbcfec4d3b2f w02
+ s04 = step512 s03 0xe9b5dba58189dbbc w03
+ s05 = step512 s04 0x3956c25bf348b538 w04
+ s06 = step512 s05 0x59f111f1b605d019 w05
+ s07 = step512 s06 0x923f82a4af194f9b w06
+ s08 = step512 s07 0xab1c5ed5da6d8118 w07
+ s09 = step512 s08 0xd807aa98a3030242 w08
+ s10 = step512 s09 0x12835b0145706fbe w09
+ s11 = step512 s10 0x243185be4ee4b28c w10
+ s12 = step512 s11 0x550c7dc3d5ffb4e2 w11
+ s13 = step512 s12 0x72be5d74f27b896f w12
+ s14 = step512 s13 0x80deb1fe3b1696b1 w13
+ s15 = step512 s14 0x9bdc06a725c71235 w14
+ s16 = step512 s15 0xc19bf174cf692694 w15
+ s17 = step512 s16 0xe49b69c19ef14ad2 w16
+ s18 = step512 s17 0xefbe4786384f25e3 w17
+ s19 = step512 s18 0x0fc19dc68b8cd5b5 w18
+ s20 = step512 s19 0x240ca1cc77ac9c65 w19
+ s21 = step512 s20 0x2de92c6f592b0275 w20
+ s22 = step512 s21 0x4a7484aa6ea6e483 w21
+ s23 = step512 s22 0x5cb0a9dcbd41fbd4 w22
+ s24 = step512 s23 0x76f988da831153b5 w23
+ s25 = step512 s24 0x983e5152ee66dfab w24
+ s26 = step512 s25 0xa831c66d2db43210 w25
+ s27 = step512 s26 0xb00327c898fb213f w26
+ s28 = step512 s27 0xbf597fc7beef0ee4 w27
+ s29 = step512 s28 0xc6e00bf33da88fc2 w28
+ s30 = step512 s29 0xd5a79147930aa725 w29
+ s31 = step512 s30 0x06ca6351e003826f w30
+ s32 = step512 s31 0x142929670a0e6e70 w31
+ s33 = step512 s32 0x27b70a8546d22ffc w32
+ s34 = step512 s33 0x2e1b21385c26c926 w33
+ s35 = step512 s34 0x4d2c6dfc5ac42aed w34
+ s36 = step512 s35 0x53380d139d95b3df w35
+ s37 = step512 s36 0x650a73548baf63de w36
+ s38 = step512 s37 0x766a0abb3c77b2a8 w37
+ s39 = step512 s38 0x81c2c92e47edaee6 w38
+ s40 = step512 s39 0x92722c851482353b w39
+ s41 = step512 s40 0xa2bfe8a14cf10364 w40
+ s42 = step512 s41 0xa81a664bbc423001 w41
+ s43 = step512 s42 0xc24b8b70d0f89791 w42
+ s44 = step512 s43 0xc76c51a30654be30 w43
+ s45 = step512 s44 0xd192e819d6ef5218 w44
+ s46 = step512 s45 0xd69906245565a910 w45
+ s47 = step512 s46 0xf40e35855771202a w46
+ s48 = step512 s47 0x106aa07032bbd1b8 w47
+ s49 = step512 s48 0x19a4c116b8d2d0c8 w48
+ s50 = step512 s49 0x1e376c085141ab53 w49
+ s51 = step512 s50 0x2748774cdf8eeb99 w50
+ s52 = step512 s51 0x34b0bcb5e19b48a8 w51
+ s53 = step512 s52 0x391c0cb3c5c95a63 w52
+ s54 = step512 s53 0x4ed8aa4ae3418acb w53
+ s55 = step512 s54 0x5b9cca4f7763e373 w54
+ s56 = step512 s55 0x682e6ff3d6b2b8a3 w55
+ s57 = step512 s56 0x748f82ee5defb2fc w56
+ s58 = step512 s57 0x78a5636f43172f60 w57
+ s59 = step512 s58 0x84c87814a1f0ab72 w58
+ s60 = step512 s59 0x8cc702081a6439ec w59
+ s61 = step512 s60 0x90befffa23631e28 w60
+ s62 = step512 s61 0xa4506cebde82bde9 w61
+ s63 = step512 s62 0xbef9a3f7b2c67915 w62
+ s64 = step512 s63 0xc67178f2e372532b w63
+ s65 = step512 s64 0xca273eceea26619c w64
+ s66 = step512 s65 0xd186b8c721c0c207 w65
+ s67 = step512 s66 0xeada7dd6cde0eb1e w66
+ s68 = step512 s67 0xf57d4f7fee6ed178 w67
+ s69 = step512 s68 0x06f067aa72176fba w68
+ s70 = step512 s69 0x0a637dc5a2c898a6 w69
+ s71 = step512 s70 0x113f9804bef90dae w70
+ s72 = step512 s71 0x1b710b35131c471b w71
+ s73 = step512 s72 0x28db77f523047d84 w72
+ s74 = step512 s73 0x32caab7b40c72493 w73
+ s75 = step512 s74 0x3c9ebe0a15c9bebc w74
+ s76 = step512 s75 0x431d67c49c100d4c w75
+ s77 = step512 s76 0x4cc5d4becb3e42b6 w76
+ s78 = step512 s77 0x597f299cfc657e2a w77
+ s79 = step512 s78 0x5fcb6fab3ad6faec w78
+ s80 = step512 s79 0x6c44198c4a475817 w79
+ SHA512S a80 b80 c80 d80 e80 f80 g80 h80 = s80
+ return $ SHA512S (a00 + a80) (b00 + b80) (c00 + c80) (d00 + d80)
+ (e00 + e80) (f00 + f80) (g00 + g80) (h00 + h80)
+
+{-# INLINE step512 #-}
+step512 :: SHA512State -> Word64 -> Word64 -> SHA512State
+step512 !(SHA512S a b c d e f g h) k w = SHA512S a' b' c' d' e' f' g' h'
+ where
+ t1 = h + bsig512_1 e + ch e f g + k + w
+ t2 = bsig512_0 a + maj a b c
+ h' = g
+ g' = f
+ f' = e
+ e' = d + t1
+ d' = c
+ c' = b
+ b' = a
+ a' = t1 + t2
+
+runSHA :: a -> (a -> Get a) -> ByteString -> a
+runSHA s nextChunk input = runGet (getAll s) input
+ where
+ getAll s_in = do
+ done <- isEmpty
+ if done
+ then return s_in
+ else nextChunk s_in >>= getAll
+
+sha512 :: ByteString -> Digest SHA512State
+sha512 bs_in = Digest bs_out
+ where
+ bs_pad = padSHA512 bs_in
+ fstate = runSHA initialSHA512State processSHA512Block bs_pad
+ bs_out = runPut $ synthesizeSHA512 fstate
+
+sha512_spec_tests :: [(String, String)]
+sha512_spec_tests =
+ [("abc",
+ "ddaf35a193617abacc417349ae20413112e6fa4e89a97ea20a9eeee64b55d39a" ++
+ "2192992a274fc1a836ba3c23a3feebbd454d4423643ce80e2a9ac94fa54ca49f"),
+ ("abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmn" ++
+ "hijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu",
+ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018" ++
+ "501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909"),
+ (replicate 1000000 'a',
+ "e718483d0ce769644e2e42c7bc15b4638e1f98b13b2044285632a803afa973eb" ++
+ "de0ff244877ea60a4cb0432ce577c31beb009c5c2c49aa2e4eadb217ad8cc09b")]
+
+showDigest :: Digest t -> String
+showDigest (Digest bs) = showDigestBS bs
+
+-- |Prints out a bytestring in hexadecimal. Just for convenience.
+showDigestBS :: ByteString -> String
+showDigestBS bs = foldr paddedShowHex [] (BS.unpack bs)
+ where
+ paddedShowHex x xs = intToDigit (fromIntegral (x `shiftR` 4))
+ : intToDigit (fromIntegral (x .&. 0xf))
+ : xs
+
+main :: IO ()
+main = do
+ sequence_
+ [ unless (digest == expected)
+ $ fail $ "failed: " ++ expected ++ " /= " ++ digest
+ | (str, expected) <- sha512_spec_tests
+ , let digest = showDigest (sha512 $ BSC.pack str)
+ ]
=====================================
testsuite/tests/codeGen/should_run/all.T
=====================================
@@ -219,3 +219,4 @@ test('CallConv', [when(unregisterised(), skip),
when(arch('x86_64'), extra_hc_opts('CallConv_x86_64.s')),
when(arch('aarch64'), extra_hc_opts('CallConv_aarch64.s'))],
compile_and_run, [''])
+test('T22798', normal, compile_and_run, ['-fregs-graph'])
=====================================
testsuite/tests/ghci/T16392/T16392.script
=====================================
@@ -1,5 +1,7 @@
:set -fobject-code
+import System.Mem
:load A.hs
c_two caf
+performMajorGC
:load A.hs
c_two caf
=====================================
testsuite/tests/ghci/linking/dyn/Makefile
=====================================
@@ -74,7 +74,7 @@ compile_libAB_dyn:
'$(TEST_HC)' $(MY_TEST_HC_OPTS) -odir "bin_dyn" -shared B.c -o "bin_dyn/$(call DLL,B)" -lA -L"./bin_dyn"
rm -f bin_dyn/*.a
'$(TEST_HC)' $(TEST_HC_OPTS) -ignore-dot-ghci -v0 -o "bin_dyn/$(call EXE,T10955dyn)" -L./bin_dyn -lB -lA T10955dyn.hs -v0
- LD_LIBRARY_PATH=./bin_dyn ./bin_dyn/$(call EXE,T10955dyn)
+ DYLD_LIBRARY_PATH=./bin_dyn LD_LIBRARY_PATH=./bin_dyn ./bin_dyn/$(call EXE,T10955dyn)
.PHONY: compile_libAS_impl_gcc
compile_libAS_impl_gcc:
=====================================
testsuite/tests/rts/T18623/all.T
=====================================
@@ -5,7 +5,10 @@ test('T18623',
# This keeps failing on aarch64-linux for reasons that are not
# fully clear. Maybe it needs a higher limit due to LLMV?
when(arch('aarch64'), skip),
+ # Recent versions of osx report an error when running `ulimit -v`
+ when(opsys('darwin'), skip),
+ when(arch('powerpc64le'), skip),
cmd_prefix('ulimit -v ' + str(1024 ** 2) + ' && '),
ignore_stdout],
run_command,
- ['{compiler} --version'])
\ No newline at end of file
+ ['{compiler} --version'])
=====================================
testsuite/tests/simplCore/should_compile/T22623.hs
=====================================
@@ -0,0 +1,34 @@
+{-# LANGUAGE GHC2021 #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module T22623 where
+
+import T22623a
+
+type BindNonEmptyList :: NonEmpty -> NonEmpty -> [Q]
+type family BindNonEmptyList (x :: NonEmpty) (y :: NonEmpty) :: [Q] where
+ BindNonEmptyList ('(:|) a as) c = Tail c ++ Foldr2 a c as
+
+sBindNonEmptyList ::
+ forall (t :: NonEmpty)
+ (c :: NonEmpty). SNonEmpty t -> SNonEmpty c -> SList (BindNonEmptyList t c :: [Q])
+sBindNonEmptyList
+ ((:%|) (sA :: SQ a) (sAs :: SList as)) (sC :: SNonEmpty c)
+ = let
+ sMyHead :: SNonEmpty c -> SQ (MyHead a c)
+ sMyHead ((:%|) x _) = x
+
+ sFoldr :: forall t. SList t -> SList (Foldr2 a c t)
+ sFoldr SNil = SNil
+ sFoldr (SCons _ sYs) = SCons (sMyHead sC) (sFoldr sYs)
+
+ sF :: Id (SLambda (ConstSym1 c))
+ sF = SLambda (const sC)
+
+ sBs :: SList (Tail c)
+ _ :%| sBs = applySing sF sA
+ in
+ sBs %++ sFoldr sAs
=====================================
testsuite/tests/simplCore/should_compile/T22623a.hs
=====================================
@@ -0,0 +1,60 @@
+{-# LANGUAGE GHC2021 #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+module T22623a where
+
+import Data.Kind
+
+type Id :: Type -> Type
+type family Id x
+type instance Id x = x
+
+data Q
+data SQ (x :: Q)
+
+data NonEmpty where
+ (:|) :: Q -> [Q] -> NonEmpty
+
+type Tail :: NonEmpty -> [Q]
+type family Tail y where
+ Tail ('(:|) _ y) = y
+type MyHead :: Q -> NonEmpty -> Q
+type family MyHead x y where
+ MyHead _ ('(:|) c _) = c
+
+type SList :: [Q] -> Type
+data SList z where
+ SNil :: SList '[]
+ SCons :: SQ x -> SList xs -> SList (x:xs)
+
+type SNonEmpty :: NonEmpty -> Type
+data SNonEmpty z where
+ (:%|) :: SQ x -> SList xs -> SNonEmpty (x :| xs)
+
+data TyFun
+type F = TyFun -> Type
+
+type Apply :: F -> Q -> NonEmpty
+type family Apply f x
+
+type ConstSym1 :: NonEmpty -> F
+data ConstSym1 (x :: NonEmpty) :: F
+type instance Apply (ConstSym1 x) _ = x
+
+type SLambda :: F -> Type
+newtype SLambda (f :: F) =
+ SLambda { applySing :: forall t. SQ t -> SNonEmpty (f `Apply` t) }
+
+type Foldr2 :: Q -> NonEmpty -> [Q] -> [Q]
+type family Foldr2 a c x where
+ Foldr2 _ _ '[] = '[]
+ Foldr2 a c (_:ys) = MyHead a c : Foldr2 a c ys
+
+type (++) :: [Q] -> [Q] -> [Q]
+type family (++) xs ys where
+ (++) '[] ys = ys
+ (++) ('(:) x xs) ys = '(:) x (xs ++ ys)
+
+(%++) :: forall (x :: [Q]) (y :: [Q]). SList x -> SList y -> SList (x ++ y)
+(%++) SNil sYs = sYs
+(%++) (SCons sX sXs) sYs = SCons sX (sXs %++ sYs)
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -367,3 +367,4 @@ test('T20200', normal, compile, [''])
test('T20820', normal, compile, ['-O0'])
test('T22491', normal, compile, ['-O2'])
test('T22662', normal, compile, [''])
+test('T22623', normal, multimod_compile, ['T22623', '-O -v0'])
=====================================
testsuite/tests/stranal/should_compile/T22039.hs
=====================================
@@ -0,0 +1,59 @@
+{-# LANGUAGE ExistentialQuantification #-}
+
+module Bug where
+
+import Control.Exception
+import Data.Typeable
+import Unsafe.Coerce
+
+data Error
+ = Error Int String
+ | forall e . Exception e => SomeError Int e
+ deriving (Typeable)
+
+fromError :: Exception e => Error -> Maybe e
+fromError e@(Error _ _) = cast e
+fromError (SomeError _ e) = cast e
+-- {-# NOINLINE fromError #-}
+
+instance Eq Error where
+ Error i s == Error i' s' = i == i' && s == s'
+ SomeError i e == SomeError i' e' = i == i' && show e == show e'
+ _ == _ = False
+
+instance Show Error where
+ show _ = ""
+
+instance Exception Error
+
+-- newtype
+data
+ UniquenessError = UniquenessError [((String, String), Int)]
+ deriving (Show, Eq)
+
+instance Exception UniquenessError
+
+test :: SomeException -> IO ()
+test e = case fromError =<< fromException e :: Maybe UniquenessError of
+ Just err -> print err
+ _ -> pure ()
+
+--
+-- Smaller reproducer by sgraf
+--
+
+blarg :: (Int,Int) -> Int
+blarg (x,y) = x+y
+{-# NOINLINE blarg #-}
+
+f :: Either Int Int -> Int
+f Left{} = 0
+f e = blarg (unsafeCoerce e)
+
+blurg :: (Int -> Int) -> Int
+blurg f = f 42
+{-# NOINLINE blurg #-}
+
+g :: Either Int Int -> Int
+g Left{} = 0
+g e = blurg (unsafeCoerce e)
=====================================
testsuite/tests/stranal/should_compile/all.T
=====================================
@@ -69,3 +69,4 @@ test('T20663', [ grep_errmsg(r'\$wyeah ::') ], compile, ['-dppr-cols=1000 -ddump
test('T19180', normal, compile, [''])
test('T19849', normal, compile, [''])
+test('T22039', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1f212a7184c36c3149418afa1ac43173911f628b...9c35e76f94d059e6d751ad4585f4913864402d48
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1f212a7184c36c3149418afa1ac43173911f628b...9c35e76f94d059e6d751ad4585f4913864402d48
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/20230202/b08a2a49/attachment-0001.html>
More information about the ghc-commits
mailing list