[Git][ghc/ghc][wip/supersven/riscv-vectors] 3 commits: Cleanup Instr
by Sven Tennie (＠supersven) 12 Jul '25
by Sven Tennie (＠supersven) 12 Jul '25
12 Jul '25
Sven Tennie pushed to branch wip/supersven/riscv-vectors at Glasgow Haskell Compiler / GHC
Commits:
15bfd8bc by Sven Tennie at 2025-07-12T15:20:51+02:00
Cleanup Instr
- - - - -
4320c021 by Sven Tennie at 2025-07-12T16:59:22+02:00
Refactor vector configuration
- - - - -
e1b5fe55 by Sven Tennie at 2025-07-12T17:21:02+02:00
Delete obsolete TODO
- - - - -
2 changed files:
- compiler/GHC/CmmToAsm/RV64/Instr.hs
- compiler/GHC/CmmToAsm/RV64/Ppr.hs
Changes:
=====================================
compiler/GHC/CmmToAsm/RV64/Instr.hs
=====================================
@@ -138,21 +138,6 @@ regUsageOfInstr platform instr = case instr of
usage (regOp op1 ++ regOp op2 ++ regOp op3, regOp op1)
_ -> panic $ "regUsageOfInstr: " ++ instrCon instr
where
- -- filtering the usage is necessary, otherwise the register
- -- allocator will try to allocate pre-defined fixed stg
- -- registers as well, as they show up.
- usage :: ([(Reg, Format)], [(Reg, Format)]) -> RegUsage
- usage (srcRegs, dstRegs) =
- RU
- (map mkFmt $ filter (interesting platform) srcRegs)
- (map mkFmt $ filter (interesting platform) dstRegs)
-
- mkFmt (r, fmt) = RegWithFormat r fmt
-
- regAddr :: AddrMode -> [(Reg, Format)]
- regAddr (AddrRegImm r1 _imm) = [(r1, II64)]
- regAddr (AddrReg r1) = [(r1, II64)]
-
regOp :: Operand -> [(Reg, Format)]
regOp (OpReg fmt r1) = [(r1, fmt)]
regOp (OpAddr a) = regAddr a
@@ -162,10 +147,25 @@ regUsageOfInstr platform instr = case instr of
regTarget (TBlock _bid) = []
regTarget (TReg r1) = [(r1, II64)]
- -- Is this register interesting for the register allocator?
- interesting :: Platform -> (Reg, Format) -> Bool
- interesting _ ((RegVirtual _), _) = True
- interesting platform ((RegReal (RealRegSingle i)), _) = freeReg platform i
+ regAddr :: AddrMode -> [(Reg, Format)]
+ regAddr (AddrRegImm r1 _imm) = [(r1, II64)]
+ regAddr (AddrReg r1) = [(r1, II64)]
+
+ -- filtering the usage is necessary, otherwise the register
+ -- allocator will try to allocate pre-defined fixed stg
+ -- registers as well, as they show up.
+ usage :: ([(Reg, Format)], [(Reg, Format)]) -> RegUsage
+ usage (srcRegs, dstRegs) =
+ RU
+ (map mkFmt $ filter (interesting platform) srcRegs)
+ (map mkFmt $ filter (interesting platform) dstRegs)
+ where
+ mkFmt (r, fmt) = RegWithFormat r fmt
+
+ -- Is this register interesting for the register allocator?
+ interesting :: Platform -> (Reg, Format) -> Bool
+ interesting _ ((RegVirtual _), _) = True
+ interesting platform ((RegReal (RealRegSingle i)), _) = freeReg platform i
-- | Caller-saved registers (according to calling convention)
--
@@ -240,7 +240,7 @@ patchRegsOfInstr instr env = case instr of
VSUB o1 o2 o3 -> VSUB (patchOp o1) (patchOp o2) (patchOp o3)
VMUL o1 o2 o3 -> VMUL (patchOp o1) (patchOp o2) (patchOp o3)
VQUOT mbS o1 o2 o3 -> VQUOT mbS (patchOp o1) (patchOp o2) (patchOp o3)
- VREM s o1 o2 o3 -> VREM s (patchOp o1) (patchOp o2) (patchOp o3)
+ VREM s o1 o2 o3 -> VREM s (patchOp o1) (patchOp o2) (patchOp o3)
VSMIN o1 o2 o3 -> VSMIN (patchOp o1) (patchOp o2) (patchOp o3)
VSMAX o1 o2 o3 -> VSMAX (patchOp o1) (patchOp o2) (patchOp o3)
VUMIN o1 o2 o3 -> VUMIN (patchOp o1) (patchOp o2) (patchOp o3)
@@ -452,7 +452,7 @@ mkRegRegMoveInstr :: Format -> Reg -> Reg -> Instr
mkRegRegMoveInstr fmt src dst = ANN desc instr
where
desc = text "Reg->Reg Move: " <> ppr src <> text " -> " <> ppr dst
- instr = MOV (operandFromReg fmt dst) (operandFromReg fmt src)
+ instr = MOV (OpReg fmt dst) (OpReg fmt src)
-- | Take the source and destination from this (potential) reg -> reg move instruction
--
@@ -678,8 +678,7 @@ data Instr
-- - fmsub : d = - r1 * r2 + r3
-- - fnmadd: d = - r1 * r2 - r3
FMA FMASign Operand Operand Operand Operand
- | -- TODO: Care about the variants (<instr>.x.y) -> sum type
- VMV Operand Operand
+ | VMV Operand Operand
| VID Operand
| VMSEQ Operand Operand Operand
| VMERGE Operand Operand Operand Operand
@@ -816,21 +815,17 @@ data Operand
OpAddr AddrMode
deriving (Eq, Show)
--- TODO: This just wraps a constructor... Inline?
-operandFromReg :: Format -> Reg -> Operand
-operandFromReg = OpReg
-
operandFromRegNo :: Format -> RegNo -> Operand
-operandFromRegNo fmt = operandFromReg fmt . regSingle
+operandFromRegNo fmt = OpReg fmt . regSingle
zero, ra, sp, gp, tp, fp, tmp :: Operand
-zero = operandFromReg II64 zeroReg
-ra = operandFromReg II64 raReg
-sp = operandFromReg II64 spMachReg
+zero = OpReg II64 zeroReg
+ra = OpReg II64 raReg
+sp = OpReg II64 spMachReg
gp = operandFromRegNo II64 3
tp = operandFromRegNo II64 4
fp = operandFromRegNo II64 8
-tmp = operandFromReg II64 tmpReg
+tmp = OpReg II64 tmpReg
x0, x1, x2, x3, x4, x5, x6, x7 :: Operand
x8, x9, x10, x11, x12, x13, x14, x15 :: Operand
@@ -844,13 +839,9 @@ x4 = operandFromRegNo II64 4
x5 = operandFromRegNo II64 x5RegNo
x6 = operandFromRegNo II64 6
x7 = operandFromRegNo II64 x7RegNo
-
x8 = operandFromRegNo II64 8
-
x9 = operandFromRegNo II64 9
-
x10 = operandFromRegNo II64 x10RegNo
-
x11 = operandFromRegNo II64 11
x12 = operandFromRegNo II64 12
x13 = operandFromRegNo II64 13
@@ -885,53 +876,29 @@ d4 = operandFromRegNo FF64 36
d5 = operandFromRegNo FF64 37
d6 = operandFromRegNo FF64 38
d7 = operandFromRegNo FF64 d7RegNo
-
d8 = operandFromRegNo FF64 40
-
d9 = operandFromRegNo FF64 41
-
d10 = operandFromRegNo FF64 d10RegNo
-
d11 = operandFromRegNo FF64 43
-
d12 = operandFromRegNo FF64 44
-
d13 = operandFromRegNo FF64 45
-
d14 = operandFromRegNo FF64 46
-
d15 = operandFromRegNo FF64 47
-
d16 = operandFromRegNo FF64 48
-
d17 = operandFromRegNo FF64 d17RegNo
-
d18 = operandFromRegNo FF64 50
-
d19 = operandFromRegNo FF64 51
-
d20 = operandFromRegNo FF64 52
-
d21 = operandFromRegNo FF64 53
-
d22 = operandFromRegNo FF64 54
-
d23 = operandFromRegNo FF64 55
-
d24 = operandFromRegNo FF64 56
-
d25 = operandFromRegNo FF64 57
-
d26 = operandFromRegNo FF64 58
-
d27 = operandFromRegNo FF64 59
-
d28 = operandFromRegNo FF64 60
-
d29 = operandFromRegNo FF64 61
-
d30 = operandFromRegNo FF64 62
-
d31 = operandFromRegNo FF64 d31RegNo
fitsIn12bitImm :: (Num a, Ord a, Bits a) => a -> Bool
=====================================
compiler/GHC/CmmToAsm/RV64/Ppr.hs
=====================================
@@ -2,6 +2,7 @@
module GHC.CmmToAsm.RV64.Ppr (pprNatCmmDecl, pprInstr) where
+import Data.Maybe
import GHC.Cmm hiding (topInfoTable)
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
@@ -155,7 +156,11 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) =
)
)
where
- instrs' = injectVectorConfig (toOL optInstrs)
+ instrs' :: OrdList Instr
+ instrs'
+ | isJust (ncgVectorMinBits config) = injectVectorConfig (toOL optInstrs)
+ | otherwise = toOL optInstrs
+
-- TODO: Check if we can filter more instructions here.
-- TODO: Shouldn't this be a more general check on a higher level? And, is this still needed?
-- Filter out identity moves. E.g. mov x18, x18 will be dropped.
@@ -168,8 +173,6 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) =
injectVectorConfig instrs = fst $ foldlOL injectVectorConfig' (nilOL, Nothing) instrs
-- TODO: Fuse this with optInstrs
- -- TODO: Check config and only run this when vectors are configured
- -- TODO: Check if vectorMinBits is sufficient for the vector config
injectVectorConfig' :: (OrdList Instr, Maybe Format) -> Instr -> (OrdList Instr, Maybe Format)
injectVectorConfig' (accInstr, configuredVecFmt) currInstr =
let configuredVecFmt' Nothing = Nothing
@@ -217,14 +220,16 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) =
)
configVec :: Format -> Instr
- configVec (VecFormat length fmt) =
- VSETIVLI
- (OpReg II64 zeroReg)
- (fromIntegral length)
- ((formatToWidth . scalarFormatFormat) fmt)
- M1
- TA
- MA
+ configVec vFmt@(VecFormat length fmt)
+ | Just vlen <- (ncgVectorMinBits config),
+ (formatInBytes vFmt) * 8 <= fromIntegral vlen =
+ VSETIVLI
+ (OpReg II64 zeroReg)
+ (fromIntegral length)
+ ((formatToWidth . scalarFormatFormat) fmt)
+ M1
+ TA
+ MA
configVec fmt = pprPanic "Unsupported vector configuration" ((text . show) fmt)
asmLbl = blockLbl blockid
@@ -620,7 +625,6 @@ pprInstr platform instr = case instr of
| isFloatRegOp o1 && isIntRegOp o2 && isDoubleOp o1 -> op2 (text "\tfmv.d.x") o1 o2
| isIntRegOp o1 && isFloatRegOp o2 && isSingleOp o2 -> op2 (text "\tfmv.x.w") o1 o2
| isIntRegOp o1 && isFloatRegOp o2 && isDoubleOp o2 -> op2 (text "\tfmv.x.d") o1 o2
- -- TODO: Why does this NOP (reg1 == reg2) happen?
| isVectorRegOp o1 && isVectorRegOp o2 -> op2 (text "\tvmv.v.v") o1 o2
| (OpImm (ImmInteger i)) <- o2,
fitsIn12bitImm i ->
@@ -833,7 +837,6 @@ pprInstr platform instr = case instr of
VMERGE o1 o2 o3 o4 -> pprPanic "RV64.pprInstr - VMERGE wrong operands." (pprOps platform [o1, o2, o3, o4])
VSLIDEDOWN o1 o2 o3 | allVectorRegOps [o1, o2] && isIntOp o3 -> op3 (text "\tvslidedown.vx") o1 o2 o3
VSLIDEDOWN o1 o2 o3 -> pprPanic "RV64.pprInstr - VSLIDEDOWN wrong operands." (pprOps platform [o1, o2, o3])
- -- TODO: adjust VSETIVLI to contain only format?
VSETIVLI (OpReg fmt dst) len width grouping ta ma ->
line
$ text "\tvsetivli"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2b1096a6b4db4c53085f53cff62572…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2b1096a6b4db4c53085f53cff62572…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/spec_tyfams] 19 commits: compiler: Import AnnotationWrapper from ghc-internal
by Simon Peyton Jones (＠simonpj) 12 Jul '25
by Simon Peyton Jones (＠simonpj) 12 Jul '25
12 Jul '25
Simon Peyton Jones pushed to branch wip/andreask/spec_tyfams at Glasgow Haskell Compiler / GHC
Commits:
67957854 by Ben Gamari at 2025-07-09T09:44:44-04:00
compiler: Import AnnotationWrapper from ghc-internal
Since `GHC.Desugar` exported from `base` has been deprecated.
- - - - -
813d99d6 by Ben Gamari at 2025-07-09T09:44:44-04:00
ghc-compact: Eliminate dependency on ghc-prim
- - - - -
0ec952a1 by Ben Gamari at 2025-07-09T09:44:44-04:00
ghc-heap: Eliminate dependency on ghc-prim
- - - - -
480074c3 by Ben Gamari at 2025-07-09T09:44:44-04:00
ghc-heap: Drop redundant import
- - - - -
03455829 by Ben Gamari at 2025-07-09T09:44:45-04:00
ghc-prim: Bump version to 0.13.1
There are no interface changes from 0.13.0 but the implementation now
lives in `ghc-internal`.
- - - - -
d315345a by Ben Gamari at 2025-07-09T09:44:45-04:00
template-haskell: Bump version number to 2.24.0.0
Bumps exceptions submodule.
- - - - -
004c800e by Ben Gamari at 2025-07-09T09:44:45-04:00
Bump GHC version number to 9.14
- - - - -
eb1a3816 by Ben Gamari at 2025-07-09T09:44:45-04:00
Bump parsec to 3.1.18.0
Bumps parsec submodule.
- - - - -
86f83296 by Ben Gamari at 2025-07-09T09:44:45-04:00
unix: Bump to 2.8.7.0
Bumps unix submodule.
- - - - -
89e13998 by Ben Gamari at 2025-07-09T09:44:45-04:00
binary: Bump to 0.8.9.3
Bumps binary submodule.
- - - - -
55fff191 by Ben Gamari at 2025-07-09T09:44:45-04:00
Win32: Bump to 2.14.2.0
Bumps Win32 submodule.
- - - - -
7dafa40c by Ben Gamari at 2025-07-09T09:44:45-04:00
base: Bump version to 4.22.0
Bumps various submodules.
- - - - -
ef03d8b8 by Rodrigo Mesquita at 2025-07-09T09:45:28-04:00
base: Export displayExceptionWithInfo
This function should be exposed from base following CLC#285
Approved change in CLC#344
Fixes #26058
- - - - -
01d3154e by Wen Kokke at 2025-07-10T17:06:36+01:00
Fix documentation for HEAP_PROF_SAMPLE_STRING
- - - - -
ac259c48 by Wen Kokke at 2025-07-10T17:06:38+01:00
Fix documentation for HEAP_PROF_SAMPLE_COST_CENTRE
- - - - -
2b4db9ba by Pi Delport at 2025-07-11T16:40:52-04:00
(Applicative docs typo: missing "one")
- - - - -
f707bab4 by Andreas Klebinger at 2025-07-12T14:56:16+01:00
Specialise: Improve specialisation by refactoring interestingDict
This MR addresses #26051, which concerns missed type-class specialisation.
The main payload of the MR is to completely refactor the key function
`interestingDict` in GHC.Core.Opt.Specialise
The main change is that we now also look at the structure of the
dictionary we consider specializing on, rather than only the type.
See the big `Note [Interesting dictionary arguments]`
- - - - -
ca7a9d42 by Simon Peyton Jones at 2025-07-12T14:56:16+01:00
Treat tuple dictionaries uniformly; don't unbox them
See `Note [Do not unbox class dictionaries]` in DmdAnal.hs,
sep (DNB1).
This MR reverses the plan in #23398, which suggested a special case to
unbox tuple dictionaries in worker/wrapper. But:
- This was the cause of a pile of complexity in the specialiser (#26158)
- Even with that complexity, specialision was still bad, very bad
See https://gitlab.haskell.org/ghc/ghc/-/issues/19747#note_626297
And it's entirely unnecessary! Specialision works fine without
unboxing tuple dictionaries.
- - - - -
be7296c9 by Andreas Klebinger at 2025-07-12T14:56:16+01:00
Remove complex special case from the type-class specialiser
There was a pretty tricky special case in Specialise which is no
longer necessary.
* Historical Note [Floating dictionaries out of cases]
* #26158
* #19747 https://gitlab.haskell.org/ghc/ghc/-/issues/19747#note_626297
This MR removes it. Hooray.
- - - - -
65 changed files:
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Predicate.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/InertSet.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/ghc.cabal.in
- configure.ac
- docs/users_guide/eventlog-formats.rst
- libraries/Win32
- libraries/array
- libraries/base/base.cabal.in
- libraries/base/src/Control/Exception.hs
- libraries/binary
- libraries/deepseq
- libraries/directory
- libraries/exceptions
- libraries/filepath
- libraries/ghc-boot-th/ghc-boot-th.cabal.in
- libraries/ghc-boot/ghc-boot.cabal.in
- libraries/ghc-compact/GHC/Compact.hs
- libraries/ghc-compact/GHC/Compact/Serialized.hs
- libraries/ghc-compact/ghc-compact.cabal
- libraries/ghc-experimental/ghc-experimental.cabal.in
- libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc
- libraries/ghc-heap/ghc-heap.cabal.in
- libraries/ghc-internal/src/GHC/Internal/Base.hs
- libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs
- libraries/ghc-prim/changelog.md
- libraries/ghc-prim/ghc-prim.cabal
- libraries/ghci/ghci.cabal.in
- libraries/haskeline
- libraries/hpc
- libraries/os-string
- libraries/parsec
- libraries/process
- libraries/semaphore-compat
- libraries/stm
- libraries/template-haskell/template-haskell.cabal.in
- libraries/terminfo
- libraries/text
- libraries/unix
- testsuite/tests/dmdanal/should_compile/T23398.hs
- testsuite/tests/dmdanal/should_compile/T23398.stderr
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- + testsuite/tests/perf/should_run/SpecTyFamRun.hs
- + testsuite/tests/perf/should_run/SpecTyFamRun.stdout
- + testsuite/tests/perf/should_run/SpecTyFam_Import.hs
- testsuite/tests/perf/should_run/all.T
- + testsuite/tests/simplCore/should_compile/T26051.hs
- + testsuite/tests/simplCore/should_compile/T26051.stderr
- + testsuite/tests/simplCore/should_compile/T26051_Import.hs
- testsuite/tests/simplCore/should_compile/all.T
- utils/haddock/haddock-api/haddock-api.cabal
- utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
- utils/haddock/haddock-library/haddock-library.cabal
- utils/haddock/haddock-test/haddock-test.cabal
- utils/haddock/haddock.cabal
- utils/hsc2hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/68e88cfcde40ccfef20b6f8751056d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/68e88cfcde40ccfef20b6f8751056d…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/supersven/riscv-vectors] 15 commits: Formatting
by Sven Tennie (＠supersven) 12 Jul '25
by Sven Tennie (＠supersven) 12 Jul '25
12 Jul '25
Sven Tennie pushed to branch wip/supersven/riscv-vectors at Glasgow Haskell Compiler / GHC
Commits:
3ba1b71a by Sven Tennie at 2025-07-12T10:22:24+02:00
Formatting
- - - - -
1d7e1328 by Sven Tennie at 2025-07-12T12:17:04+02:00
Add haddock
- - - - -
cfce9319 by Sven Tennie at 2025-07-12T12:25:26+02:00
Haddock
- - - - -
ebdf9753 by Sven Tennie at 2025-07-12T12:36:54+02:00
Add calculations to TrivColorable
- - - - -
3b1e5c9b by Sven Tennie at 2025-07-12T12:57:18+02:00
Better allocReg check (check upper boundary for floats)
- - - - -
c0eed9cf by Sven Tennie at 2025-07-12T13:11:19+02:00
point free: floatVecFormat & intVecFormat
- - - - -
fe65c5c0 by Sven Tennie at 2025-07-12T13:12:16+02:00
Delete trailing whitespace
- - - - -
98247b80 by Sven Tennie at 2025-07-12T13:13:44+02:00
Formatting
- - - - -
2331c9b8 by Sven Tennie at 2025-07-12T13:15:12+02:00
Comment t Haddock
- - - - -
60d5833a by Sven Tennie at 2025-07-12T13:25:50+02:00
Cleanup session functions
- - - - -
aa346342 by Sven Tennie at 2025-07-12T13:40:04+02:00
Update comment
- - - - -
e986d733 by Sven Tennie at 2025-07-12T13:45:29+02:00
Formatting / better error message
- - - - -
06d5126d by Sven Tennie at 2025-07-12T14:17:21+02:00
Prepare for more cpu_features
- - - - -
f4e033f9 by Sven Tennie at 2025-07-12T14:21:33+02:00
Improve comment
- - - - -
2b1096a6 by Sven Tennie at 2025-07-12T14:45:47+02:00
cpuinfo.py: Better comments
- - - - -
14 changed files:
- compiler/GHC/CmmToAsm/Format.hs
- compiler/GHC/CmmToAsm/RV64.hs
- compiler/GHC/CmmToAsm/RV64/Regs.hs
- compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs
- compiler/GHC/CmmToAsm/Reg/Linear/RV64.hs
- compiler/GHC/Driver/Config/StgToCmm.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/StgToCmm/Config.hs
- compiler/GHC/StgToCmm/Prim.hs
- m4/fp_riscv_check_gcc_version.m4
- testsuite/driver/cpu_features.py
- testsuite/driver/cpuinfo.py
- testsuite/driver/testlib.py
Changes:
=====================================
compiler/GHC/CmmToAsm/Format.hs
=====================================
@@ -213,10 +213,10 @@ vecFormat ty =
_ -> pprPanic "Incorrect vector element width" (ppr elemTy)
floatVecFormat :: Int -> Width -> Format
-floatVecFormat length width = vecFormat (cmmVec length (cmmFloat width))
+floatVecFormat length = vecFormat . cmmVec length . cmmFloat
intVecFormat :: Int -> Width -> Format
-intVecFormat length width = vecFormat (cmmVec length (cmmBits width))
+intVecFormat length = vecFormat . cmmVec length . cmmBits
-- | Check if a format represents a vector
isVecFormat :: Format -> Bool
=====================================
compiler/GHC/CmmToAsm/RV64.hs
=====================================
@@ -49,7 +49,7 @@ instance Instruction RV64.Instr where
mkLoadInstr = RV64.mkLoadInstr
takeDeltaInstr = RV64.takeDeltaInstr
isMetaInstr = RV64.isMetaInstr
- mkRegRegMoveInstr _ = RV64.mkRegRegMoveInstr
+ mkRegRegMoveInstr _ = RV64.mkRegRegMoveInstr
takeRegRegMoveInstr _ = RV64.takeRegRegMoveInstr
mkJumpInstr = RV64.mkJumpInstr
mkStackAllocInstr = RV64.mkStackAllocInstr
=====================================
compiler/GHC/CmmToAsm/RV64/Regs.hs
=====================================
@@ -123,13 +123,12 @@ tmpReg = regSingle tmpRegNo
v0Reg :: Reg
v0Reg = regSingle v0RegNo
--- | All machine register numbers. Including potential vector registers.
+-- | All machine register numbers, including potential vector registers.
allMachRegNos :: [RegNo]
allMachRegNos = intRegs ++ fpRegs ++ vRegs
where
intRegs = [x0RegNo .. x31RegNo]
fpRegs = [d0RegNo .. d31RegNo]
- -- TODO: If Vector extension is turned off, this should become the empty list
vRegs = [v0RegNo .. v31RegNo]
-- | Registers available to the register allocator.
@@ -138,10 +137,10 @@ allMachRegNos = intRegs ++ fpRegs ++ vRegs
-- sp, gp, tp, fp, tmp) and GHC RTS (Base, Sp, Hp, HpLim, R1..R8, F1..F6,
-- D1..D6.)
--
--- We pretend that vector registers are always available. If they aren't, we
--- simply don't emit instructions using them. This is much simpler than fixing
--- the register allocators which expect a configuration per platform (which we
--- can only set when GHC itself gets build.)
+-- We pretend that vector registers (RVV 1.0) are always available. If they
+-- aren't, we simply don't emit instructions using them. This is much simpler
+-- than fixing the register allocators which expect a configuration per
+-- platform (which we can only set when GHC itself gets built.)
allocatableRegs :: Platform -> [RealReg]
allocatableRegs platform =
let isFree = freeReg platform
@@ -159,6 +158,7 @@ allFpArgRegs = map regSingle [fa0RegNo .. fa7RegNo]
allVecRegs :: [Reg]
allVecRegs = map regSingle [v0RegNo .. v31RegNo]
+-- | Vector argument `Reg`s according to the calling convention
allVecArgRegs :: [Reg]
allVecArgRegs = map regSingle [v8RegNo .. v23RegNo]
=====================================
compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs
=====================================
@@ -144,8 +144,8 @@ allocatableRegs arch rc =
ArchMipsel -> panic "trivColorable ArchMipsel"
ArchS390X -> panic "trivColorable ArchS390X"
ArchRISCV64 -> case rc of
- Separate.RcInteger -> 14 -- TODO: Write the calculation of this magic number down. And, fix the value if needed.
- Separate.RcFloat -> 20 -- TODO: See riscv64.h for TODO.
+ Separate.RcInteger -> 32 - 7 - 11 -- 32 - (zero, lr, sp, gp, tp, fp, tmp) - 11 STG regs
+ Separate.RcFloat -> 32 - 2 * 6 -- 32 - float STG regs - double STG regs | TODO: See riscv64.h for TODO.
Separate.RcVector -> 32 - 6 - 1 -- 32 - pc_MAX_Real_XMM_REG - 1 mask_register
ArchLoongArch64 -> case rc of
Separate.RcInteger -> 16
=====================================
compiler/GHC/CmmToAsm/Reg/Linear/RV64.hs
=====================================
@@ -71,7 +71,6 @@ getFreeRegs cls (FreeRegs g f v) =
case cls of
RcInteger -> go 0 g allocatableIntRegs
RcFloat -> go 32 f allocatableDoubleRegs
- -- TODO: If there's no Vector support, we should return an empty list or panic.
RcVector -> go 64 v allocatableVectorRegs
where
go _ _ [] = []
@@ -90,7 +89,7 @@ getFreeRegs cls (FreeRegs g f v) =
allocateReg :: (HasCallStack) => RealReg -> FreeRegs -> FreeRegs
allocateReg (RealRegSingle r) (FreeRegs g f v)
| r < 32 && testBit g r = FreeRegs (clearBit g r) f v
- | r >= 32 && testBit f (r - 32) = FreeRegs g (clearBit f (r - 32)) v
+ | r >= 32 && r <= 63 && testBit f (r - 32) = FreeRegs g (clearBit f (r - 32)) v
| r >= 64 && testBit v (r - 64) = FreeRegs g f (clearBit v (r - 64))
| otherwise =
pprPanic "Linear.RV64.allocateReg"
=====================================
compiler/GHC/Driver/Config/StgToCmm.hs
=====================================
@@ -88,7 +88,7 @@ initStgToCmmConfig dflags mod = StgToCmmConfig
, stgToCmmAvx = isAvxEnabled dflags
, stgToCmmAvx2 = isAvx2Enabled dflags
, stgToCmmAvx512f = isAvx512fEnabled dflags
- , stgToCmmVectorMinBits = vectorMinBits dflags
+ , stgToCmmVectorMinBits = vectorMinBits dflags
, stgToCmmTickyAP = gopt Opt_Ticky_AP dflags
-- See Note [Saving foreign call target to local]
, stgToCmmSaveFCallTargetToLocal = any (callerSaves platform) $ activeStgRegs platform
=====================================
compiler/GHC/Driver/DynFlags.hs
=====================================
@@ -449,7 +449,7 @@ data DynFlags = DynFlags {
avx512er :: Bool, -- Enable AVX-512 Exponential and Reciprocal Instructions.
avx512f :: Bool, -- Enable AVX-512 instructions.
avx512pf :: Bool, -- Enable AVX-512 PreFetch Instructions.
- vectorMinBits :: Maybe Word, -- Minimal expected vector register width in bits (currently, RISCV-V only)
+ vectorMinBits :: Maybe Word, -- ^ Minimal expected vector register width in bits (currently, RISCV-V only)
fma :: Bool, -- ^ Enable FMA instructions.
-- Constants used to control the amount of optimization done.
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -2864,7 +2864,7 @@ word64Suffix :: (Word64 -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)
word64Suffix fn = Word64Suffix (\n -> upd (fn n))
word64SuffixM :: (Word64 -> DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags)
-word64SuffixM fn = Word64Suffix (\n -> updM (fn n))
+word64SuffixM fn = Word64Suffix (updM . fn)
floatSuffix :: (Float -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)
floatSuffix fn = FloatSuffix (\n -> upd (fn n))
@@ -3850,12 +3850,11 @@ updatePlatformConstants dflags mconstants = do
return dflags1
setVectorMinBits :: Word64 -> DynFlags -> DynP DynFlags
-setVectorMinBits v dflags =
- let validValues = [16,32,64,128,256,512]
- in
+setVectorMinBits v dflags =
+ let validValues = [16, 32, 64, 128, 256, 512]
+ in
if v `elem` validValues then
- pure $ dflags { vectorMinBits = (Just . fromIntegral) v}
+ pure $ dflags { vectorMinBits = (Just . fromIntegral) v}
else do
- addErr ("Minimal vector register size can only be one of" ++ show validValues)
+ addErr ("Minimal vector register size can only be one of: " ++ show validValues)
pure dflags
-
=====================================
compiler/GHC/StgToCmm/Config.hs
=====================================
@@ -76,12 +76,11 @@ data StgToCmmConfig = StgToCmmConfig
, stgToCmmTickyAP :: !Bool -- ^ Disable use of precomputed standard thunks.
, stgToCmmSaveFCallTargetToLocal :: !Bool -- ^ Save a foreign call target to a Cmm local, see
-- Note [Saving foreign call target to local] for details
- -- TODO: Update comment
------------------------------ SIMD flags ------------------------------------
-- Each of these flags checks vector compatibility with the backend requested
- -- during compilation. In essence, this means checking for @-fllvm@ which is
- -- the only backend that currently allows SIMD instructions, see
- -- Ghc.StgToCmm.Prim.checkVecCompatibility for these flags only call site.
+ -- during compilation. Some backends (e.g. the C backend) or architectures
+ -- don't implement SIMD instructions, see
+ -- Ghc.StgToCmm.Prim.checkVecCompatibility for these flags' only call site.
, stgToCmmVecInstrsErr :: Maybe String -- ^ Error (if any) to raise when vector instructions are
-- used, see @StgToCmm.Prim.checkVecCompatibility@
, stgToCmmAvx :: !Bool -- ^ check for Advanced Vector Extensions
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -2637,11 +2637,15 @@ checkVecCompatibility cfg vcat l w =
checkRISCV64 :: Width -> FCode ()
checkRISCV64 w = case stgToCmmVectorMinBits cfg of
- Nothing -> sorry "Vector support has not been configured."
+ Nothing -> sorry "Vector support has not been configured. Check '-mriscv-vlen'."
Just w' | widthInBits w <= fromIntegral w' -> return ()
Just w' ->
sorry
- $ "Vector size is " ++ show w ++ ", but only " ++ show w' ++ " configured."
+ $ "Vector width is "
+ ++ show w
+ ++ ", but only "
+ ++ show w'
+ ++ " configured. Check '-mriscv-vlen'."
vecWidth = typeWidth (vecCmmType vcat l w)
=====================================
m4/fp_riscv_check_gcc_version.m4
=====================================
@@ -18,7 +18,7 @@
AC_DEFUN([FP_RISCV_CHECK_GCC_VERSION], [
AC_REQUIRE([FP_GCC_VERSION])
AC_REQUIRE([AC_CANONICAL_TARGET])
- #
+
# Check if target is RISC-V
case "$target" in
riscv64*-*-*)
=====================================
testsuite/driver/cpu_features.py
=====================================
@@ -14,7 +14,8 @@ SUPPORTED_CPU_FEATURES = {
'popcnt', 'bmi1', 'bmi2',
# riscv:
- 'zvl128b', 'zvl256b', 'zvl512b'
+ 'zvl32b', 'zvl64b', 'zvl128b', 'zvl256b', 'zvl512b',
+ 'zvl1024b'
}
cpu_feature_cache = None
=====================================
testsuite/driver/cpuinfo.py
=====================================
@@ -2126,8 +2126,9 @@ def _get_cpu_info_from_ibm_pa_features():
def _get_cpu_info_from_riscv_isa():
'''
- Returns the CPU info gathered from 'cat /proc/device-tree/cpus/cpu@0/riscv,isa'
- Returns {} if this file does not exist (i.e. we're not on RISC-V Linux)
+ Returns the CPU info gathered from 'cat
+ /proc/device-tree/cpus/cpu@0/riscv,isa' (Linux) and/or tries to figure out
+ vector extensions by running assembly code.
'''
def remove_prefix(prefix, text):
@@ -2165,10 +2166,10 @@ def _get_cpu_info_from_riscv_isa():
flags = output.split('_')
- # The usage of the Zvl* extensions in the industry is very
- # inconsistent. Though, they are useful to communicate the VLEN. So, if
- # they are not provided by the system, we try to figure them out on our
- # own.
+ # The usage of the Zvl* extensions in the industry is very
+ # inconsistent. Though, they are useful to communicate the VLEN. So, if
+ # they are not provided by the system, we try to figure them out on our
+ # own.
# E.g. rv64imafdcvh
arch_string = flags[0]
=====================================
testsuite/driver/testlib.py
=====================================
@@ -424,7 +424,8 @@ def req_fma_cpu( name, opts ):
Require FMA support.
"""
- # RISC-V: Imply float and double extensions, so we only have to change for vectors.
+ # RISC-V: We imply float and double extensions (rv64g), so we only have to
+ # check for vector support.
if not(have_cpu_feature('avx') or have_cpu_feature('zvl128b')):
opts.skip = True
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a40bf1997b45830062c9558c8273f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a40bf1997b45830062c9558c8273f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/supersven/riscv-vectors] 4 commits: Adjust vector check in all.T
by Sven Tennie (＠supersven) 12 Jul '25
by Sven Tennie (＠supersven) 12 Jul '25
12 Jul '25
Sven Tennie pushed to branch wip/supersven/riscv-vectors at Glasgow Haskell Compiler / GHC
Commits:
696d1213 by Sven Tennie at 2025-07-04T18:34:51+02:00
Adjust vector check in all.T
- - - - -
d00766d6 by Sven Tennie at 2025-07-04T19:10:44+02:00
Print vectors to show that the stack is intact
- - - - -
897fd7be by Sven Tennie at 2025-07-05T15:56:24+02:00
Check for GCC >= 14 in autoconf
- - - - -
6a40bf19 by Sven Tennie at 2025-07-05T19:51:24+02:00
VectorCCallConv test: Test doubles as well
- - - - -
8 changed files:
- configure.ac
- distrib/configure.ac.in
- + m4/fp_riscv_check_gcc_version.m4
- testsuite/driver/testlib.py
- testsuite/tests/simd/should_run/VectorCCallConv.hs
- testsuite/tests/simd/should_run/VectorCCallConv.stdout
- testsuite/tests/simd/should_run/VectorCCallConv_c.c
- testsuite/tests/simd/should_run/all.T
Changes:
=====================================
configure.ac
=====================================
@@ -612,9 +612,10 @@ AC_SYS_INTERPRETER()
dnl ** look for GCC and find out which version
dnl Figure out which C compiler to use. Gcc is preferred.
-dnl If gcc, make sure it's at least 4.7
+dnl If gcc, make sure it's at least 4.7 (14 for RISC-V 64bit)
dnl
FP_GCC_VERSION
+FP_RISCV_CHECK_GCC_VERSION
dnl ** Check support for the extra flags passed by GHC when compiling via C
=====================================
distrib/configure.ac.in
=====================================
@@ -225,6 +225,7 @@ dnl ** Check gcc version and flags we need to pass it **
FP_GCC_VERSION
FP_GCC_SUPPORTS_NO_PIE
FP_GCC_SUPPORTS_VIA_C_FLAGS
+FP_RISCV_CHECK_GCC_VERSION
FPTOOLS_SET_C_LD_FLAGS([target],[CFLAGS],[LDFLAGS],[IGNORE_LINKER_LD_FLAGS],[CPPFLAGS])
FPTOOLS_SET_C_LD_FLAGS([build],[CONF_CC_OPTS_STAGE0],[CONF_GCC_LINKER_OPTS_STAGE0],[CONF_LD_LINKER_OPTS_STAGE0],[CONF_CPP_OPTS_STAGE0])
=====================================
m4/fp_riscv_check_gcc_version.m4
=====================================
@@ -0,0 +1,37 @@
+# FP_RISCV_CHECK_GCC_VERSION
+#
+# We cannot use all GCC versions that are generally supported: Up to
+# (including) GCC 13, GCC does not support the expected C calling convention
+# for vectors. Thus, we require at least GCC 14.
+#
+# Details: GCC 13 expects vector arguments to be passed on stack / by
+# reference, though the "Standard Vector Calling Convention Variant"
+# (https://github.com/riscv-non-isa/riscv-elf-psabi-doc/blob/master/riscv-cc.a…)
+# - which is the new default (e.g. for GCC 14) - expects vector arguments in
+# registers v8 to v23. I guess, this is due to the "Standard Vector Calling
+# Convention Variant" being pretty new. And, the GCC implementors had to make
+# up design decissions before this part of the standard has been ratified.
+# As long as the calling convention is consistently used for all code, this
+# isn't an issue. But, we have to be able to call C functions compiled by GCC
+# with code emitted by GHC.
+
+AC_DEFUN([FP_RISCV_CHECK_GCC_VERSION], [
+ AC_REQUIRE([FP_GCC_VERSION])
+ AC_REQUIRE([AC_CANONICAL_TARGET])
+ #
+ # Check if target is RISC-V
+ case "$target" in
+ riscv64*-*-*)
+ AC_MSG_NOTICE([Assert GCC version for RISC-V. Detected version is $GccVersion])
+ if test -n "$GccVersion"; then
+ AC_CACHE_CHECK([risc-v version of gcc], [fp_riscv_check_gcc_version], [
+ FP_COMPARE_VERSIONS([$GccVersion], [-lt], [14.0],
+ [AC_MSG_ERROR([Need at least GCC version 14 for RISC-V])],
+ [AC_MSG_RESULT([good])]
+ )
+ ])
+ fi
+ ;;
+ # Ignore riscv32*-*-* as we don't have a NCG for RISC-V 32bit targets
+ esac
+])
=====================================
testsuite/driver/testlib.py
=====================================
@@ -416,7 +416,7 @@ def req_basic_simd_cpu( name, opts ):
- PowerPC with AltiVec (not currently supported)
"""
- if not (arch('aarch64') or have_cpu_feature('sse2') or have_cpu_feature('zvl128b')):
+ if not (arch('aarch64') or have_cpu_feature('sse2') or have_cpu_feature('zvl128b')):
opts.skip = True
def req_fma_cpu( name, opts ):
=====================================
testsuite/tests/simd/should_run/VectorCCallConv.hs
=====================================
@@ -7,6 +7,7 @@
module Main where
import Data.Int
+import GHC.Float
import GHC.Int
import GHC.Prim
import System.IO
@@ -38,46 +39,151 @@ unpackInt64X2 :: Int64X2# -> (Int64, Int64)
unpackInt64X2 v = case unpackInt64X2# v of
(# x0, x1 #) -> (I64# x0, I64# x1)
+foreign import ccall "printVecs_doublex2_c"
+ printVecs_doublex2# ::
+ DoubleX2# -> -- v8
+ DoubleX2# -> -- v9
+ DoubleX2# -> -- v10
+ DoubleX2# -> -- v11
+ DoubleX2# -> -- v12
+ DoubleX2# -> -- v13
+ DoubleX2# -> -- v14
+ DoubleX2# -> -- v15
+ DoubleX2# -> -- v16
+ DoubleX2# -> -- v17
+ DoubleX2# -> -- v18
+ DoubleX2# -> -- v19
+ DoubleX2# -> -- v20
+ DoubleX2# -> -- v21
+ DoubleX2# -> -- v22
+ DoubleX2# -> -- v23
+ IO ()
+
+foreign import ccall "return_doubleX2"
+ return_doubleX2# :: (# #) -> DoubleX2#
+
+unpackDoubleX2 :: DoubleX2# -> (Double, Double)
+unpackDoubleX2 v = case unpackDoubleX2# v of
+ (# x0, x1 #) -> (D# x0, D# x1)
+
main :: IO ()
main = do
-- Use some negative values to fill more bits and discover possible overlaps.
- let v8 = packInt64X2# (# 0#Int64, -1#Int64 #)
- v9 = packInt64X2# (# -2#Int64, 3#Int64 #)
- v10 = packInt64X2# (# -4#Int64, 5#Int64 #)
- v11 = packInt64X2# (# -6#Int64, 7#Int64 #)
- v12 = packInt64X2# (# -8#Int64, 9#Int64 #)
- v13 = packInt64X2# (# -10#Int64, 11#Int64 #)
- v14 = packInt64X2# (# -12#Int64, 13#Int64 #)
- v15 = packInt64X2# (# -14#Int64, 15#Int64 #)
- v16 = packInt64X2# (# -16#Int64, 17#Int64 #)
- v17 = packInt64X2# (# -18#Int64, 19#Int64 #)
- v18 = packInt64X2# (# -20#Int64, 21#Int64 #)
- v19 = packInt64X2# (# -22#Int64, 23#Int64 #)
- v20 = packInt64X2# (# -24#Int64, 25#Int64 #)
- v21 = packInt64X2# (# -26#Int64, 27#Int64 #)
- v22 = packInt64X2# (# -28#Int64, 29#Int64 #)
- v23 = packInt64X2# (# -30#Int64, 31#Int64 #)
-
- print "Arguments"
+ let int_v8 = packInt64X2# (# 0#Int64, -1#Int64 #)
+ int_v9 = packInt64X2# (# -2#Int64, 3#Int64 #)
+ int_v10 = packInt64X2# (# -4#Int64, 5#Int64 #)
+ int_v11 = packInt64X2# (# -6#Int64, 7#Int64 #)
+ int_v12 = packInt64X2# (# -8#Int64, 9#Int64 #)
+ int_v13 = packInt64X2# (# -10#Int64, 11#Int64 #)
+ int_v14 = packInt64X2# (# -12#Int64, 13#Int64 #)
+ int_v15 = packInt64X2# (# -14#Int64, 15#Int64 #)
+ int_v16 = packInt64X2# (# -16#Int64, 17#Int64 #)
+ int_v17 = packInt64X2# (# -18#Int64, 19#Int64 #)
+ int_v18 = packInt64X2# (# -20#Int64, 21#Int64 #)
+ int_v19 = packInt64X2# (# -22#Int64, 23#Int64 #)
+ int_v20 = packInt64X2# (# -24#Int64, 25#Int64 #)
+ int_v21 = packInt64X2# (# -26#Int64, 27#Int64 #)
+ int_v22 = packInt64X2# (# -28#Int64, 29#Int64 #)
+ int_v23 = packInt64X2# (# -30#Int64, 31#Int64 #)
+
+ double_v8 = packDoubleX2# (# 0.0##, -1.0## #)
+ double_v9 = packDoubleX2# (# -2.0##, 3.0## #)
+ double_v10 = packDoubleX2# (# -4.0##, 5.0## #)
+ double_v11 = packDoubleX2# (# -6.0##, 7.0## #)
+ double_v12 = packDoubleX2# (# -8.0##, 9.0## #)
+ double_v13 = packDoubleX2# (# -10.0##, 11.0## #)
+ double_v14 = packDoubleX2# (# -12.0##, 13.0## #)
+ double_v15 = packDoubleX2# (# -14.0##, 15.0## #)
+ double_v16 = packDoubleX2# (# -16.0##, 17.0## #)
+ double_v17 = packDoubleX2# (# -18.0##, 19.0## #)
+ double_v18 = packDoubleX2# (# -20.0##, 21.0## #)
+ double_v19 = packDoubleX2# (# -22.0##, 23.0## #)
+ double_v20 = packDoubleX2# (# -24.0##, 25.0## #)
+ double_v21 = packDoubleX2# (# -26.0##, 27.0## #)
+ double_v22 = packDoubleX2# (# -28.0##, 29.0## #)
+ double_v23 = packDoubleX2# (# -30.0##, 31.0## #)
+
+ print "Arguments (int)"
hFlush stdout
printVecs_int64x2#
- v8
- v9
- v10
- v11
- v12
- v13
- v14
- v15
- v16
- v17
- v18
- v19
- v20
- v21
- v22
- v23
-
- print "Return values"
+ int_v8
+ int_v9
+ int_v10
+ int_v11
+ int_v12
+ int_v13
+ int_v14
+ int_v15
+ int_v16
+ int_v17
+ int_v18
+ int_v19
+ int_v20
+ int_v21
+ int_v22
+ int_v23
+
+ print "Arguments (double)"
+ hFlush stdout
+ printVecs_doublex2#
+ double_v8
+ double_v9
+ double_v10
+ double_v11
+ double_v12
+ double_v13
+ double_v14
+ double_v15
+ double_v16
+ double_v17
+ double_v18
+ double_v19
+ double_v20
+ double_v21
+ double_v22
+ double_v23
+
+ print "Return values (int)"
let v = return_int64X2# (# #)
print $ unpackInt64X2 v
+
+ print "Return values (double)"
+ let v = return_doubleX2# (# #)
+ print $ unpackDoubleX2 v
+
+ -- Check that these registers weren't messed up
+ print "Initial vectors (int)"
+ print $ unpackInt64X2 int_v8
+ print $ unpackInt64X2 int_v9
+ print $ unpackInt64X2 int_v10
+ print $ unpackInt64X2 int_v11
+ print $ unpackInt64X2 int_v12
+ print $ unpackInt64X2 int_v13
+ print $ unpackInt64X2 int_v14
+ print $ unpackInt64X2 int_v15
+ print $ unpackInt64X2 int_v16
+ print $ unpackInt64X2 int_v17
+ print $ unpackInt64X2 int_v18
+ print $ unpackInt64X2 int_v19
+ print $ unpackInt64X2 int_v20
+ print $ unpackInt64X2 int_v21
+ print $ unpackInt64X2 int_v22
+ print $ unpackInt64X2 int_v23
+
+ print "Initial vectors (double)"
+ print $ unpackDoubleX2 double_v8
+ print $ unpackDoubleX2 double_v9
+ print $ unpackDoubleX2 double_v10
+ print $ unpackDoubleX2 double_v11
+ print $ unpackDoubleX2 double_v12
+ print $ unpackDoubleX2 double_v13
+ print $ unpackDoubleX2 double_v14
+ print $ unpackDoubleX2 double_v15
+ print $ unpackDoubleX2 double_v16
+ print $ unpackDoubleX2 double_v17
+ print $ unpackDoubleX2 double_v18
+ print $ unpackDoubleX2 double_v19
+ print $ unpackDoubleX2 double_v20
+ print $ unpackDoubleX2 double_v21
+ print $ unpackDoubleX2 double_v22
+ print $ unpackDoubleX2 double_v23
=====================================
testsuite/tests/simd/should_run/VectorCCallConv.stdout
=====================================
@@ -1,4 +1,4 @@
-"Arguments"
+"Arguments (int)"
[0, -1]
[-2, 3]
[-4, 5]
@@ -15,5 +15,58 @@
[-26, 27]
[-28, 29]
[-30, 31]
-"Return values"
+"Arguments (double)"
+[0.000000, -1.000000]
+[-2.000000, 3.000000]
+[-4.000000, 5.000000]
+[-6.000000, 7.000000]
+[-8.000000, 9.000000]
+[-10.000000, 11.000000]
+[-12.000000, 13.000000]
+[-14.000000, 15.000000]
+[-16.000000, 17.000000]
+[-18.000000, 19.000000]
+[-20.000000, 21.000000]
+[-22.000000, 23.000000]
+[-24.000000, 25.000000]
+[-26.000000, 27.000000]
+[-28.000000, 29.000000]
+[-30.000000, 31.000000]
+"Return values (int)"
(-9223372036854775808,9223372036854775807)
+"Return values (double)"
+(2.2250738585072014e-308,1.7976931348623157e308)
+"Initial vectors (int)"
+(0,-1)
+(-2,3)
+(-4,5)
+(-6,7)
+(-8,9)
+(-10,11)
+(-12,13)
+(-14,15)
+(-16,17)
+(-18,19)
+(-20,21)
+(-22,23)
+(-24,25)
+(-26,27)
+(-28,29)
+(-30,31)
+"Initial vectors (double)"
+(0.0,-1.0)
+(-2.0,3.0)
+(-4.0,5.0)
+(-6.0,7.0)
+(-8.0,9.0)
+(-10.0,11.0)
+(-12.0,13.0)
+(-14.0,15.0)
+(-16.0,17.0)
+(-18.0,19.0)
+(-20.0,21.0)
+(-22.0,23.0)
+(-24.0,25.0)
+(-26.0,27.0)
+(-28.0,29.0)
+(-30.0,31.0)
=====================================
testsuite/tests/simd/should_run/VectorCCallConv_c.c
=====================================
@@ -1,4 +1,5 @@
#include "riscv_vector.h"
+#include <float.h>
#include <stdio.h>
static void printVec_int64(vint64m1_t v, int length) {
@@ -44,3 +45,47 @@ vint64m1_t return_int64X2() {
int64_t v[] = {INT64_MIN, INT64_MAX};
return __riscv_vle64_v_i64m1(v, 2);
}
+
+static void printVec_double(vfloat64m1_t v, int length) {
+ // Extract and print elements from the vector register
+ double temp[length]; // Temporary array to hold vector elements
+ __riscv_vse64_v_f64m1(temp, v, length); // Store vector to memory
+
+ printf("[%f", temp[0]);
+ for (int i = 1; i < length; i++) {
+ printf(", %f", temp[i]);
+ }
+ printf("]\n");
+ fflush(stdout);
+}
+// Provide many vectors to enforce stack usage
+void printVecs_doublex2_c(vfloat64m1_t v8, vfloat64m1_t v9, vfloat64m1_t v10,
+ vfloat64m1_t v11, vfloat64m1_t v12, vfloat64m1_t v13,
+ vfloat64m1_t v14, vfloat64m1_t v15, vfloat64m1_t v16,
+ vfloat64m1_t v17, vfloat64m1_t v18, vfloat64m1_t v19,
+ vfloat64m1_t v20, vfloat64m1_t v21, vfloat64m1_t v22,
+ vfloat64m1_t v23) {
+ printVec_double(v8, 2);
+ printVec_double(v9, 2);
+ printVec_double(v10, 2);
+ printVec_double(v11, 2);
+ printVec_double(v12, 2);
+ printVec_double(v13, 2);
+ printVec_double(v14, 2);
+ printVec_double(v15, 2);
+ printVec_double(v16, 2);
+ printVec_double(v17, 2);
+ printVec_double(v18, 2);
+ printVec_double(v19, 2);
+ printVec_double(v20, 2);
+ printVec_double(v21, 2);
+ printVec_double(v22, 2);
+ printVec_double(v23, 2);
+
+ fflush(stdout);
+}
+
+vfloat64m1_t return_doubleX2() {
+ double v[] = {DBL_MIN, DBL_MAX};
+ return __riscv_vle64_v_f64m1(v, 2);
+}
=====================================
testsuite/tests/simd/should_run/all.T
=====================================
@@ -26,7 +26,7 @@ def riscvVlen():
elif have_cpu_feature('zvl512b'):
return 512
else:
- raise Exception("Vector extension not supported by CPU or VLEN too small.")
+ return 0
# Ensure we set the CPU features we have available.
#
@@ -35,7 +35,7 @@ def riscvVlen():
# with or without -mavx2.
setTestOpts([
# TODO: -optc and -opta should not be required, but provided by the GHC pipeline
- when(arch('riscv64'), extra_hc_opts('-mriscv-vlen' + str(riscvVlen()) + " -optc=-march=rv64gv -opta=-march=rv64gv"))
+ when(arch('riscv64') and (riscvVlen() > 0), extra_hc_opts('-mriscv-vlen' + str(riscvVlen()) + " -optc=-march=rv64gv -opta=-march=rv64gv"))
])
test('simd_insert_baseline', [], compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/80263d354b4743a66c458587ff8d17…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/80263d354b4743a66c458587ff8d17…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/warning-for-last-and-init] Re CLC issue 292 Warn GHC.Internal.List.{init,last} are partial
by Bodigrim (＠Bodigrim) 12 Jul '25
by Bodigrim (＠Bodigrim) 12 Jul '25
12 Jul '25
Bodigrim pushed to branch wip/warning-for-last-and-init at Glasgow Haskell Compiler / GHC
Commits:
8f16552d by Mike Pilgrem at 2025-07-12T01:04:22+01:00
Re CLC issue 292 Warn GHC.Internal.List.{init,last} are partial
Also corrects the warning for `tail` to refer to `Data.List.uncons` (like the existing warning for `head`).
In module `Settings.Warnings`, applies `-Wno-unrecognised-warning-flags` `-Wno-x-partial` to the `Cabal`, `filepath`, `hsc2hs`, `hpc`, `parsec`, `text` and `time` packages (outside GHC's repository).
- - - - -
17 changed files:
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Driver/Session/Units.hs
- compiler/GHC/Prelude/Basic.hs
- ghc/GHCi/UI.hs
- ghc/Main.hs
- libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
- libraries/ghc-internal/src/GHC/Internal/Float.hs
- libraries/ghc-internal/src/GHC/Internal/List.hs
- libraries/ghc-internal/src/GHC/Internal/System/IO.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
- libraries/template-haskell/vendored-filepath/System/FilePath/Posix.hs
- libraries/template-haskell/vendored-filepath/System/FilePath/Windows.hs
- testsuite/tests/driver/j-space/jspace.hs
- testsuite/tests/rts/KeepCafsBase.hs
- utils/check-exact/Utils.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs
- utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs
Changes:
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -112,8 +112,7 @@ import GHC.Utils.Misc
import Data.ByteString ( ByteString )
import Data.Function ( on )
-import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL )
-import qualified Data.List as Partial ( init, last )
+import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL, unsnoc )
import Data.Ord ( comparing )
import Control.Monad ( guard )
import qualified Data.Set as Set
@@ -1871,10 +1870,10 @@ app_ok fun_ok primop_ok fun args
PrimOpId op _
| primOpIsDiv op
- , Lit divisor <- Partial.last args
+ , Just (initArgs, Lit divisor) <- unsnoc args
-- there can be 2 args (most div primops) or 3 args
-- (WordQuotRem2Op), hence the use of last/init
- -> not (isZeroLit divisor) && all (expr_ok fun_ok primop_ok) (Partial.init args)
+ -> not (isZeroLit divisor) && all (expr_ok fun_ok primop_ok) initArgs
-- Special case for dividing operations that fail
-- In general they are NOT ok-for-speculation
-- (which primop_ok will catch), but they ARE OK
=====================================
compiler/GHC/Driver/Session/Units.hs
=====================================
@@ -183,7 +183,7 @@ checkUnitCycles dflags graph = processSCCs (HUG.hugSCCs graph)
processSCCs [] = return ()
processSCCs (AcyclicSCC _: other_sccs) = processSCCs other_sccs
- processSCCs (CyclicSCC uids: _) = throwGhcException $ CmdLineError $ showSDoc dflags (cycle_err uids)
+ processSCCs (NECyclicSCC uids: _) = throwGhcException $ CmdLineError $ showSDoc dflags (cycle_err uids)
cycle_err uids =
@@ -195,8 +195,8 @@ checkUnitCycles dflags graph = processSCCs (HUG.hugSCCs graph)
(map (\uid -> text "-" <+> ppr uid <+> text "depends on") start)
++ [text "-" <+> ppr final]
where
- start = init uids
- final = last uids
+ start = NE.init uids
+ final = NE.last uids
-- | Check that we don't have multiple units with the same UnitId.
checkDuplicateUnits :: DynFlags -> [(FilePath, DynFlags)] -> Ghc ()
=====================================
compiler/GHC/Prelude/Basic.hs
=====================================
@@ -2,8 +2,8 @@
{-# OPTIONS_HADDOCK not-home #-}
{-# OPTIONS_GHC -O2 #-} -- See Note [-O2 Prelude]
--- See Note [Proxies for head and tail]
-{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-}
+-- See Note [Proxies for partial list functions]
+{-# OPTIONS_GHC -Wno-x-partial #-}
-- | Custom minimal GHC "Prelude"
--
@@ -24,7 +24,7 @@ module GHC.Prelude.Basic
, bit
, shiftL, shiftR
, setBit, clearBit
- , head, tail, unzip
+ , head, tail, init, last, unzip
, strictGenericLength
) where
@@ -59,7 +59,7 @@ NoImplicitPrelude. There are two motivations for this:
-}
import qualified Prelude
-import Prelude as X hiding ((<>), Applicative(..), Foldable(..), head, tail, unzip)
+import Prelude as X hiding ((<>), Applicative(..), Foldable(..), head, tail, init, last, unzip)
import Control.Applicative (Applicative(..))
import Data.Foldable as X (Foldable (elem, foldMap, foldl, foldl', foldr, length, null, product, sum))
import Data.Foldable1 as X hiding (head, last)
@@ -118,24 +118,35 @@ setBit = \ x i -> x Bits..|. bit i
clearBit :: (Num a, Bits.Bits a) => a -> Int -> a
clearBit = \ x i -> x Bits..&. Bits.complement (bit i)
-{- Note [Proxies for head and tail]
+{- Note [Proxies for partial list functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Prelude.head and Prelude.tail have recently acquired {-# WARNING in "x-partial" #-},
+Prelude.head, Prelude.tail, Prelude.init and Prelude.last
+have recently acquired {-# WARNING in "x-partial" #-},
but the GHC codebase uses them fairly extensively and insists on building warning-free.
Thus, instead of adding {-# OPTIONS_GHC -Wno-x-partial #-} to every module which
employs them, we define warning-less proxies and export them from GHC.Prelude.
-}
--- See Note [Proxies for head and tail]
+-- See Note [Proxies for partial list functions]
head :: HasCallStack => [a] -> a
head = Prelude.head
{-# INLINE head #-}
--- See Note [Proxies for head and tail]
+-- See Note [Proxies for partial list functions]
tail :: HasCallStack => [a] -> [a]
tail = Prelude.tail
{-# INLINE tail #-}
+-- See Note [Proxies for partial list functions]
+init :: HasCallStack => [a] -> [a]
+init = Prelude.init
+{-# INLINE init #-}
+
+-- See Note [Proxies for partial list functions]
+last :: HasCallStack => [a] -> a
+last = Prelude.last
+{-# INLINE last #-}
+
{- |
The 'genericLength' function defined in base can't be specialised due to the
NOINLINE pragma.
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -133,7 +133,7 @@ import Data.Char
import Data.Function
import qualified Data.Foldable as Foldable
import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )
-import Data.List ( find, intercalate, intersperse,
+import Data.List ( find, intercalate, intersperse, unsnoc,
isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) )
import qualified Data.List.NonEmpty as NE
import qualified Data.Set as S
@@ -2399,9 +2399,9 @@ setContextAfterLoad keep_ctxt (Just graph) = do
[] ->
let graph' = flattenSCCs $ filterToposortToModules $
GHC.topSortModuleGraph True (GHC.mkModuleGraph loaded_graph) Nothing
- in case graph' of
- [] -> setContextKeepingPackageModules keep_ctxt []
- xs -> load_this (last xs)
+ in case unsnoc graph' of
+ Nothing -> setContextKeepingPackageModules keep_ctxt []
+ Just (_, lst) -> load_this lst
(m:_) ->
load_this m
where
=====================================
ghc/Main.hs
=====================================
@@ -88,7 +88,7 @@ import System.Exit
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except (throwE, runExceptT)
-import Data.List ( isPrefixOf, partition, intercalate )
+import Data.List ( isPrefixOf, partition, intercalate, unsnoc )
import Prelude
import qualified Data.List.NonEmpty as NE
@@ -115,8 +115,7 @@ main = do
argv0 <- getArgs
let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0
- mbMinusB | null minusB_args = Nothing
- | otherwise = Just (drop 2 (last minusB_args))
+ mbMinusB = drop 2 . snd <$> unsnoc minusB_args
let argv2 = map (mkGeneralLocated "on the commandline") argv1
=====================================
libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
=====================================
@@ -13,7 +13,7 @@ import GHC.Boot.TH.PprLib
import GHC.Boot.TH.Syntax
import Data.Word ( Word8 )
import Data.Char ( toLower, chr )
-import Data.List ( intersperse )
+import Data.List ( intersperse, unsnoc )
import GHC.Show ( showMultiLineString )
import GHC.Lexeme( isVarSymChar )
import Data.Ratio ( numerator, denominator )
@@ -214,9 +214,10 @@ pprExp i (MDoE m ss_) = parensIf (i > noPrec) $
pprStms [s] = ppr s
pprStms ss = braces (semiSep ss)
-pprExp _ (CompE []) = text "<<Empty CompExp>>"
-- This will probably break with fixity declarations - would need a ';'
-pprExp _ (CompE ss) =
+pprExp _ (CompE ss) = case unsnoc ss of
+ Nothing -> text "<<Empty CompExp>>"
+ Just (ss', s) ->
if null ss'
-- If there are no statements in a list comprehension besides the last
-- one, we simply treat it like a normal list.
@@ -225,8 +226,6 @@ pprExp _ (CompE ss) =
<+> bar
<+> commaSep ss'
<> text "]"
- where s = last ss
- ss' = init ss
pprExp _ (ArithSeqE d) = ppr d
pprExp _ (ListE es) = brackets (commaSep es)
pprExp i (SigE e t) = parensIf (i > noPrec) $ pprExp sigPrec e
=====================================
libraries/ghc-internal/src/GHC/Internal/Float.hs
=====================================
@@ -13,6 +13,9 @@
{-# OPTIONS_HADDOCK not-home #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+-- For init in formatRealFloatAlt
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : GHC.Internal.Float
=====================================
libraries/ghc-internal/src/GHC/Internal/List.hs
=====================================
@@ -190,12 +190,18 @@ tail :: HasCallStack => [a] -> [a]
tail (_:xs) = xs
tail [] = errorEmptyList "tail"
-{-# WARNING in "x-partial" tail "This is a partial function, it throws an error on empty lists. Replace it with 'drop' 1, or use pattern matching or 'GHC.Internal.Data.List.uncons' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-}
+{-# WARNING in "x-partial" tail "This is a partial function, it throws an error on empty lists. Replace it with 'drop' 1, or use pattern matching or 'Data.List.uncons' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-}
-- | \(\mathcal{O}(n)\). Extract the last element of a list, which must be
-- finite and non-empty.
--
--- WARNING: This function is partial. Consider using 'unsnoc' instead.
+-- To disable the warning about partiality put
+-- @{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-}@
+-- at the top of the file. To disable it throughout a package put the same
+-- options into @ghc-options@ section of Cabal file. To disable it in GHCi
+-- put @:set -Wno-x-partial -Wno-unrecognised-warning-flags@ into @~/.ghci@
+-- config file. See also the
+-- [migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides….
--
-- ==== __Examples__
--
@@ -218,10 +224,18 @@ last xs = foldl (\_ x -> x) lastError xs
lastError :: HasCallStack => a
lastError = errorEmptyList "last"
+{-# WARNING in "x-partial" last "This is a partial function, it throws an error on empty lists. Use 'Data.List.unsnoc' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-}
+
-- | \(\mathcal{O}(n)\). Return all the elements of a list except the last one.
-- The list must be non-empty.
--
--- WARNING: This function is partial. Consider using 'unsnoc' instead.
+-- To disable the warning about partiality put
+-- @{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-}@
+-- at the top of the file. To disable it throughout a package put the same
+-- options into @ghc-options@ section of Cabal file. To disable it in GHCi
+-- put @:set -Wno-x-partial -Wno-unrecognised-warning-flags@ into @~/.ghci@
+-- config file. See also the
+-- [migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides….
--
-- ==== __Examples__
--
@@ -240,6 +254,8 @@ init (x:xs) = init' x xs
where init' _ [] = []
init' y (z:zs) = y : init' z zs
+{-# WARNING in "x-partial" init "This is a partial function, it throws an error on empty lists. Use 'Data.List.unsnoc' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-}
+
-- | \(\mathcal{O}(1)\). Test whether a list is empty.
--
-- >>> null []
=====================================
libraries/ghc-internal/src/GHC/Internal/System/IO.hs
=====================================
@@ -825,11 +825,12 @@ output_flags = std_flags
where
-- XXX bits copied from System.FilePath, since that's not available here
- combine a b
- | null b = a
- | null a = b
- | pathSeparator [last a] = a ++ b
- | otherwise = a ++ [pathSeparatorChar] ++ b
+ combine a [] = a
+ combine a b = case unsnoc a of
+ Nothing -> b
+ Just (_, lastA)
+ | pathSeparator [lastA] -> a ++ b
+ | otherwise -> a ++ [pathSeparatorChar] ++ b
tempCounter :: IORef Int
tempCounter = unsafePerformIO $ newIORef 0
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
=====================================
@@ -54,6 +54,7 @@ import GHC.Internal.Base hiding (NonEmpty(..),Type, Module, sequence)
import GHC.Internal.Data.Data hiding (Fixity(..))
import GHC.Internal.Data.NonEmpty (NonEmpty(..))
import GHC.Internal.Data.Traversable
+import GHC.Internal.List (unsnoc)
import GHC.Internal.Word
import GHC.Internal.Generics (Generic)
import GHC.Internal.IORef
@@ -73,7 +74,7 @@ import GHC.Internal.Control.Monad.Fix
import GHC.Internal.Control.Exception
import GHC.Internal.Num
import GHC.Internal.IO.Unsafe
-import GHC.Internal.List (dropWhile, break, replicate, reverse, last)
+import GHC.Internal.List (dropWhile, break, replicate, reverse)
import GHC.Internal.MVar
import GHC.Internal.IO.Exception
import GHC.Internal.Unicode
@@ -82,6 +83,16 @@ import qualified GHC.Internal.Types as Kind (Type)
import GHC.Internal.ForeignSrcLang
import GHC.Internal.LanguageExtensions
+#ifdef BOOTSTRAP_TH
+#if MIN_VERSION_base(4,19,0)
+import Data.List (unsnoc)
+#else
+import Data.Maybe (maybe)
+unsnoc :: [a] -> Maybe ([a], a)
+unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing
+#endif
+#endif
+
-----------------------------------------------------
--
-- The Quasi class
@@ -1296,7 +1307,7 @@ mkName str
-- (i.e. non-empty, starts with capital, all alpha)
is_rev_mod_name rev_mod_str
| (compt, rest) <- break (== '.') rev_mod_str
- , not (null compt), isUpper (last compt), all is_mod_char compt
+ , Just (_, lastCompt) <- unsnoc compt, isUpper lastCompt, all is_mod_char compt
= case rest of
[] -> True
(_dot : rest') -> is_rev_mod_name rest'
=====================================
libraries/template-haskell/vendored-filepath/System/FilePath/Posix.hs
=====================================
@@ -104,7 +104,7 @@ module System.FilePath.Posix
import Data.Char(toLower, toUpper, isAsciiLower, isAsciiUpper)
import Data.Maybe(isJust)
-import Data.List(stripPrefix, isSuffixOf)
+import Data.List(stripPrefix, isSuffixOf, uncons, unsnoc)
import System.Environment(getEnv)
@@ -203,14 +203,20 @@ isExtSeparator = (== extSeparator)
splitSearchPath :: String -> [FilePath]
splitSearchPath = f
where
- f xs = case break isSearchPathSeparator xs of
- (pre, [] ) -> g pre
- (pre, _:post) -> g pre ++ f post
-
- g "" = ["." | isPosix]
- g ('\"':x@(_:_)) | isWindows && last x == '\"' = [init x]
- g x = [x]
-
+ f xs = let (pre, post) = break isSearchPathSeparator xs
+ in case uncons post of
+ Nothing -> g pre
+ Just (_, t) -> g pre ++ f t
+
+ g x = case uncons x of
+ Nothing -> ["." | isPosix]
+ Just (h, t)
+ | h == '"'
+ , Just{} <- uncons t -- >= 2
+ , isWindows
+ , Just (i, l) <- unsnoc t
+ , l == '"' -> [i]
+ | otherwise -> [x]
-- | Get a list of 'FilePath's in the $PATH variable.
getSearchPath :: IO [FilePath]
@@ -233,12 +239,17 @@ getSearchPath = fmap splitSearchPath (getEnv "PATH")
-- > splitExtension "file/path.txt.bob.fred" == ("file/path.txt.bob",".fred")
-- > splitExtension "file/path.txt/" == ("file/path.txt/","")
splitExtension :: FilePath -> (String, String)
-splitExtension x = case nameDot of
- "" -> (x,"")
- _ -> (dir ++ init nameDot, extSeparator : ext)
- where
- (dir,file) = splitFileName_ x
- (nameDot,ext) = breakEnd isExtSeparator file
+splitExtension x = case unsnoc nameDot of
+ -- Imagine x = "no-dots", then nameDot = ""
+ Nothing -> (x, mempty)
+ Just (initNameDot, _)
+ -- Imagine x = "\\shared.with.dots\no-dots"
+ | isWindows && null (dropDrive nameDot) -> (x, mempty)
+ -- Imagine x = "dir.with.dots/no-dots"
+ | any isPathSeparator ext -> (x, mempty)
+ | otherwise -> (initNameDot, extSeparator : ext)
+ where
+ (nameDot, ext) = breakEnd isExtSeparator x
-- | Get the extension of a file, returns @\"\"@ for no extension, @.ext@ otherwise.
--
@@ -594,9 +605,13 @@ replaceBaseName pth nam = combineAlways a (nam <.> ext)
-- > hasTrailingPathSeparator "test" == False
-- > hasTrailingPathSeparator "test/" == True
hasTrailingPathSeparator :: FilePath -> Bool
-hasTrailingPathSeparator "" = False
-hasTrailingPathSeparator x = isPathSeparator (last x)
+hasTrailingPathSeparator = isJust . getTrailingPathSeparator
+getTrailingPathSeparator :: FilePath -> Maybe Char
+getTrailingPathSeparator x = case unsnoc x of
+ Just (_, lastX)
+ | isPathSeparator lastX -> Just lastX
+ _ -> Nothing
hasLeadingPathSeparator :: FilePath -> Bool
hasLeadingPathSeparator "" = False
@@ -619,12 +634,12 @@ addTrailingPathSeparator x = if hasTrailingPathSeparator x then x else x ++ [pat
-- > Windows: dropTrailingPathSeparator "\\" == "\\"
-- > Posix: not (hasTrailingPathSeparator (dropTrailingPathSeparator x)) || isDrive x
dropTrailingPathSeparator :: FilePath -> FilePath
-dropTrailingPathSeparator x =
- if hasTrailingPathSeparator x && not (isDrive x)
- then let x' = dropWhileEnd isPathSeparator x
- in if null x' then [last x] else x'
- else x
-
+dropTrailingPathSeparator x = case getTrailingPathSeparator x of
+ Just lastX
+ | not (isDrive x)
+ -> let x' = dropWhileEnd isPathSeparator x
+ in if null x' then [lastX] else x'
+ _ -> x
-- | Get the directory name, move up one level.
--
@@ -863,28 +878,37 @@ makeRelative root path
-- > Posix: normalise "bob/fred/." == "bob/fred/"
-- > Posix: normalise "//home" == "/home"
normalise :: FilePath -> FilePath
-normalise path = result ++ [pathSeparator | addPathSeparator]
- where
- (drv,pth) = splitDrive path
- result = joinDrive' (normaliseDrive drv) (f pth)
+normalise filepath =
+ result <>
+ (if addPathSeparator
+ then [pathSeparator]
+ else mempty)
+ where
+ (drv,pth) = splitDrive filepath
+
+ result = joinDrive' (normaliseDrive drv) (f pth)
- joinDrive' "" "" = "."
- joinDrive' d p = joinDrive d p
+ joinDrive' d p
+ = if null d && null p
+ then "."
+ else joinDrive d p
- addPathSeparator = isDirPath pth
- && not (hasTrailingPathSeparator result)
- && not (isRelativeDrive drv)
+ addPathSeparator = isDirPath pth
+ && not (hasTrailingPathSeparator result)
+ && not (isRelativeDrive drv)
- isDirPath xs = hasTrailingPathSeparator xs
- || not (null xs) && last xs == '.' && hasTrailingPathSeparator (init xs)
+ isDirPath xs = hasTrailingPathSeparator xs || case unsnoc xs of
+ Nothing -> False
+ Just (initXs, lastXs) -> lastXs == '.' && hasTrailingPathSeparator initXs
- f = joinPath . dropDots . propSep . splitDirectories
+ f = joinPath . dropDots . propSep . splitDirectories
- propSep (x:xs) | all isPathSeparator x = [pathSeparator] : xs
- | otherwise = x : xs
- propSep [] = []
+ propSep (x:xs)
+ | all isPathSeparator x = [pathSeparator] : xs
+ | otherwise = x : xs
+ propSep [] = []
- dropDots = filter ("." /=)
+ dropDots = filter ("." /=)
normaliseDrive :: FilePath -> FilePath
normaliseDrive "" = ""
=====================================
libraries/template-haskell/vendored-filepath/System/FilePath/Windows.hs
=====================================
@@ -104,7 +104,7 @@ module System.FilePath.Windows
import Data.Char(toLower, toUpper, isAsciiLower, isAsciiUpper)
import Data.Maybe(isJust)
-import Data.List(stripPrefix, isSuffixOf)
+import Data.List(stripPrefix, isSuffixOf, uncons, unsnoc)
import System.Environment(getEnv)
@@ -203,14 +203,20 @@ isExtSeparator = (== extSeparator)
splitSearchPath :: String -> [FilePath]
splitSearchPath = f
where
- f xs = case break isSearchPathSeparator xs of
- (pre, [] ) -> g pre
- (pre, _:post) -> g pre ++ f post
-
- g "" = ["." | isPosix]
- g ('\"':x@(_:_)) | isWindows && last x == '\"' = [init x]
- g x = [x]
-
+ f xs = let (pre, post) = break isSearchPathSeparator xs
+ in case uncons post of
+ Nothing -> g pre
+ Just (_, t) -> g pre ++ f t
+
+ g x = case uncons x of
+ Nothing -> ["." | isPosix]
+ Just (h, t)
+ | h == '"'
+ , Just{} <- uncons t -- >= 2
+ , isWindows
+ , Just (i, l) <- unsnoc t
+ , l == '"' -> [i]
+ | otherwise -> [x]
-- | Get a list of 'FilePath's in the $PATH variable.
getSearchPath :: IO [FilePath]
@@ -233,12 +239,17 @@ getSearchPath = fmap splitSearchPath (getEnv "PATH")
-- > splitExtension "file/path.txt.bob.fred" == ("file/path.txt.bob",".fred")
-- > splitExtension "file/path.txt/" == ("file/path.txt/","")
splitExtension :: FilePath -> (String, String)
-splitExtension x = case nameDot of
- "" -> (x,"")
- _ -> (dir ++ init nameDot, extSeparator : ext)
- where
- (dir,file) = splitFileName_ x
- (nameDot,ext) = breakEnd isExtSeparator file
+splitExtension x = case unsnoc nameDot of
+ -- Imagine x = "no-dots", then nameDot = ""
+ Nothing -> (x, mempty)
+ Just (initNameDot, _)
+ -- Imagine x = "\\shared.with.dots\no-dots"
+ | isWindows && null (dropDrive nameDot) -> (x, mempty)
+ -- Imagine x = "dir.with.dots/no-dots"
+ | any isPathSeparator ext -> (x, mempty)
+ | otherwise -> (initNameDot, extSeparator : ext)
+ where
+ (nameDot, ext) = breakEnd isExtSeparator x
-- | Get the extension of a file, returns @\"\"@ for no extension, @.ext@ otherwise.
--
@@ -594,9 +605,13 @@ replaceBaseName pth nam = combineAlways a (nam <.> ext)
-- > hasTrailingPathSeparator "test" == False
-- > hasTrailingPathSeparator "test/" == True
hasTrailingPathSeparator :: FilePath -> Bool
-hasTrailingPathSeparator "" = False
-hasTrailingPathSeparator x = isPathSeparator (last x)
+hasTrailingPathSeparator = isJust . getTrailingPathSeparator
+getTrailingPathSeparator :: FilePath -> Maybe Char
+getTrailingPathSeparator x = case unsnoc x of
+ Just (_, lastX)
+ | isPathSeparator lastX -> Just lastX
+ _ -> Nothing
hasLeadingPathSeparator :: FilePath -> Bool
hasLeadingPathSeparator "" = False
@@ -619,12 +634,12 @@ addTrailingPathSeparator x = if hasTrailingPathSeparator x then x else x ++ [pat
-- > Windows: dropTrailingPathSeparator "\\" == "\\"
-- > Posix: not (hasTrailingPathSeparator (dropTrailingPathSeparator x)) || isDrive x
dropTrailingPathSeparator :: FilePath -> FilePath
-dropTrailingPathSeparator x =
- if hasTrailingPathSeparator x && not (isDrive x)
- then let x' = dropWhileEnd isPathSeparator x
- in if null x' then [last x] else x'
- else x
-
+dropTrailingPathSeparator x = case getTrailingPathSeparator x of
+ Just lastX
+ | not (isDrive x)
+ -> let x' = dropWhileEnd isPathSeparator x
+ in if null x' then [lastX] else x'
+ _ -> x
-- | Get the directory name, move up one level.
--
@@ -863,28 +878,37 @@ makeRelative root path
-- > Posix: normalise "bob/fred/." == "bob/fred/"
-- > Posix: normalise "//home" == "/home"
normalise :: FilePath -> FilePath
-normalise path = result ++ [pathSeparator | addPathSeparator]
- where
- (drv,pth) = splitDrive path
- result = joinDrive' (normaliseDrive drv) (f pth)
+normalise filepath =
+ result <>
+ (if addPathSeparator
+ then [pathSeparator]
+ else mempty)
+ where
+ (drv,pth) = splitDrive filepath
+
+ result = joinDrive' (normaliseDrive drv) (f pth)
- joinDrive' "" "" = "."
- joinDrive' d p = joinDrive d p
+ joinDrive' d p
+ = if null d && null p
+ then "."
+ else joinDrive d p
- addPathSeparator = isDirPath pth
- && not (hasTrailingPathSeparator result)
- && not (isRelativeDrive drv)
+ addPathSeparator = isDirPath pth
+ && not (hasTrailingPathSeparator result)
+ && not (isRelativeDrive drv)
- isDirPath xs = hasTrailingPathSeparator xs
- || not (null xs) && last xs == '.' && hasTrailingPathSeparator (init xs)
+ isDirPath xs = hasTrailingPathSeparator xs || case unsnoc xs of
+ Nothing -> False
+ Just (initXs, lastXs) -> lastXs == '.' && hasTrailingPathSeparator initXs
- f = joinPath . dropDots . propSep . splitDirectories
+ f = joinPath . dropDots . propSep . splitDirectories
- propSep (x:xs) | all isPathSeparator x = [pathSeparator] : xs
- | otherwise = x : xs
- propSep [] = []
+ propSep (x:xs)
+ | all isPathSeparator x = [pathSeparator] : xs
+ | otherwise = x : xs
+ propSep [] = []
- dropDots = filter ("." /=)
+ dropDots = filter ("." /=)
normaliseDrive :: FilePath -> FilePath
normaliseDrive "" = ""
=====================================
testsuite/tests/driver/j-space/jspace.hs
=====================================
@@ -7,7 +7,7 @@ import System.Environment
import GHC.Driver.Env.Types
import GHC.Profiling
import System.Mem
-import Data.List (isPrefixOf)
+import Data.List (isPrefixOf, unsnoc)
import Control.Monad
import System.Exit
import GHC.Platform
@@ -41,7 +41,9 @@ initGhcM xs = do
requestHeapCensus
performGC
[ys] <- filter (isPrefixOf (ghcUnitId <> ":GHC.Unit.Module.ModDetails.ModDetails")) . lines <$> readFile "jspace.hp"
- let (n :: Int) = read (last (words ys))
+ let (n :: Int) = case unsnoc (words ys) of
+ Nothing -> error "input is unexpectedly empty"
+ Just (_, lst) -> read lst
-- The output should be 50 * 8 * word_size (i.e. 3600, or 1600 on 32-bit architectures):
-- the test contains DEPTH + WIDTH + 2 = 50 modules J, H_0, .., H_DEPTH, W_1, .., W_WIDTH,
-- and each ModDetails contains 1 (info table) + 8 word-sized fields.
=====================================
testsuite/tests/rts/KeepCafsBase.hs
=====================================
@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
module KeepCafsBase (x) where
x :: Int
=====================================
utils/check-exact/Utils.hs
=====================================
@@ -37,7 +37,7 @@ import GHC.Base (NonEmpty(..))
import GHC.Parser.Lexer (allocateComments)
import Data.Data hiding ( Fixity )
-import Data.List (sortBy, partition)
+import Data.List (sortBy, partition, unsnoc)
import qualified Data.Map.Strict as Map
import Debug.Trace
@@ -734,8 +734,9 @@ ghead info [] = error $ "ghead "++info++" []"
ghead _info (h:_) = h
glast :: String -> [a] -> a
-glast info [] = error $ "glast " ++ info ++ " []"
-glast _info h = last h
+glast info xs = case unsnoc xs of
+ Nothing -> error $ "glast " ++ info ++ " []"
+ Just (_, lst) -> lst
gtail :: String -> [a] -> [a]
gtail info [] = error $ "gtail " ++ info ++ " []"
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs
=====================================
@@ -755,7 +755,7 @@ ppHtmlIndex
divAlphabet
<< unordList
( map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $
- [ [c] | c <- initialChars, any ((== c) . toUpper . head . fst) index
+ [ [c] | c <- initialChars, any (maybe False ((== c) . toUpper . fst) . List.uncons . fst) index
]
++ [merged_name]
)
@@ -772,7 +772,7 @@ ppHtmlIndex
writeUtf8File (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html)
where
html = indexPage True (Just c) index_part
- index_part = [(n, stuff) | (n, stuff) <- this_ix, toUpper (head n) == c]
+ index_part = [(n, stuff) | (n@(headN : _), stuff) <- this_ix, toUpper headN == c]
index :: [(String, Map GHC.Name [(Module, Bool)])]
index = sortBy cmp (Map.toAscList full_index)
=====================================
utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs
=====================================
@@ -30,7 +30,7 @@ import Control.Arrow (first)
import Control.Monad
import Data.Char (chr, isAlpha, isSpace, isUpper)
import Data.Functor (($>))
-import Data.List (elemIndex, intercalate, intersperse, unfoldr)
+import Data.List (elemIndex, intercalate, intersperse, unfoldr, unsnoc)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Monoid
import qualified Data.Set as Set
@@ -870,10 +870,10 @@ codeblock =
DocCodeBlock . parseParagraph . dropSpaces
<$> ("@" *> skipHorizontalSpace *> "\n" *> block' <* "@")
where
- dropSpaces xs =
- case splitByNl xs of
- [] -> xs
- ys -> case T.uncons (last ys) of
+ dropSpaces xs = let ys = splitByNl xs in
+ case unsnoc ys of
+ Nothing -> xs
+ Just (_, lastYs) -> case T.uncons lastYs of
Just (' ', _) -> case mapM dropSpace ys of
Nothing -> xs
Just zs -> T.intercalate "\n" zs
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8f16552d7617e1f41b5da85b8d2ed2a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8f16552d7617e1f41b5da85b8d2ed2a…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
11 Jul '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
2b4db9ba by Pi Delport at 2025-07-11T16:40:52-04:00
(Applicative docs typo: missing "one")
- - - - -
1 changed file:
- libraries/ghc-internal/src/GHC/Internal/Base.hs
Changes:
=====================================
libraries/ghc-internal/src/GHC/Internal/Base.hs
=====================================
@@ -1047,7 +1047,7 @@ class Functor f where
-- * sequence computations and combine their results ('<*>' and 'liftA2').
--
-- A minimal complete definition must include implementations of 'pure'
--- and of either '<*>' or 'liftA2'. If it defines both, then they must behave
+-- and one of either '<*>' or 'liftA2'. If it defines both, then they must behave
-- the same as their default definitions:
--
-- @('<*>') = 'liftA2' 'id'@
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2b4db9bacf4a54552179154d067efc5…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2b4db9bacf4a54552179154d067efc5…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] 2 commits: Fix documentation for HEAP_PROF_SAMPLE_STRING
by Marge Bot (＠marge-bot) 11 Jul '25
by Marge Bot (＠marge-bot) 11 Jul '25
11 Jul '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
01d3154e by Wen Kokke at 2025-07-10T17:06:36+01:00
Fix documentation for HEAP_PROF_SAMPLE_STRING
- - - - -
ac259c48 by Wen Kokke at 2025-07-10T17:06:38+01:00
Fix documentation for HEAP_PROF_SAMPLE_COST_CENTRE
- - - - -
1 changed file:
- docs/users_guide/eventlog-formats.rst
Changes:
=====================================
docs/users_guide/eventlog-formats.rst
=====================================
@@ -779,9 +779,9 @@ the total time spent profiling.
Cost-centre break-down
^^^^^^^^^^^^^^^^^^^^^^
-A variable-length packet encoding a heap profile sample broken down by,
- * cost-centre (:rts-flag:`-hc`)
-
+A variable-length packet encoding a heap profile sample.
+This event is only emitted when the heap profile type is set to :rts-flag:`-hc` or :rts-flag:`-hb`.
+Otherwise, a :event-type:`HEAP_PROF_SAMPLE_STRING` event is emitted instead.
.. event-type:: HEAP_PROF_SAMPLE_COST_CENTRE
@@ -796,11 +796,19 @@ A variable-length packet encoding a heap profile sample broken down by,
String break-down
^^^^^^^^^^^^^^^^^
-A variable-length event encoding a heap sample broken down by,
+A variable-length event encoding a heap sample.
+The content of the sample label varies depending on the heap profile type:
+
+ * :rts-flag:`-hT` The sample label contains a closure type, e.g., ``"ghc-bignum:GHC.Num.Integer.IS"``.
+ * :rts-flag:`-hm` The sample label contains a module name, e.g., ``"GHC.Num.Integer"``.
+ * :rts-flag:`-hd` The sample label contains a closure description, e.g., ``"IS"``.
+ * :rts-flag:`-hy` The sample label contains a type description, e.g., ``"Integer"``.
+ * :rts-flag:`-he` The sample label contains a stringified era, e.g., ``"1"``.
+ * :rts-flag:`-hr` The sample label contains a retainer set description, e.g., ``"(184)$stoIntegralSized1"``.
+ * :rts-flag:`-hi` The sample label contains a stringified pointer, e.g., ``"0x1008b7588"``,
+ which can be matched to an info table description emitted by the :event-type:`IPE` event.
- * type description (:rts-flag:`-hy`)
- * closure description (:rts-flag:`-hd`)
- * module (:rts-flag:`-hm`)
+If the heap profile type is set to :rts-flag:`-hc` or :rts-flag:`-hb`, a :event-type:`HEAP_PROF_SAMPLE_COST_CENTRE` event is emitted instead.
.. event-type:: HEAP_PROF_SAMPLE_STRING
@@ -808,7 +816,7 @@ A variable-length event encoding a heap sample broken down by,
:length: variable
:field Word8: profile ID
:field Word64: heap residency in bytes
- :field String: type or closure description, or module name
+ :field String: sample label
.. _time-profiler-events:
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ef03d8b8851a1cace5f792fe5a91b6…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ef03d8b8851a1cace5f792fe5a91b6…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
11 Jul '25
Rodrigo Mesquita pushed to branch wip/romes/24212 at Glasgow Haskell Compiler / GHC
Commits:
d585fb63 by Rodrigo Mesquita at 2025-07-11T19:54:15+01:00
Fix windows failure
- - - - -
1 changed file:
- testsuite/tests/ghc-api/T20757.hs
Changes:
=====================================
testsuite/tests/ghc-api/T20757.hs
=====================================
@@ -3,4 +3,4 @@ module Main where
import GHC.SysTools.BaseDir
main :: IO ()
-main = findToolDir False "/" >>= print
+main = findToolDir "/" >>= print
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d585fb63786fb4aec7bb900855e80ad…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d585fb63786fb4aec7bb900855e80ad…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
11 Jul '25
Rodrigo Mesquita pushed to branch wip/romes/24212 at Glasgow Haskell Compiler / GHC
Commits:
f8f86d99 by Rodrigo Mesquita at 2025-07-11T19:49:40+01:00
.gitkeep that
- - - - -
1 changed file:
- + testsuite/tests/ghc-api/settings-escape/ghc-install-folder/lib with spaces/targets/.gitkeep
Changes:
=====================================
testsuite/tests/ghc-api/settings-escape/ghc-install-folder/lib with spaces/targets/.gitkeep
=====================================
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f8f86d9954e9d41d0518bc90457e92c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f8f86d9954e9d41d0518bc90457e92c…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
11 Jul '25
Rodrigo Mesquita pushed to branch wip/romes/step-out-11 at Glasgow Haskell Compiler / GHC
Commits:
ef667857 by Rodrigo Mesquita at 2025-07-11T19:46:30+01:00
Working on it
- - - - -
7 changed files:
- compiler/GHC/ByteCode/Breakpoints.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Runtime/Debugger/Breakpoints.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/StgToByteCode.hs
- ghc/GHCi/UI.hs
Changes:
=====================================
compiler/GHC/ByteCode/Breakpoints.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE DerivingStrategies #-}
-- | Breakpoint information constructed during ByteCode generation.
--
@@ -15,6 +16,7 @@ module GHC.ByteCode.Breakpoints
-- ** Internal breakpoint identifier
, InternalBreakpointId(..), BreakInfoIndex
+ , InternalBreakLoc(..)
-- * Operations
@@ -23,7 +25,7 @@ module GHC.ByteCode.Breakpoints
-- ** Source-level information operations
, getBreakLoc, getBreakVars, getBreakDecls, getBreakCCS
- , getBreakSourceId
+ , getBreakSourceId, getBreakSourceMod
-- * Utils
, seqInternalModBreaks
@@ -165,7 +167,7 @@ data CgBreakInfo
{ cgb_tyvars :: ![IfaceTvBndr] -- ^ Type variables in scope at the breakpoint
, cgb_vars :: ![Maybe (IfaceIdBndr, Word)]
, cgb_resty :: !IfaceType
- , cgb_tick_id :: !BreakpointId
+ , cgb_tick_id :: !(Either InternalBreakLoc BreakpointId)
-- ^ This field records the original breakpoint tick identifier for this
-- internal breakpoint info. It is used to convert a breakpoint
-- *occurrence* index ('InternalBreakpointId') into a *definition* index
@@ -173,9 +175,19 @@ data CgBreakInfo
--
-- The modules of breakpoint occurrence and breakpoint definition are not
-- necessarily the same: See Note [Breakpoint identifiers].
+ --
+ -- If there is no original tick identifier (that is, the breakpoint was
+ -- created during code generation), instead refer directly to the SrcSpan
+ -- we want to use for it. See Note [Internal Breakpoint Locations]
}
-- See Note [Syncing breakpoint info] in GHC.Runtime.Eval
+-- | Breakpoints created during code generation don't have a source-level tick
+-- location. Instead, we come up with one ourselves.
+-- See Note [Internal Breakpoint Locations]
+newtype InternalBreakLoc = InternalBreakLoc SrcSpan
+ deriving newtype (Eq, Show, NFData, Outputable)
+
-- | Get an internal breakpoint info by 'InternalBreakpointId'
getInternalBreak :: InternalBreakpointId -> InternalModBreaks -> CgBreakInfo
getInternalBreak (InternalBreakpointId mod ix) imbs =
@@ -196,27 +208,36 @@ assert_modules_match ibi_mod imbs_mod =
-- | Get the source module and tick index for this breakpoint
-- (as opposed to the module where this breakpoint occurs, which is in 'InternalBreakpointId')
-getBreakSourceId :: InternalBreakpointId -> InternalModBreaks -> BreakpointId
+getBreakSourceId :: InternalBreakpointId -> InternalModBreaks -> Either InternalBreakLoc BreakpointId
getBreakSourceId (InternalBreakpointId ibi_mod ibi_ix) imbs =
assert_modules_match ibi_mod (imodBreaks_module imbs) $
let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix
in cgb_tick_id cgb
+-- | Get the source module for this breakpoint (where the breakpoint is defined)
+getBreakSourceMod :: InternalBreakpointId -> InternalModBreaks -> Module
+getBreakSourceMod (InternalBreakpointId ibi_mod ibi_ix) imbs =
+ assert_modules_match ibi_mod (imodBreaks_module imbs) $
+ let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix
+ in case cgb_tick_id cgb of
+ Left InternalBreakLoc{} -> imodBreaks_module imbs
+ Right BreakpointId{bi_tick_mod} -> bi_tick_mod
+
-- | Get the source span for this breakpoint
getBreakLoc :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO SrcSpan
-getBreakLoc = getBreakXXX modBreaks_locs
+getBreakLoc = getBreakXXX modBreaks_locs (\(InternalBreakLoc x) -> x)
-- | Get the vars for this breakpoint
getBreakVars :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [OccName]
-getBreakVars = getBreakXXX modBreaks_vars
+getBreakVars = getBreakXXX modBreaks_vars (const [])
-- | Get the decls for this breakpoint
getBreakDecls :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [String]
-getBreakDecls = getBreakXXX modBreaks_decls
+getBreakDecls = getBreakXXX modBreaks_decls (const [])
-- | Get the decls for this breakpoint
-getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO (String, String)
-getBreakCCS = getBreakXXX modBreaks_ccs
+getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO (Maybe (String, String))
+getBreakCCS = getBreakXXX (fmap Just . modBreaks_ccs) (const Nothing)
-- | Internal utility to access a ModBreaks field at a particular breakpoint index
--
@@ -228,14 +249,17 @@ getBreakCCS = getBreakXXX modBreaks_ccs
-- 'ModBreaks'. When the tick module is different, we need to look up the
-- 'ModBreaks' in the HUG for that other module.
--
+-- When there is no tick module (the breakpoint was generated at codegen), use
+-- the function on internal mod breaks.
+--
-- To avoid cyclic dependencies, we instead receive a function that looks up
-- the 'ModBreaks' given a 'Module'
-getBreakXXX :: (ModBreaks -> Array BreakTickIndex a) -> (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO a
-getBreakXXX view lookupModule (InternalBreakpointId ibi_mod ibi_ix) imbs =
+getBreakXXX :: (ModBreaks -> Array BreakTickIndex a) -> (InternalBreakLoc -> a) -> (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO a
+getBreakXXX view viewInternal lookupModule (InternalBreakpointId ibi_mod ibi_ix) imbs =
assert_modules_match ibi_mod (imodBreaks_module imbs) $ do
let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix
case cgb_tick_id cgb of
- BreakpointId{bi_tick_mod, bi_tick_index}
+ Right BreakpointId{bi_tick_mod, bi_tick_index}
| bi_tick_mod == ibi_mod
-> do
let these_mbs = imodBreaks_modBreaks imbs
@@ -244,6 +268,8 @@ getBreakXXX view lookupModule (InternalBreakpointId ibi_mod ibi_ix) imbs =
-> do
other_mbs <- lookupModule bi_tick_mod
return $ view other_mbs ! bi_tick_index
+ Left l ->
+ return $ viewInternal l
--------------------------------------------------------------------------------
-- Instances
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -50,8 +50,6 @@ import GHC.Prelude
import GHC.StgToCmm.Types
-import GHC.ByteCode.Types
-
import GHC.Core
import GHC.Core.TyCon hiding ( pprPromotionQuote )
import GHC.Core.Coercion.Axiom
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -58,6 +58,7 @@ import GHCi.RemoteTypes
import GHC.Iface.Load
import GHCi.Message (ConInfoTable(..), LoadedDLL)
+import GHC.ByteCode.Breakpoints
import GHC.ByteCode.Linker
import GHC.ByteCode.Asm
import GHC.ByteCode.Types
@@ -1711,8 +1712,10 @@ allocateCCS interp ce mbss
let count = 1 + (maybe 0 fst $ IM.lookupMax imodBreaks_breakInfo)
let ccs = IM.map
(\info ->
- fromMaybe (toRemotePtr nullPtr)
- (M.lookup (cgb_tick_id info) ccss)
+ case cgb_tick_id info of
+ Right bi -> fromMaybe (toRemotePtr nullPtr)
+ (M.lookup bi ccss)
+ Left InternalBreakLoc{} -> toRemotePtr nullPtr
)
imodBreaks_breakInfo
assertPpr (count == length ccs)
=====================================
compiler/GHC/Runtime/Debugger/Breakpoints.hs
=====================================
@@ -253,8 +253,11 @@ mkBreakpointOccurrences = do
let imod = modBreaks_module $ imodBreaks_modBreaks ibrks
IntMap.foldrWithKey (\info_ix cgi bmp -> do
let ibi = InternalBreakpointId imod info_ix
- let BreakpointId tick_mod tick_ix = cgb_tick_id cgi
- extendModuleEnvWith (IntMap.unionWith (S.<>)) bmp tick_mod (IntMap.singleton tick_ix [ibi])
+ case cgb_tick_id cgi of
+ Right (BreakpointId tick_mod tick_ix)
+ -> extendModuleEnvWith (IntMap.unionWith (S.<>)) bmp tick_mod (IntMap.singleton tick_ix [ibi])
+ Left _
+ -> bmp
) bmp0 (imodBreaks_breakInfo ibrks)
--------------------------------------------------------------------------------
@@ -287,7 +290,7 @@ getCurrentBreakModule = do
Nothing -> pure Nothing
Just ibi -> do
brks <- readIModBreaks hug ibi
- return $ Just $ bi_tick_mod $ getBreakSourceId ibi brks
+ return $ Just $ getBreakSourceMod ibi brks
ix ->
Just <$> getHistoryModule hug (resumeHistory r !! (ix-1))
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -151,7 +151,7 @@ getHistoryModule :: HUG.HomeUnitGraph -> History -> IO Module
getHistoryModule hug hist = do
let ibi = historyBreakpointId hist
brks <- readIModBreaks hug ibi
- return $ bi_tick_mod $ getBreakSourceId ibi brks
+ return $ getBreakSourceMod ibi brks
getHistorySpan :: HUG.HomeUnitGraph -> History -> IO SrcSpan
getHistorySpan hug hist = do
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -63,7 +63,7 @@ import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRepU,
assertNonVoidIds, assertNonVoidStgArgs )
import GHC.StgToCmm.Layout
import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)
-import GHC.Runtime.Interpreter ( interpreterProfiled )
+import GHC.Runtime.Interpreter ( interpreterProfiled, readIModModBreaks )
import GHC.Data.Bitmap
import GHC.Data.FlatBag as FlatBag
import GHC.Data.OrdList
@@ -99,6 +99,7 @@ import GHC.CoreToIface
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader (ReaderT(..))
import Control.Monad.Trans.State (StateT(..))
+import Data.Array ((!))
-- -----------------------------------------------------------------------------
-- Generating byte code for a complete module
@@ -393,26 +394,30 @@ schemeR_wrk fvs nm original_body (args, body)
-- | Introduce break instructions for ticked expressions.
-- If no breakpoint information is available, the instruction is omitted.
schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList
-schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_id fvs) rhs) = do
- code <- schemeE d 0 p rhs
- mb_current_mod_breaks <- getCurrentModBreaks
- case mb_current_mod_breaks of
- -- if we're not generating ModBreaks for this module for some reason, we
- -- can't store breakpoint occurrence information.
- Nothing -> pure code
- Just current_mod_breaks -> do
- platform <- profilePlatform <$> getProfile
- let idOffSets = getVarOffSets platform d p fvs
- ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
- toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)
- toWord = fmap (\(i, wo) -> (i, fromIntegral wo))
- breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty tick_id
-
- let info_mod = modBreaks_module current_mod_breaks
- infox <- newBreakInfo breakInfo
+schemeER_wrk d p (StgTick bp@(Breakpoint tick_ty tick_id fvs) rhs) = do
+ platform <- profilePlatform <$> getProfile
+
+ -- When we find a tick surrounding a case expression we introduce a new BRK_FUN
+ -- instruction at the start of the case *continuation*, in addition to the
+ -- usual BRK_FUN surrounding the StgCase)
+ -- See Note [TODO]
+ code <- case rhs of
+ StgCase scrut bndr _ alts
+ -> doCase d 0 p (Just bp) scrut bndr alts
+ _ -> schemeE d 0 p rhs
+
+ let idOffSets = getVarOffSets platform d p fvs
+ ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
+ toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)
+ toWord = fmap (\(i, wo) -> (i, fromIntegral wo))
+ breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty (Right tick_id)
+
+ mibi <- newBreakInfo breakInfo
+
+ return $ case mibi of
+ Nothing -> code
+ Just ibi -> BRK_FUN ibi `consOL` code
- let breakInstr = BRK_FUN (InternalBreakpointId info_mod infox)
- return $ breakInstr `consOL` code
schemeER_wrk d p rhs = schemeE d 0 p rhs
getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, WordOff)]
@@ -614,7 +619,7 @@ schemeE d s p (StgTick _ rhs) = schemeE d s p rhs
schemeE d s p (StgCase scrut _ _ []) = schemeE d s p scrut
schemeE d s p (StgCase scrut bndr _ alts)
- = doCase d s p scrut bndr alts
+ = doCase d s p Nothing scrut bndr alts
{-
@@ -1106,11 +1111,15 @@ doCase
:: StackDepth
-> Sequel
-> BCEnv
+ -> Maybe StgTickish
+ -- ^ The breakpoint surrounding the full case expression, if any (only
+ -- source-level cases get breakpoint ticks, and those are the only we care
+ -- about). See Note [TODO]
-> CgStgExpr
-> Id
-> [CgStgAlt]
-> BcM BCInstrList
-doCase d s p scrut bndr alts
+doCase d s p m_bid scrut bndr alts
= do
profile <- getProfile
hsc_env <- getHscEnv
@@ -1327,11 +1336,28 @@ doCase d s p scrut bndr alts
let alt_final1
| ubx_tuple_frame = SLIDE 0 2 `consOL` alt_final0
| otherwise = alt_final0
- alt_final
- | gopt Opt_InsertBreakpoints (hsc_dflags hsc_env)
- -- See Note [Debugger: BRK_ALTS]
- = BRK_ALTS False `consOL` alt_final1
- | otherwise = alt_final1
+
+ alt_final <- case m_bid of
+ Just (Breakpoint tick_ty tick_id fvs)
+ | gopt Opt_InsertBreakpoints (hsc_dflags hsc_env)
+ -- Construct an internal breakpoint to put at the start of this case
+ -- continuation BCO.
+ -- See Note [TODO]
+ -> do
+ internal_tick_loc <- makeCaseInternalBreakLoc tick_id
+
+ -- same fvs available in the case expression are available in the case continuation
+ let idOffSets = getVarOffSets platform d p fvs
+ ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
+ toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)
+ toWord = fmap (\(i, wo) -> (i, fromIntegral wo))
+ breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty (Left internal_tick_loc)
+
+ mibi <- newBreakInfo breakInfo
+ return $ case mibi of
+ Nothing -> alt_final1
+ Just ibi -> BRK_FUN ibi `consOL` alt_final1
+ _ -> pure alt_final1
add_bco_name <- shouldAddBcoName
let
@@ -1351,6 +1377,24 @@ doCase d s p scrut bndr alts
_ -> panic "schemeE(StgCase).push_alts"
in return (PUSH_ALTS alt_bco scrut_rep `consOL` scrut_code)
+makeCaseInternalBreakLoc :: BreakpointId -> BcM InternalBreakLoc
+makeCaseInternalBreakLoc bid = do
+ hug <- hsc_HUG <$> getHscEnv
+ curr_mod <- getCurrentModule
+ mb_mod_brks <- getCurrentModBreaks
+
+ -- TODO: Subtract the scrutinee loc from the case loc to get continuation loc
+ InternalBreakLoc <$> case bid of
+ BreakpointId{bi_tick_mod, bi_tick_index}
+ | bi_tick_mod == curr_mod
+ , Just these_mbs <- mb_mod_brks
+ -> do
+ return $ modBreaks_locs these_mbs ! bi_tick_index
+ | otherwise
+ -> do
+ other_mbs <- liftIO $ readIModModBreaks hug bi_tick_mod
+ return $ modBreaks_locs other_mbs ! bi_tick_index
+
{-
Note [Debugger: BRK_ALTS]
~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2667,14 +2711,19 @@ getLabelsBc n = BcM $ \_ st ->
let ctr = nextlabel st
in return (coerce [ctr .. ctr+n-1], st{nextlabel = ctr+n})
-newBreakInfo :: CgBreakInfo -> BcM Int
-newBreakInfo info = BcM $ \_ st ->
- let ix = breakInfoIdx st
- st' = st
- { breakInfo = IntMap.insert ix info (breakInfo st)
- , breakInfoIdx = ix + 1
- }
- in return (ix, st')
+newBreakInfo :: CgBreakInfo -> BcM (Maybe InternalBreakpointId)
+newBreakInfo info = BcM $ \env st -> do
+ -- if we're not generating ModBreaks for this module for some reason, we
+ -- can't store breakpoint occurrence information.
+ case modBreaks env of
+ Nothing -> pure (Nothing, st)
+ Just modBreaks -> do
+ let ix = breakInfoIdx st
+ st' = st
+ { breakInfo = IntMap.insert ix info (breakInfo st)
+ , breakInfoIdx = ix + 1
+ }
+ return (Just $ InternalBreakpointId (modBreaks_module modBreaks) ix, st')
getCurrentModule :: BcM Module
getCurrentModule = BcM $ \env st -> return (bcm_module env, st)
@@ -2687,7 +2736,7 @@ tickFS = fsLit "ticked"
-- Dehydrating CgBreakInfo
-dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word)] -> Type -> BreakpointId -> CgBreakInfo
+dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word)] -> Type -> Either InternalBreakLoc BreakpointId -> CgBreakInfo
dehydrateCgBreakInfo ty_vars idOffSets tick_ty bid =
CgBreakInfo
{ cgb_tyvars = map toIfaceTvBndr ty_vars
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -45,7 +45,7 @@ import GHC.Runtime.Eval (mkTopLevEnv)
import GHC.Runtime.Eval.Utils
-- The GHC interface
-import GHC.ByteCode.Breakpoints (imodBreaks_modBreaks, InternalBreakpointId(..), getBreakSourceId)
+import GHC.ByteCode.Breakpoints (imodBreaks_modBreaks, InternalBreakpointId(..), getBreakSourceId, getBreakSourceMod)
import GHC.Runtime.Interpreter
import GHCi.RemoteTypes
import GHCi.BreakArray( breakOn, breakOff )
@@ -1621,7 +1621,7 @@ toBreakIdAndLocation (Just inf) = do
brks <- liftIO $ readIModBreaks hug inf
let bi = getBreakSourceId inf brks
return $ listToMaybe [ id_loc | id_loc@(_,loc) <- IntMap.assocs (breaks st),
- breakId loc == bi ]
+ Right (breakId loc) == bi ]
printStoppedAtBreakInfo :: GHC.GhcMonad m => Resume -> [Name] -> m ()
printStoppedAtBreakInfo res names = do
@@ -3825,7 +3825,7 @@ pprStopped res = do
hug <- hsc_HUG <$> GHC.getSession
brks <- liftIO $ readIModBreaks hug ibi
return $ Just $ moduleName $
- bi_tick_mod $ getBreakSourceId ibi brks
+ getBreakSourceMod ibi brks
return $
text "Stopped in"
<+> ((case mb_mod_name of
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ef66785749d8714122e529ac148bea7…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ef66785749d8714122e529ac148bea7…
You're receiving this email because of your account on gitlab.haskell.org.
1
0