[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: Update Match Datatype
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Jul 28 17:46:38 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
a5319358 by David Knothe at 2023-07-28T13:13:10-04:00
Update Match Datatype
EquationInfo currently contains a list of the equation's patterns together with a CoreExpr that is to be evaluated after a successful match on this equation.
All the match-functions only operate on the first pattern of an equation - after successfully matching it, match is called recursively on the tail of the pattern list.
We can express this more clearly and make the code a little more elegant by updating the datatype of EquationInfo as follows:
data EquationInfo
= EqnMatch { eqn_pat = Pat GhcTc, eqn_rest = EquationInfo }
| EqnDone { eqn_rhs = MatchResult CoreExpr }
An EquationInfo now explicitly exposes its first pattern which most functions operate on, and exposes the equation that remains after processing the first pattern. An EqnDone signifies an empty equation where the CoreExpr can now be evaluated.
- - - - -
86ad1af9 by David Binder at 2023-07-28T13:13:53-04:00
Improve documentation for Data.Fixed
- - - - -
f8fa1d08 by Ben Gamari at 2023-07-28T13:14:31-04:00
ghc-prim: Use C11 atomics
Previously `ghc-prim`'s atomic wrappers used the legacy `__sync_*`
family of C builtins. Here we refactor these to rather use the
appropriate C11 atomic equivalents, allowing us to be more explicit
about the expected ordering semantics.
- - - - -
bc040950 by Finley McIlwaine at 2023-07-28T13:46:05-04:00
Include -haddock in DynFlags fingerprint
The -haddock flag determines whether or not the resulting .hi files
contain haddock documentation strings. If the existing .hi files do
not contain haddock documentation strings and the user requests them,
we should recompile.
- - - - -
8f30aa3f by Andreas Klebinger at 2023-07-28T13:46:06-04:00
Aarch64 NCG: Use encoded immediates for literals.
Try to generate
instr x2, <imm>
instead of
mov x1, lit
instr x2, x1
When possible. This get's rid if quite a few redundant
mov instructions.
I believe this causes a metric decrease for LargeRecords as
we reduce register pressure.
-------------------------
Metric Decrease:
LargeRecord
-------------------------
- - - - -
01a6254e by Bodigrim at 2023-07-28T13:46:11-04:00
Bump filepath submodule to 1.4.100.4
Resolves #23741
Metric Decrease:
MultiComponentModules
MultiComponentModulesRecomp
MultiLayerModules
MultiLayerModulesRecomp
T10421
T12234
T12425
T13035
T13701
T13719
T16875
T18304
T18698a
T18698b
T21839c
T9198
TcPlugin_RewritePerf
hard_hole_fits
Metric decrease on Windows can be probably attributed to https://github.com/haskell/filepath/pull/183
- - - - -
7eceeb0c by Bodigrim at 2023-07-28T13:46:13-04:00
Add since pragmas to GHC.IO.Handle.FD
- - - - -
15 changed files:
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/CmmToAsm/AArch64/Instr.hs
- compiler/GHC/CmmToAsm/AArch64/Ppr.hs
- compiler/GHC/CmmToAsm/AArch64/Regs.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Match/Constructor.hs
- compiler/GHC/HsToCore/Match/Literal.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/Utils.hs
- libraries/base/Data/Fixed.hs
- libraries/base/GHC/IO/Handle/FD.hs
- libraries/filepath
- libraries/ghc-prim/cbits/atomic.c
Changes:
=====================================
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
=====================================
@@ -372,6 +372,97 @@ getSomeReg expr = do
Fixed rep reg code ->
return (reg, rep, code)
+{- Note [Aarch64 immediates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Aarch64 with it's fixed width instruction encoding uses leftover space for
+immediates.
+If you want the full rundown consult the arch reference document:
+"Arm® Architecture Reference Manual" - "C3.4 Data processing - immediate"
+
+The gist of it is that different instructions allow for different immediate encodings.
+The ones we care about for better code generation are:
+
+* Simple but potentially repeated bit-patterns for logic instructions.
+* 16bit numbers shifted by multiples of 16.
+* 12 bit numbers optionally shifted by 12 bits.
+
+It might seem like the ISA allows for 64bit immediates but this isn't the case.
+Rather there are some instruction aliases which allow for large unencoded immediates
+which will then be transalted to one of the immediate encodings implicitly.
+
+For example mov x1, #0x10000 is allowed but will be assembled to movz x1, #0x1, lsl #16
+-}
+
+-- | Move (wide immediate)
+-- Allows for 16bit immediate which can be shifted by 0/16/32/48 bits.
+-- Used with MOVZ,MOVN, MOVK
+-- See Note [Aarch64 immediates]
+getMovWideImm :: Integer -> Width -> Maybe Operand
+getMovWideImm n w
+ -- TODO: Handle sign extension/negatives
+ | n <= 0
+ = Nothing
+ -- Fits in 16 bits
+ | sized_n < 2^(16 :: Int)
+ = Just $ OpImm (ImmInteger truncated)
+
+ -- 0x0000 0000 xxxx 0000
+ | trailing_zeros >= 16 && sized_n < 2^(32 :: Int)
+ = Just $ OpImmShift (ImmInteger $ truncated `shiftR` 16) SLSL 16
+
+ -- 0x 0000 xxxx 0000 0000
+ | trailing_zeros >= 32 && sized_n < 2^(48 :: Int)
+ = Just $ OpImmShift (ImmInteger $ truncated `shiftR` 32) SLSL 32
+
+ -- 0x xxxx 0000 0000 0000
+ | trailing_zeros >= 48
+ = Just $ OpImmShift (ImmInteger $ truncated `shiftR` 48) SLSL 48
+
+ | otherwise
+ = Nothing
+ where
+ truncated = narrowU w n
+ sized_n = fromIntegral truncated :: Word64
+ trailing_zeros = countTrailingZeros sized_n
+
+-- | Arithmetic(immediate)
+-- Allows for 12bit immediates which can be shifted by 0 or 12 bits.
+-- Used with ADD, ADDS, SUB, SUBS, CMP, CMN
+-- See Note [Aarch64 immediates]
+getArithImm :: Integer -> Width -> Maybe Operand
+getArithImm n w
+ -- TODO: Handle sign extension
+ | n <= 0
+ = Nothing
+ -- Fits in 16 bits
+ -- Fits in 12 bits
+ | sized_n < 2^(12::Int)
+ = Just $ OpImm (ImmInteger truncated)
+
+ -- 12 bits shifted by 12 places.
+ | trailing_zeros >= 12 && sized_n < 2^(24::Int)
+ = Just $ OpImmShift (ImmInteger $ truncated `shiftR` 12) SLSL 12
+
+ | otherwise
+ = Nothing
+ where
+ sized_n = fromIntegral truncated :: Word64
+ truncated = narrowU w n
+ trailing_zeros = countTrailingZeros sized_n
+
+-- | Logical (immediate)
+-- Allows encoding of some repeated bitpatterns
+-- Used with AND, ANDS, EOR, ORR, TST
+-- and their aliases which includes at least MOV (bitmask immediate)
+-- See Note [Aarch64 immediates]
+getBitmaskImm :: Integer -> Width -> Maybe Operand
+getBitmaskImm n w
+ | isAArch64Bitmask truncated = Just $ OpImm (ImmInteger truncated)
+ | otherwise = Nothing
+ where
+ truncated = narrowU w n
+
+
-- TODO OPT: we might be able give getRegister
-- a hint, what kind of register we want.
getFloatReg :: HasCallStack => CmmExpr -> NatM (Reg, Format, InstrBlock)
@@ -494,8 +585,14 @@ getRegister' config plat expr
CmmLit lit
-> case lit of
- -- TODO handle CmmInt 0 specially, use wzr or xzr.
-
+ -- Use wzr xzr for CmmInt 0 if the width matches up, otherwise do a move.
+ -- TODO: Reenable after https://gitlab.haskell.org/ghc/ghc/-/issues/23632 is fixed.
+ -- CmmInt 0 W32 -> do
+ -- let format = intFormat W32
+ -- return (Fixed format reg_zero (unitOL $ (COMMENT ((text . show $ expr))) ))
+ -- CmmInt 0 W64 -> do
+ -- let format = intFormat W64
+ -- return (Fixed format reg_zero (unitOL $ (COMMENT ((text . show $ expr))) ))
CmmInt i W8 | i >= 0 -> do
return (Any (intFormat W8) (\dst -> unitOL $ annExpr expr (MOV (OpReg W8 dst) (OpImm (ImmInteger (narrowU W8 i))))))
CmmInt i W16 | i >= 0 -> do
@@ -510,8 +607,13 @@ getRegister' config plat expr
-- Those need the upper bits set. We'd either have to explicitly sign
-- or figure out something smarter. Lowered to
-- `MOV dst XZR`
+ CmmInt i w | i >= 0
+ , Just imm_op <- getMovWideImm i w -> do
+ return (Any (intFormat w) (\dst -> unitOL $ annExpr expr (MOVZ (OpReg w dst) imm_op)))
+
CmmInt i w | isNbitEncodeable 16 i, i >= 0 -> do
return (Any (intFormat w) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger i)))))
+
CmmInt i w | isNbitEncodeable 32 i, i >= 0 -> do
let half0 = fromIntegral (fromIntegral i :: Word16)
half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16)
@@ -586,7 +688,6 @@ getRegister' config plat expr
(op, imm_code) <- litToImm' lit
let rep = cmmLitType plat lit
format = cmmTypeFormat rep
- -- width = typeWidth rep
return (Any format (\dst -> imm_code `snocOL` LDR format (OpReg (formatToWidth format) dst) op))
CmmLabelOff lbl off -> do
@@ -791,17 +892,51 @@ getRegister' config plat expr
-- withTempFloatReg w op = OpReg w <$> getNewRegNat (floatFormat w) >>= op
-- A "plain" operation.
- bitOp w op = do
+ bitOpImm w op encode_imm = do
-- compute x<m> <- x
-- compute x<o> <- y
-- <OP> x<n>, x<m>, x<o>
(reg_x, format_x, code_x) <- getSomeReg x
- (reg_y, format_y, code_y) <- getSomeReg y
- massertPpr (isIntFormat format_x == isIntFormat format_y) $ text "bitOp: incompatible"
+ (op_y, format_y, code_y) <- case y of
+ CmmLit (CmmInt n w)
+ | Just imm_operand_y <- encode_imm n w
+ -> return (imm_operand_y, intFormat w, nilOL)
+ _ -> do
+ (reg_y, format_y, code_y) <- getSomeReg y
+ return (OpReg w reg_y, format_y, code_y)
+ massertPpr (isIntFormat format_x == isIntFormat format_y) $ text "bitOpImm: incompatible"
return $ Any (intFormat w) (\dst ->
code_x `appOL`
code_y `appOL`
- op (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))
+ op (OpReg w dst) (OpReg w reg_x) op_y)
+
+ -- A (potentially signed) integer operation.
+ -- In the case of 8- and 16-bit signed arithmetic we must first
+ -- sign-extend both arguments to 32-bits.
+ -- See Note [Signed arithmetic on AArch64].
+ intOpImm :: Bool -> Width -> (Operand -> Operand -> Operand -> OrdList Instr) -> (Integer -> Width -> Maybe Operand) -> NatM (Register)
+ intOpImm {- is signed -} True w op _encode_imm = intOp True w op
+ intOpImm False w op encode_imm = do
+ -- compute x<m> <- x
+ -- compute x<o> <- y
+ -- <OP> x<n>, x<m>, x<o>
+ (reg_x, format_x, code_x) <- getSomeReg x
+ (op_y, format_y, code_y) <- case y of
+ CmmLit (CmmInt n w)
+ | Just imm_operand_y <- encode_imm n w
+ -> return (imm_operand_y, intFormat w, nilOL)
+ _ -> do
+ (reg_y, format_y, code_y) <- getSomeReg y
+ return (OpReg w reg_y, format_y, code_y)
+ massertPpr (isIntFormat format_x && isIntFormat format_y) $ text "intOp: non-int"
+ -- This is the width of the registers on which the operation
+ -- should be performed.
+ let w' = opRegWidth w
+ return $ Any (intFormat w) $ \dst ->
+ code_x `appOL`
+ code_y `appOL`
+ op (OpReg w' dst) (OpReg w' reg_x) (op_y) `appOL`
+ truncateReg w' w dst -- truncate back to the operand's original width
-- A (potentially signed) integer operation.
-- In the case of 8- and 16-bit signed arithmetic we must first
@@ -847,9 +982,9 @@ getRegister' config plat expr
case op of
-- Integer operations
-- Add/Sub should only be Integer Options.
- MO_Add w -> intOp False w (\d x y -> unitOL $ annExpr expr (ADD d x y))
+ MO_Add w -> intOpImm False w (\d x y -> unitOL $ annExpr expr (ADD d x y)) getArithImm
-- TODO: Handle sub-word case
- MO_Sub w -> intOp False w (\d x y -> unitOL $ annExpr expr (SUB d x y))
+ MO_Sub w -> intOpImm False w (\d x y -> unitOL $ annExpr expr (SUB d x y)) getArithImm
-- Note [CSET]
-- ~~~~~~~~~~~
@@ -891,8 +1026,8 @@ getRegister' config plat expr
-- N.B. We needn't sign-extend sub-word size (in)equality comparisons
-- since we don't care about ordering.
- MO_Eq w -> bitOp w (\d x y -> toOL [ CMP x y, CSET d EQ ])
- MO_Ne w -> bitOp w (\d x y -> toOL [ CMP x y, CSET d NE ])
+ MO_Eq w -> bitOpImm w (\d x y -> toOL [ CMP x y, CSET d EQ ]) getArithImm
+ MO_Ne w -> bitOpImm w (\d x y -> toOL [ CMP x y, CSET d NE ]) getArithImm
-- Signed multiply/divide
MO_Mul w -> intOp True w (\d x y -> unitOL $ MUL d x y)
@@ -921,10 +1056,10 @@ getRegister' config plat expr
MO_S_Lt w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SLT ])
-- Unsigned comparisons
- MO_U_Ge w -> intOp False w (\d x y -> toOL [ CMP x y, CSET d UGE ])
- MO_U_Le w -> intOp False w (\d x y -> toOL [ CMP x y, CSET d ULE ])
- MO_U_Gt w -> intOp False w (\d x y -> toOL [ CMP x y, CSET d UGT ])
- MO_U_Lt w -> intOp False w (\d x y -> toOL [ CMP x y, CSET d ULT ])
+ MO_U_Ge w -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d UGE ]) getArithImm
+ MO_U_Le w -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d ULE ]) getArithImm
+ MO_U_Gt w -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d UGT ]) getArithImm
+ MO_U_Lt w -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d ULT ]) getArithImm
-- Floating point arithmetic
MO_F_Add w -> floatOp w (\d x y -> unitOL $ ADD d x y)
@@ -947,9 +1082,9 @@ getRegister' config plat expr
MO_F_Lt w -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OLT ]) -- x < y <=> y >= x
-- Bitwise operations
- MO_And w -> bitOp w (\d x y -> unitOL $ AND d x y)
- MO_Or w -> bitOp w (\d x y -> unitOL $ ORR d x y)
- MO_Xor w -> bitOp w (\d x y -> unitOL $ EOR d x y)
+ MO_And w -> bitOpImm w (\d x y -> unitOL $ AND d x y) getBitmaskImm
+ MO_Or w -> bitOpImm w (\d x y -> unitOL $ ORR d x y) getBitmaskImm
+ MO_Xor w -> bitOpImm w (\d x y -> unitOL $ EOR d x y) getBitmaskImm
MO_Shl w -> intOp False w (\d x y -> unitOL $ LSL d x y)
MO_U_Shr w -> intOp False w (\d x y -> unitOL $ LSR d x y)
MO_S_Shr w -> intOp True w (\d x y -> unitOL $ ASR d x y)
@@ -999,7 +1134,7 @@ getRegister' config plat expr
where
isNbitEncodeable :: Int -> Integer -> Bool
- isNbitEncodeable n i = let shift = n - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift)
+ isNbitEncodeable n_bits i = let shift = n_bits - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift)
-- N.B. MUL does not set the overflow flag.
do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
=====================================
compiler/GHC/CmmToAsm/AArch64/Instr.hs
=====================================
@@ -110,6 +110,7 @@ regUsageOfInstr platform instr = case instr of
LSR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
MOV dst src -> usage (regOp src, regOp dst)
MOVK dst src -> usage (regOp src, regOp dst)
+ MOVZ dst src -> usage (regOp src, regOp dst)
MVN dst src -> usage (regOp src, regOp dst)
ORR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
ROR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
@@ -251,6 +252,7 @@ patchRegsOfInstr instr env = case instr of
LSR o1 o2 o3 -> LSR (patchOp o1) (patchOp o2) (patchOp o3)
MOV o1 o2 -> MOV (patchOp o1) (patchOp o2)
MOVK o1 o2 -> MOVK (patchOp o1) (patchOp o2)
+ MOVZ o1 o2 -> MOVZ (patchOp o1) (patchOp o2)
MVN o1 o2 -> MVN (patchOp o1) (patchOp o2)
ORR o1 o2 o3 -> ORR (patchOp o1) (patchOp o2) (patchOp o3)
ROR o1 o2 o3 -> ROR (patchOp o1) (patchOp o2) (patchOp o3)
@@ -381,9 +383,8 @@ mkSpillInstr config reg delta slot =
where
a .&~. b = a .&. (complement b)
- fmt = case reg of
- RegReal (RealRegSingle n) | n < 32 -> II64
- _ -> FF64
+ fmt = fmtOfRealReg (case reg of { RegReal r -> r; _ -> panic "Expected real reg"})
+
mkIp0SpillAddr imm = ANN (text "Spill: IP0 <- SP + " <> int imm) $ ADD ip0 sp (OpImm (ImmInt imm))
mkStrSp imm = ANN (text "Spill@" <> int (off - delta)) $ STR fmt (OpReg W64 reg) (OpAddr (AddrRegImm (regSingle 31) (ImmInt imm)))
mkStrIp0 imm = ANN (text "Spill@" <> int (off - delta)) $ STR fmt (OpReg W64 reg) (OpAddr (AddrRegImm (regSingle 16) (ImmInt imm)))
@@ -408,9 +409,7 @@ mkLoadInstr config reg delta slot =
where
a .&~. b = a .&. (complement b)
- fmt = case reg of
- RegReal (RealRegSingle n) | n < 32 -> II64
- _ -> FF64
+ fmt = fmtOfRealReg (case reg of { RegReal r -> r; _ -> panic "Expected real reg"})
mkIp0SpillAddr imm = ANN (text "Reload: IP0 <- SP + " <> int imm) $ ADD ip0 sp (OpImm (ImmInt imm))
mkLdrSp imm = ANN (text "Reload@" <> int (off - delta)) $ LDR fmt (OpReg W64 reg) (OpAddr (AddrRegImm (regSingle 31) (ImmInt imm)))
@@ -619,7 +618,7 @@ data Instr
| MOV Operand Operand -- rd = rn or rd = #i
| MOVK Operand Operand
-- | MOVN Operand Operand
- -- | MOVZ Operand Operand
+ | MOVZ Operand Operand
| MVN Operand Operand -- rd = ~rn
| ORN Operand Operand Operand -- rd = rn | ~op2
| ORR Operand Operand Operand -- rd = rn | op2
@@ -708,6 +707,7 @@ instrCon i =
LSR{} -> "LSR"
MOV{} -> "MOV"
MOVK{} -> "MOVK"
+ MOVZ{} -> "MOVZ"
MVN{} -> "MVN"
ORN{} -> "ORN"
ORR{} -> "ORR"
@@ -782,6 +782,9 @@ wzr = OpReg W32 (RegReal (RealRegSingle (-1)))
sp = OpReg W64 (RegReal (RealRegSingle 31))
ip0 = OpReg W64 (RegReal (RealRegSingle 16))
+reg_zero :: Reg
+reg_zero = RegReal (RealRegSingle (-1))
+
_x :: Int -> Operand
_x i = OpReg W64 (RegReal (RealRegSingle i))
x0, x1, x2, x3, x4, x5, x6, x7 :: Operand
=====================================
compiler/GHC/CmmToAsm/AArch64/Ppr.hs
=====================================
@@ -417,6 +417,7 @@ pprInstr platform instr = case instr of
| isFloatOp o1 || isFloatOp o2 -> op2 (text "\tfmov") o1 o2
| otherwise -> op2 (text "\tmov") o1 o2
MOVK o1 o2 -> op2 (text "\tmovk") o1 o2
+ MOVZ o1 o2 -> op2 (text "\tmovz") o1 o2
MVN o1 o2 -> op2 (text "\tmvn") o1 o2
ORN o1 o2 o3 -> op3 (text "\torn") o1 o2 o3
ORR o1 o2 o3 -> op3 (text "\torr") o1 o2 o3
=====================================
compiler/GHC/CmmToAsm/AArch64/Regs.hs
=====================================
@@ -77,6 +77,8 @@ litToImm (CmmInt i w) = ImmInteger (narrowS w i)
-- narrow to the width: a CmmInt might be out of
-- range, but we assume that ImmInteger only contains
-- in-range values. A signed value should be fine here.
+ -- AK: We do call this with out of range values, however
+ -- it just truncates as we would expect.
litToImm (CmmFloat f W32) = ImmFloat f
litToImm (CmmFloat f W64) = ImmDouble f
litToImm (CmmLabel l) = ImmCLbl l
@@ -147,6 +149,13 @@ classOfRealReg (RealRegSingle i)
| i < 32 = RcInteger
| otherwise = RcDouble
+fmtOfRealReg :: RealReg -> Format
+fmtOfRealReg real_reg =
+ case classOfRealReg real_reg of
+ RcInteger -> II64
+ RcDouble -> FF64
+ RcFloat -> panic "No float regs on arm"
+
regDotColor :: RealReg -> SDoc
regDotColor reg
= case classOfRealReg reg of
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -568,6 +568,7 @@ codeGenFlags = EnumSet.fromList
-- Flags that affect generated code
, Opt_ExposeAllUnfoldings
, Opt_NoTypeableBinds
+ , Opt_Haddock
-- Flags that affect catching of runtime errors
, Opt_CatchNonexhaustiveCases
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -206,11 +206,8 @@ dsUnliftedBind (PatBind { pat_lhs = pat, pat_rhs = grhss
-- ==> case rhs of C x# y# -> body
do { match_nablas <- pmcGRHSs PatBindGuards grhss
; rhs <- dsGuarded grhss ty match_nablas
- ; let upat = unLoc pat
- eqn = EqnInfo { eqn_pats = [upat],
- eqn_orig = FromSource,
- eqn_rhs = cantFailMatchResult body }
- ; var <- selectMatchVar ManyTy upat
+ ; let eqn = EqnMatch { eqn_pat = pat, eqn_rest = EqnDone (cantFailMatchResult body) }
+ ; var <- selectMatchVar ManyTy (unLoc pat)
-- `var` will end up in a let binder, so the multiplicity
-- doesn't matter.
; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -29,8 +29,12 @@ import Language.Haskell.Syntax.Basic (Boxity(..))
import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr)
-import GHC.Types.Basic ( Origin(..), isGenerated, requiresPMC )
+import GHC.Types.Basic ( Origin(..), requiresPMC )
import GHC.Types.SourceText
+ ( FractionalLit,
+ IntegralLit(il_value),
+ negateFractionalLit,
+ integralFractionalLit )
import GHC.Driver.DynFlags
import GHC.Hs
import GHC.Hs.Syn.Type
@@ -193,13 +197,9 @@ match :: [MatchId] -- ^ Variables rep\'ing the exprs we\'re matching with
match [] ty eqns
= assertPpr (not (null eqns)) (ppr ty) $
- return (foldr1 combineMatchResults match_results)
- where
- match_results = [ assert (null (eqn_pats eqn)) $
- eqn_rhs eqn
- | eqn <- eqns ]
+ combineEqnRhss (NEL.fromList eqns)
-match (v:vs) ty eqns -- Eqns *can* be empty
+match (v:vs) ty eqns -- Eqns can be empty, but each equation is nonempty
= assertPpr (all (isInternalName . idName) vars) (ppr vars) $
do { dflags <- getDynFlags
; let platform = targetPlatform dflags
@@ -222,12 +222,11 @@ match (v:vs) ty eqns -- Eqns *can* be empty
dropGroup :: Functor f => f (PatGroup,EquationInfo) -> f EquationInfo
dropGroup = fmap snd
- match_groups :: [NonEmpty (PatGroup,EquationInfo)] -> DsM (NonEmpty (MatchResult CoreExpr))
- -- Result list of [MatchResult CoreExpr] is always non-empty
+ match_groups :: [NonEmpty (PatGroup,EquationInfoNE)] -> DsM (NonEmpty (MatchResult CoreExpr))
match_groups [] = matchEmpty v ty
match_groups (g:gs) = mapM match_group $ g :| gs
- match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM (MatchResult CoreExpr)
+ match_group :: NonEmpty (PatGroup,EquationInfoNE) -> DsM (MatchResult CoreExpr)
match_group eqns@((group,_) :| _)
= case group of
PgCon {} -> matchConFamily vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns'])
@@ -267,20 +266,20 @@ matchEmpty var res_ty
mk_seq fail = return $ mkWildCase (Var var) (idScaledType var) res_ty
[Alt DEFAULT [] fail]
-matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
+matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
-- Real true variables, just like in matchVar, SLPJ p 94
-- No binding to do: they'll all be wildcards by now (done in tidy)
matchVariables (_ :| vars) ty eqns = match vars ty $ NEL.toList $ shiftEqns eqns
-matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
+matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
matchBangs (var :| vars) ty eqns
= do { match_result <- match (var:vars) ty $ NEL.toList $
decomposeFirstPat getBangPat <$> eqns
; return (mkEvalMatchResult var ty match_result) }
-matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
+matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
-- Apply the coercion to the match variable and then match that
-matchCoercion (var :| vars) ty (eqns@(eqn1 :| _))
+matchCoercion (var :| vars) ty eqns@(eqn1 :| _)
= do { let XPat (CoPat co pat _) = firstPat eqn1
; let pat_ty' = hsPatType pat
; var' <- newUniqueId var (idMult var) pat_ty'
@@ -290,9 +289,9 @@ matchCoercion (var :| vars) ty (eqns@(eqn1 :| _))
{ let bind = NonRec var' (core_wrap (Var var))
; return (mkCoLetMatchResult bind match_result) } }
-matchView :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
+matchView :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
-- Apply the view function to the match variable and then match that
-matchView (var :| vars) ty (eqns@(eqn1 :| _))
+matchView (var :| vars) ty eqns@(eqn1 :| _)
= do { -- we could pass in the expr from the PgView,
-- but this needs to extract the pat anyway
-- to figure out the type of the fresh variable
@@ -309,10 +308,9 @@ matchView (var :| vars) ty (eqns@(eqn1 :| _))
match_result) }
-- decompose the first pattern and leave the rest alone
-decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
-decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
- = eqn { eqn_pats = extractpat pat : pats}
-decomposeFirstPat _ _ = panic "decomposeFirstPat"
+decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfoNE -> EquationInfoNE
+decomposeFirstPat extract eqn@(EqnMatch { eqn_pat = pat }) = eqn{eqn_pat = fmap extract pat}
+decomposeFirstPat _ (EqnDone {}) = panic "decomposeFirstPat"
getCoPat, getBangPat, getViewPat :: Pat GhcTc -> Pat GhcTc
getCoPat (XPat (CoPat _ pat _)) = pat
@@ -405,15 +403,14 @@ tidyEqnInfo :: Id -> EquationInfo
-- POST CONDITION: head pattern in the EqnInfo is
-- one of these for which patGroup is defined.
-tidyEqnInfo _ (EqnInfo { eqn_pats = [] })
- = panic "tidyEqnInfo"
+tidyEqnInfo _ eqn@(EqnDone {}) = return (idDsWrapper, eqn)
-tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_orig = orig })
- = do { (wrap, pat') <- tidy1 v orig pat
- ; return (wrap, eqn { eqn_pats = pat' : pats }) }
+tidyEqnInfo v eqn@(EqnMatch { eqn_pat = (L loc pat) }) = do
+ (wrap, pat') <- tidy1 v (not . isGoodSrcSpan . locA $ loc) pat
+ return (wrap, eqn{eqn_pat = L loc pat' })
tidy1 :: Id -- The Id being scrutinised
- -> Origin -- Was this a pattern the user wrote?
+ -> Bool -- `True` if the pattern was generated, `False` if it was user-written
-> Pat GhcTc -- The pattern against which it is to be matched
-> DsM (DsWrapper, -- Extra bindings to do before the match
Pat GhcTc) -- Equivalent pattern
@@ -424,10 +421,10 @@ tidy1 :: Id -- The Id being scrutinised
-- It eliminates many pattern forms (as-patterns, variable patterns,
-- list patterns, etc) and returns any created bindings in the wrapper.
-tidy1 v o (ParPat _ _ pat _) = tidy1 v o (unLoc pat)
-tidy1 v o (SigPat _ pat _) = tidy1 v o (unLoc pat)
+tidy1 v g (ParPat _ _ pat _) = tidy1 v g (unLoc pat)
+tidy1 v g (SigPat _ pat _) = tidy1 v g (unLoc pat)
tidy1 _ _ (WildPat ty) = return (idDsWrapper, WildPat ty)
-tidy1 v o (BangPat _ (L l p)) = tidy_bang_pat v o l p
+tidy1 v g (BangPat _ (L l p)) = tidy_bang_pat v g l p
-- case v of { x -> mr[] }
-- = case v of { _ -> let x=v in mr[] }
@@ -436,8 +433,8 @@ tidy1 v _ (VarPat _ (L _ var))
-- case v of { x at p -> mr[] }
-- = case v of { p -> let x=v in mr[] }
-tidy1 v o (AsPat _ (L _ var) _ pat)
- = do { (wrap, pat') <- tidy1 v o (unLoc pat)
+tidy1 v g (AsPat _ (L _ var) _ pat)
+ = do { (wrap, pat') <- tidy1 v g (unLoc pat)
; return (wrapBind var v . wrap, pat') }
{- now, here we handle lazy patterns:
@@ -489,22 +486,22 @@ tidy1 _ _ (SumPat tys pat alt arity)
-- See Note [Unboxed tuple RuntimeRep vars] in TyCon
-- LitPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ o (LitPat _ lit)
- = do { unless (isGenerated o) $
+tidy1 _ g (LitPat _ lit)
+ = do { unless g $
warnAboutOverflowedLit lit
; return (idDsWrapper, tidyLitPat lit) }
-- NPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ o (NPat ty (L _ lit at OverLit { ol_val = v }) mb_neg eq)
- = do { unless (isGenerated o) $
+tidy1 _ g (NPat ty (L _ lit at OverLit { ol_val = v }) mb_neg eq)
+ = do { unless g $
let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v }
| otherwise = lit
in warnAboutOverflowedOverLit lit'
; return (idDsWrapper, tidyNPat lit mb_neg eq ty) }
-- NPlusKPat: we may want to warn about the literals
-tidy1 _ o n@(NPlusKPat _ _ (L _ lit1) lit2 _ _)
- = do { unless (isGenerated o) $ do
+tidy1 _ g n@(NPlusKPat _ _ (L _ lit1) lit2 _ _)
+ = do { unless g $ do
warnAboutOverflowedOverLit lit1
warnAboutOverflowedOverLit lit2
; return (idDsWrapper, n) }
@@ -514,28 +511,28 @@ tidy1 _ _ non_interesting_pat
= return (idDsWrapper, non_interesting_pat)
--------------------
-tidy_bang_pat :: Id -> Origin -> SrcSpanAnnA -> Pat GhcTc
+tidy_bang_pat :: Id -> Bool -> SrcSpanAnnA -> Pat GhcTc
-> DsM (DsWrapper, Pat GhcTc)
-- Discard par/sig under a bang
-tidy_bang_pat v o _ (ParPat _ _ (L l p) _) = tidy_bang_pat v o l p
-tidy_bang_pat v o _ (SigPat _ (L l p) _) = tidy_bang_pat v o l p
+tidy_bang_pat v g _ (ParPat _ _ (L l p) _) = tidy_bang_pat v g l p
+tidy_bang_pat v g _ (SigPat _ (L l p) _) = tidy_bang_pat v g l p
-- Push the bang-pattern inwards, in the hope that
-- it may disappear next time
-tidy_bang_pat v o l (AsPat x v' at p)
- = tidy1 v o (AsPat x v' at (L l (BangPat noExtField p)))
-tidy_bang_pat v o l (XPat (CoPat w p t))
- = tidy1 v o (XPat $ CoPat w (BangPat noExtField (L l p)) t)
+tidy_bang_pat v g l (AsPat x v' at p)
+ = tidy1 v g (AsPat x v' at (L l (BangPat noExtField p)))
+tidy_bang_pat v g l (XPat (CoPat w p t))
+ = tidy1 v g (XPat $ CoPat w (BangPat noExtField (L l p)) t)
-- Discard bang around strict pattern
-tidy_bang_pat v o _ p@(LitPat {}) = tidy1 v o p
-tidy_bang_pat v o _ p@(ListPat {}) = tidy1 v o p
-tidy_bang_pat v o _ p@(TuplePat {}) = tidy1 v o p
-tidy_bang_pat v o _ p@(SumPat {}) = tidy1 v o p
+tidy_bang_pat v g _ p@(LitPat {}) = tidy1 v g p
+tidy_bang_pat v g _ p@(ListPat {}) = tidy1 v g p
+tidy_bang_pat v g _ p@(TuplePat {}) = tidy1 v g p
+tidy_bang_pat v g _ p@(SumPat {}) = tidy1 v g p
-- Data/newtype constructors
-tidy_bang_pat v o l p@(ConPat { pat_con = L _ (RealDataCon dc)
+tidy_bang_pat v g l p@(ConPat { pat_con = L _ (RealDataCon dc)
, pat_args = args
, pat_con_ext = ConPatTc
{ cpt_arg_tys = arg_tys
@@ -544,8 +541,8 @@ tidy_bang_pat v o l p@(ConPat { pat_con = L _ (RealDataCon dc)
-- Newtypes: push bang inwards (#9844)
=
if isNewTyCon (dataConTyCon dc)
- then tidy1 v o (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args })
- else tidy1 v o p -- Data types: discard the bang
+ then tidy1 v g (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args })
+ else tidy1 v g p -- Data types: discard the bang
where
(ty:_) = dataConInstArgTys dc arg_tys
@@ -808,16 +805,14 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches
mk_eqn_info :: LMatch GhcTc (LHsExpr GhcTc) -> (Nablas, NonEmpty Nablas) -> DsM EquationInfo
mk_eqn_info (L _ (Match { m_pats = pats, m_grhss = grhss })) (pat_nablas, rhss_nablas)
= do { dflags <- getDynFlags
- ; let upats = map (unLoc . decideBangHood dflags) pats
+ ; let upats = map (decideBangHood dflags) pats
-- pat_nablas is the covered set *after* matching the pattern, but
-- before any of the GRHSs. We extend the environment with pat_nablas
-- (via updPmNablas) so that the where-clause of 'grhss' can profit
-- from that knowledge (#18533)
; match_result <- updPmNablas pat_nablas $
dsGRHSs ctxt grhss rhs_ty rhss_nablas
- ; return EqnInfo { eqn_pats = upats
- , eqn_orig = FromSource
- , eqn_rhs = match_result } }
+ ; return $ mkEqnInfo upats match_result }
discard_warnings_if_skip_pmc orig =
if requiresPMC orig
@@ -958,10 +953,9 @@ matchSinglePatVar var mb_scrut ctx pat ty match_result
pmcPatBind (DsMatchContext ctx locn) var (unLoc pat)
else getLdiNablas
- ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]
- , eqn_orig = FromSource
- , eqn_rhs =
- updPmNablasMatchResult ldi_nablas match_result }
+ ; let eqn_info = EqnMatch { eqn_pat = decideBangHood dflags pat
+ , eqn_rest =
+ EqnDone $ updPmNablasMatchResult ldi_nablas match_result }
-- See Note [Long-distance information in do notation]
-- in GHC.HsToCore.Expr.
@@ -999,6 +993,13 @@ data PatGroup
-- the LHsExpr is the expression e
Type -- the Type is the type of p (equivalently, the result type of e)
+instance Show PatGroup where
+ show PgAny = "PgAny"
+ show (PgCon _) = "PgCon"
+ show (PgLit _) = "PgLit"
+ show (PgView _ _) = "PgView"
+ show _ = "PgOther"
+
{- Note [Don't use Literal for PgN]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Previously we had, as PatGroup constructors
@@ -1019,7 +1020,7 @@ the PgN constructor as a FractionalLit if numeric, and add a PgOverStr construct
for overloaded strings.
-}
-groupEquations :: Platform -> [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)]
+groupEquations :: Platform -> [EquationInfoNE] -> [NonEmpty (PatGroup, EquationInfoNE)]
-- If the result is of form [g1, g2, g3],
-- (a) all the (pg,eq) pairs in g1 have the same pg
-- (b) none of the gi are empty
@@ -1163,8 +1164,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2'
-- the fixities have been straightened out by now, so it's safe
-- to ignore them?
- exp (OpApp _ l o ri) (OpApp _ l' o' ri') =
- lexp l l' && lexp o o' && lexp ri ri'
+ exp (OpApp _ l g ri) (OpApp _ l' o' ri') =
+ lexp l l' && lexp g o' && lexp ri ri'
exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n'
exp (SectionL _ e1 e2) (SectionL _ e1' e2') =
lexp e1 e1' && lexp e2 e2'
=====================================
compiler/GHC/HsToCore/Match/Constructor.hs
=====================================
@@ -21,7 +21,6 @@ import {-# SOURCE #-} GHC.HsToCore.Match ( match )
import GHC.Hs
import GHC.HsToCore.Binds
import GHC.Core.ConLike
-import GHC.Types.Basic
import GHC.Tc.Utils.TcType
import GHC.Core.Multiplicity
import GHC.HsToCore.Monad
@@ -95,7 +94,7 @@ have-we-used-all-the-constructors? question; the local function
matchConFamily :: NonEmpty Id
-> Type
- -> NonEmpty (NonEmpty EquationInfo)
+ -> NonEmpty (NonEmpty EquationInfoNE)
-> DsM (MatchResult CoreExpr)
-- Each group of eqns is for a single constructor
matchConFamily (var :| vars) ty groups
@@ -114,7 +113,7 @@ matchConFamily (var :| vars) ty groups
matchPatSyn :: NonEmpty Id
-> Type
- -> NonEmpty EquationInfo
+ -> NonEmpty EquationInfoNE
-> DsM (MatchResult CoreExpr)
matchPatSyn (var :| vars) ty eqns
= do let mult = idMult var
@@ -130,7 +129,7 @@ type ConArgPats = HsConPatDetails GhcTc
matchOneConLike :: [Id]
-> Type
-> Mult
- -> NonEmpty EquationInfo
+ -> NonEmpty EquationInfoNE
-> DsM (CaseAlt ConLike)
matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single constructor
= do { let inst_tys = assert (all tcIsTcTyVar ex_tvs) $
@@ -144,7 +143,7 @@ matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single construct
-- and returns the types of the *value* args, which is what we want
match_group :: [Id]
- -> NonEmpty (ConArgPats, EquationInfo)
+ -> NonEmpty (ConArgPats, EquationInfoNE)
-> DsM (MatchResult CoreExpr)
-- All members of the group have compatible ConArgPats
match_group arg_vars arg_eqn_prs
@@ -154,24 +153,21 @@ matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single construct
; return $ foldr1 (.) wraps <$> match_result
}
- shift (_, eqn@(EqnInfo
- { eqn_pats = ConPat
- { pat_args = args
- , pat_con_ext = ConPatTc
- { cpt_tvs = tvs
- , cpt_dicts = ds
- , cpt_binds = bind
- }
- } : pats
- }))
+ shift (_, EqnMatch {
+ eqn_pat = L _ (ConPat
+ { pat_args = args
+ , pat_con_ext = ConPatTc
+ { cpt_tvs = tvs
+ , cpt_dicts = ds
+ , cpt_binds = bind }})
+ , eqn_rest = rest })
= do dsTcEvBinds bind $ \ds_bind ->
return ( wrapBinds (tvs `zip` tvs1)
. wrapBinds (ds `zip` dicts1)
. mkCoreLets ds_bind
- , eqn { eqn_orig = Generated SkipPmc
- , eqn_pats = conArgPats val_arg_tys args ++ pats }
+ , prependPats (conArgPats val_arg_tys args) rest
)
- shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps)
+ shift (_, eqn) = pprPanic "matchOneCon/shift" (ppr eqn)
; let scaled_arg_tys = map (scaleScaled mult) val_arg_tys
-- The 'val_arg_tys' are taken from the data type definition, they
-- do not take into account the context multiplicity, therefore we
@@ -185,7 +181,7 @@ matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single construct
-- suggestions for the new variables
-- Divide into sub-groups; see Note [Record patterns]
- ; let groups :: NonEmpty (NonEmpty (ConArgPats, EquationInfo))
+ ; let groups :: NonEmpty (NonEmpty (ConArgPats, EquationInfoNE))
groups = NE.groupBy1 compatible_pats
$ fmap (\eqn -> (pat_args (firstPat eqn), eqn)) (eqn1 :| eqns)
@@ -257,14 +253,14 @@ conArgPats :: [Scaled Type]-- Instantiated argument types
-- Used only to fill in the types of WildPats, which
-- are probably never looked at anyway
-> ConArgPats
- -> [Pat GhcTc]
-conArgPats _arg_tys (PrefixCon _ ps) = map unLoc ps
-conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2]
+ -> [LPat GhcTc]
+conArgPats _arg_tys (PrefixCon _ ps) = ps
+conArgPats _arg_tys (InfixCon p1 p2) = [p1, p2]
conArgPats arg_tys (RecCon (HsRecFields { rec_flds = rpats }))
- | null rpats = map WildPat (map scaledThing arg_tys)
+ | null rpats = map (noLocA . WildPat . scaledThing) arg_tys
-- Important special case for C {}, which can be used for a
-- datacon that isn't declared to have fields at all
- | otherwise = map (unLoc . hfbRHS . unLoc) rpats
+ | otherwise = map (hfbRHS . unLoc) rpats
{-
Note [Record patterns]
=====================================
compiler/GHC/HsToCore/Match/Literal.hs
=====================================
@@ -607,7 +607,7 @@ tidyNPat over_lit mb_neg eq outer_ty
matchLiterals :: NonEmpty Id
-> Type -- ^ Type of the whole case expression
- -> NonEmpty (NonEmpty EquationInfo) -- ^ All PgLits
+ -> NonEmpty (NonEmpty EquationInfoNE) -- ^ All PgLits
-> DsM (MatchResult CoreExpr)
matchLiterals (var :| vars) ty sub_groups
@@ -625,11 +625,11 @@ matchLiterals (var :| vars) ty sub_groups
return (mkCoPrimCaseMatchResult var ty $ NEL.toList alts)
}
where
- match_group :: NonEmpty EquationInfo -> DsM (Literal, MatchResult CoreExpr)
- match_group eqns@(firstEqn :| _)
+ match_group :: NonEmpty EquationInfoNE -> DsM (Literal, MatchResult CoreExpr)
+ match_group eqns
= do { dflags <- getDynFlags
; let platform = targetPlatform dflags
- ; let LitPat _ hs_lit = firstPat firstEqn
+ ; let EqnMatch { eqn_pat = L _ (LitPat _ hs_lit) } = NEL.head eqns
; match_result <- match vars ty (NEL.toList $ shiftEqns eqns)
; return (hsLitKey platform hs_lit, match_result) }
@@ -682,7 +682,7 @@ hsLitKey _ l = pprPanic "hsLitKey" (ppr l)
************************************************************************
-}
-matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
+matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
matchNPats (var :| vars) ty (eqn1 :| eqns) -- All for the same literal
= do { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1
; lit_expr <- dsOverLit lit
@@ -711,7 +711,7 @@ We generate:
\end{verbatim}
-}
-matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
+matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
-- All NPlusKPats, for the *same* literal k
matchNPlusKPats (var :| vars) ty (eqn1 :| eqns)
= do { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus
@@ -727,7 +727,7 @@ matchNPlusKPats (var :| vars) ty (eqn1 :| eqns)
fmap (foldr1 (.) wraps) $
match_result) }
where
- shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats })
- = (wrapBind n n1, eqn { eqn_pats = pats })
+ shift n1 (EqnMatch { eqn_pat = L _ (NPlusKPat _ (L _ n) _ _ _ _), eqn_rest = rest })
+ = (wrapBind n n1, rest)
-- The wrapBind is a no-op for the first equation
shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -49,7 +49,8 @@ module GHC.HsToCore.Monad (
-- Data types
DsMatchContext(..),
- EquationInfo(..), MatchResult (..), runMatchResult, DsWrapper, idDsWrapper,
+ EquationInfo(..), EquationInfoNE, prependPats, mkEqnInfo, eqnMatchResult,
+ MatchResult (..), runMatchResult, DsWrapper, idDsWrapper,
-- Trace injection
pprRuntimeTrace
@@ -92,7 +93,6 @@ import GHC.Unit.Module
import GHC.Unit.Module.ModGuts
import GHC.Types.Name.Reader
-import GHC.Types.Basic ( Origin )
import GHC.Types.SourceFile
import GHC.Types.Id
import GHC.Types.Var (EvId)
@@ -132,27 +132,42 @@ instance Outputable DsMatchContext where
ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match
data EquationInfo
- = EqnInfo { eqn_pats :: [Pat GhcTc]
- -- ^ The patterns for an equation
- --
- -- NB: We have /already/ applied 'decideBangHood' to
- -- these patterns. See Note [decideBangHood] in "GHC.HsToCore.Utils"
-
- , eqn_orig :: Origin
- -- ^ Was this equation present in the user source?
- --
- -- This helps us avoid warnings on patterns that GHC elaborated.
- --
- -- For instance, the pattern @-1 :: Word@ gets desugared into
- -- @W# -1## :: Word@, but we shouldn't warn about an overflowed
- -- literal for /both/ of these cases.
-
- , eqn_rhs :: MatchResult CoreExpr
- -- ^ What to do after match
- }
+ = EqnMatch { eqn_pat :: LPat GhcTc
+ -- ^ The first pattern of the equation
+ --
+ -- NB: The location info is used to determine whether the
+ -- pattern is generated or not.
+ -- This helps us avoid warnings on patterns that GHC elaborated.
+ --
+ -- NB: We have /already/ applied 'decideBangHood' to this
+ -- pattern. See Note [decideBangHood] in "GHC.HsToCore.Utils"
+
+ , eqn_rest :: EquationInfo }
+ -- ^ The rest of the equation after its first pattern
+
+ | EqnDone
+ -- The empty tail of an equation having no more patterns
+ (MatchResult CoreExpr)
+ -- ^ What to do after match
+
+type EquationInfoNE = EquationInfo
+-- An EquationInfo which has at least one pattern
+
+prependPats :: [LPat GhcTc] -> EquationInfo -> EquationInfo
+prependPats [] eqn = eqn
+prependPats (pat:pats) eqn = EqnMatch { eqn_pat = pat, eqn_rest = prependPats pats eqn }
+
+mkEqnInfo :: [LPat GhcTc] -> MatchResult CoreExpr -> EquationInfo
+mkEqnInfo pats = prependPats pats . EqnDone
+
+eqnMatchResult :: EquationInfo -> MatchResult CoreExpr
+eqnMatchResult (EqnDone rhs) = rhs
+eqnMatchResult (EqnMatch { eqn_rest = eq }) = eqnMatchResult eq
instance Outputable EquationInfo where
- ppr (EqnInfo pats _ _) = ppr pats
+ ppr = ppr . allEqnPats where
+ allEqnPats (EqnDone {}) = []
+ allEqnPats (EqnMatch { eqn_pat = pat, eqn_rest = eq }) = unLoc pat : allEqnPats eq
type DsWrapper = CoreExpr -> CoreExpr
idDsWrapper :: DsWrapper
=====================================
compiler/GHC/HsToCore/Utils.hs
=====================================
@@ -15,7 +15,7 @@ This module exports some utility functions of no great interest.
-- | Utility functions for constructing Core syntax, principally for desugaring
module GHC.HsToCore.Utils (
EquationInfo(..),
- firstPat, shiftEqns,
+ firstPat, shiftEqns, combineEqnRhss,
MatchResult (..), CaseAlt(..),
cantFailMatchResult, alwaysFailMatchResult,
@@ -194,12 +194,16 @@ The ``equation info'' used by @match@ is relatively complicated and
worthy of a type synonym and a few handy functions.
-}
-firstPat :: EquationInfo -> Pat GhcTc
-firstPat eqn = assert (notNull (eqn_pats eqn)) $ head (eqn_pats eqn)
+firstPat :: EquationInfoNE -> Pat GhcTc
+firstPat (EqnMatch { eqn_pat = pat }) = unLoc pat
+firstPat (EqnDone {}) = error "firstPat: no patterns"
-shiftEqns :: Functor f => f EquationInfo -> f EquationInfo
+shiftEqns :: Functor f => f EquationInfoNE -> f EquationInfo
-- Drop the first pattern in each equation
-shiftEqns = fmap $ \eqn -> eqn { eqn_pats = tail (eqn_pats eqn) }
+shiftEqns = fmap eqn_rest
+
+combineEqnRhss :: NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
+combineEqnRhss eqns = return $ foldr1 combineMatchResults $ map eqnMatchResult (NEL.toList eqns)
-- Functions on MatchResult CoreExprs
=====================================
libraries/base/Data/Fixed.hs
=====================================
@@ -13,10 +13,19 @@
-- Stability : stable
-- Portability : portable
--
--- This module defines a \"Fixed\" type for fixed-precision arithmetic.
--- The parameter to 'Fixed' is any type that's an instance of 'HasResolution'.
--- 'HasResolution' has a single method that gives the resolution of the 'Fixed'
--- type.
+-- This module defines a 'Fixed' type for working with fixed-point arithmetic.
+-- Fixed-point arithmetic represents fractional numbers with a fixed number of
+-- digits for their fractional part. This is different to the behaviour of the floating-point
+-- number types 'Float' and 'Double', because the number of digits of the
+-- fractional part of 'Float' and 'Double' numbers depends on the size of the number.
+-- Fixed point arithmetic is frequently used in financial mathematics, where they
+-- are used for representing decimal currencies.
+--
+-- The type 'Fixed' is used for fixed-point fractional numbers, which are internally
+-- represented as an 'Integer'. The type 'Fixed' takes one parameter, which should implement
+-- the typeclass 'HasResolution', to specify the number of digits of the fractional part.
+-- This module provides instances of the `HasResolution` typeclass for arbitrary typelevel
+-- natural numbers, and for some canonical important fixed-point representations.
--
-- This module also contains generalisations of 'div', 'mod', and 'divMod' to
-- work with any 'Real' instance.
@@ -31,18 +40,49 @@
-----------------------------------------------------------------------------
module Data.Fixed
-(
- div',mod',divMod',
-
+( -- * The Fixed Type
Fixed(..), HasResolution(..),
showFixed,
+ -- * Resolution \/ Scaling Factors
+ -- | The resolution or scaling factor determines the number of digits in the fractional part.
+ --
+ -- +------------+----------------------+--------------------------+--------------------------+
+ -- | Resolution | Scaling Factor | Synonym for \"Fixed EX\" | show (12345 :: Fixed EX) |
+ -- +============+======================+==========================+==========================+
+ -- | E0 | 1\/1 | Uni | 12345.0 |
+ -- +------------+----------------------+--------------------------+--------------------------+
+ -- | E1 | 1\/10 | Deci | 1234.5 |
+ -- +------------+----------------------+--------------------------+--------------------------+
+ -- | E2 | 1\/100 | Centi | 123.45 |
+ -- +------------+----------------------+--------------------------+--------------------------+
+ -- | E3 | 1\/1 000 | Milli | 12.345 |
+ -- +------------+----------------------+--------------------------+--------------------------+
+ -- | E6 | 1\/1 000 000 | Micro | 0.012345 |
+ -- +------------+----------------------+--------------------------+--------------------------+
+ -- | E9 | 1\/1 000 000 000 | Nano | 0.000012345 |
+ -- +------------+----------------------+--------------------------+--------------------------+
+ -- | E12 | 1\/1 000 000 000 000 | Pico | 0.000000012345 |
+ -- +------------+----------------------+--------------------------+--------------------------+
+ --
+
+ -- ** 1\/1
E0,Uni,
+ -- ** 1\/10
E1,Deci,
+ -- ** 1\/100
E2,Centi,
+ -- ** 1\/1 000
E3,Milli,
+ -- ** 1\/1 000 000
E6,Micro,
+ -- ** 1\/1 000 000 000
E9,Nano,
- E12,Pico
+ -- ** 1\/1 000 000 000 000
+ E12,Pico,
+ -- * Generalized Functions on Real's
+ div',
+ mod',
+ divMod'
) where
import Data.Data
@@ -67,7 +107,14 @@ mod' :: (Real a) => a -> a -> a
mod' n d = n - (fromInteger f) * d where
f = div' n d
--- | The type parameter should be an instance of 'HasResolution'.
+-- | The type of fixed-point fractional numbers.
+-- The type parameter specifies the number of digits of the fractional part and should be an instance of the 'HasResolution' typeclass.
+--
+-- === __Examples__
+--
+-- @
+-- MkFixed 12345 :: Fixed E3
+-- @
newtype Fixed (a :: k) = MkFixed Integer
deriving ( Eq -- ^ @since 2.01
, Ord -- ^ @since 2.01
@@ -77,6 +124,7 @@ newtype Fixed (a :: k) = MkFixed Integer
-- Our manual instance has the more general (Typeable a) context.
tyFixed :: DataType
tyFixed = mkDataType "Data.Fixed.Fixed" [conMkFixed]
+
conMkFixed :: Constr
conMkFixed = mkConstr tyFixed "MkFixed" [] Prefix
@@ -87,7 +135,9 @@ instance (Typeable k,Typeable a) => Data (Fixed (a :: k)) where
dataTypeOf _ = tyFixed
toConstr _ = conMkFixed
+-- | Types which can be used as a resolution argument to the 'Fixed' type constructor must implement the 'HasResolution' typeclass.
class HasResolution (a :: k) where
+ -- | Provide the resolution for a fixed-point fractional number.
resolution :: p a -> Integer
-- | For example, @Fixed 1000@ will give you a 'Fixed' with a resolution of 1000.
@@ -109,33 +159,26 @@ withResolution foo = withType (foo . resolution)
-- resolution of the 'Fixed' value. For example, when enumerating values of
-- resolution @10^-3@ of @type Milli = Fixed E3@,
--
--- @
--- succ (0.000 :: Milli) == 0.001
--- @
---
+-- >>> succ (0.000 :: Milli)
+-- 0.001
--
-- and likewise
--
--- @
--- pred (0.000 :: Milli) == -0.001
--- @
---
+-- >>> pred (0.000 :: Milli)
+-- -0.001
--
-- In other words, 'succ' and 'pred' increment and decrement a fixed-precision
-- value by the least amount such that the value's resolution is unchanged.
-- For example, @10^-12@ is the smallest (positive) amount that can be added to
-- a value of @type Pico = Fixed E12@ without changing its resolution, and so
--
--- @
--- succ (0.000000000000 :: Pico) == 0.000000000001
--- @
---
+-- >>> succ (0.000000000000 :: Pico)
+-- 0.000000000001
--
-- and similarly
--
--- @
--- pred (0.000000000000 :: Pico) == -0.000000000001
--- @
+-- >>> pred (0.000000000000 :: Pico)
+-- -0.000000000001
--
--
-- This is worth bearing in mind when defining 'Fixed' arithmetic sequences. In
@@ -175,6 +218,7 @@ instance Enum (Fixed a) where
--
-- >>> (0.2 * 0.6 :: Deci) * 0.9 == 0.2 * (0.6 * 0.9)
-- False
+--
-- >>> (0.1 + 0.1 :: Deci) * 0.5 == 0.1 * 0.5 + 0.1 * 0.5
-- False
instance (HasResolution a) => Num (Fixed a) where
@@ -223,6 +267,15 @@ withDot "" = ""
withDot s = '.':s
-- | First arg is whether to chop off trailing zeros
+--
+-- === __Examples__
+--
+-- >>> showFixed True (MkFixed 10000 :: Fixed E3)
+-- "10"
+--
+-- >>> showFixed False (MkFixed 10000 :: Fixed E3)
+-- "10.000"
+--
showFixed :: (HasResolution a) => Bool -> Fixed a -> String
showFixed chopTrailingZeros fa@(MkFixed a) | a < 0 = "-" ++ (showFixed chopTrailingZeros (asTypeOf (MkFixed (negate a)) fa))
showFixed chopTrailingZeros fa@(MkFixed a) = (show i) ++ (withDot (showIntegerZeros chopTrailingZeros digits fracNum)) where
@@ -256,58 +309,135 @@ convertFixed (Number n)
e = ceiling (logBase 10 (fromInteger r) :: Double)
convertFixed _ = pfail
+-- | Resolution of 1, this works the same as Integer.
data E0
-- | @since 4.1.0.0
instance HasResolution E0 where
resolution _ = 1
--- | resolution of 1, this works the same as Integer
+
+-- | Resolution of 1, this works the same as Integer.
+--
+-- === __Examples__
+--
+-- >>> show (MkFixed 12345 :: Fixed E0)
+-- "12345.0"
+--
+-- >>> show (MkFixed 12345 :: Uni)
+-- "12345.0"
+--
type Uni = Fixed E0
+-- | Resolution of 10^-1 = .1
data E1
-- | @since 4.1.0.0
instance HasResolution E1 where
resolution _ = 10
--- | resolution of 10^-1 = .1
+
+-- | Resolution of 10^-1 = .1
+--
+-- === __Examples__
+--
+-- >>> show (MkFixed 12345 :: Fixed E1)
+-- "1234.5"
+--
+-- >>> show (MkFixed 12345 :: Deci)
+-- "1234.5"
+--
type Deci = Fixed E1
+-- | Resolution of 10^-2 = .01, useful for many monetary currencies
data E2
-- | @since 4.1.0.0
instance HasResolution E2 where
resolution _ = 100
--- | resolution of 10^-2 = .01, useful for many monetary currencies
+
+-- | Resolution of 10^-2 = .01, useful for many monetary currencies
+--
+-- === __Examples__
+--
+-- >>> show (MkFixed 12345 :: Fixed E2)
+-- "123.45"
+--
+-- >>> show (MkFixed 12345 :: Centi)
+-- "123.45"
+--
type Centi = Fixed E2
+-- | Resolution of 10^-3 = .001
data E3
-- | @since 4.1.0.0
instance HasResolution E3 where
resolution _ = 1000
--- | resolution of 10^-3 = .001
+
+-- | Resolution of 10^-3 = .001
+--
+-- === __Examples__
+--
+-- >>> show (MkFixed 12345 :: Fixed E3)
+-- "12.345"
+--
+-- >>> show (MkFixed 12345 :: Milli)
+-- "12.345"
+--
type Milli = Fixed E3
+-- | Resolution of 10^-6 = .000001
data E6
-- | @since 2.01
instance HasResolution E6 where
resolution _ = 1000000
--- | resolution of 10^-6 = .000001
+
+-- | Resolution of 10^-6 = .000001
+--
+-- === __Examples__
+--
+-- >>> show (MkFixed 12345 :: Fixed E6)
+-- "0.012345"
+--
+-- >>> show (MkFixed 12345 :: Micro)
+-- "0.012345"
+--
type Micro = Fixed E6
+-- | Resolution of 10^-9 = .000000001
data E9
-- | @since 4.1.0.0
instance HasResolution E9 where
resolution _ = 1000000000
--- | resolution of 10^-9 = .000000001
+
+-- | Resolution of 10^-9 = .000000001
+--
+-- === __Examples__
+--
+-- >>> show (MkFixed 12345 :: Fixed E9)
+-- "0.000012345"
+--
+-- >>> show (MkFixed 12345 :: Nano)
+-- "0.000012345"
+--
type Nano = Fixed E9
+-- | Resolution of 10^-12 = .000000000001
data E12
-- | @since 2.01
instance HasResolution E12 where
resolution _ = 1000000000000
--- | resolution of 10^-12 = .000000000001
+
+-- | Resolution of 10^-12 = .000000000001
+--
+-- === __Examples__
+--
+-- >>> show (MkFixed 12345 :: Fixed E12)
+-- "0.000000012345"
+--
+-- >>> show (MkFixed 12345 :: Pico)
+-- "0.000000012345"
+--
type Pico = Fixed E12
=====================================
libraries/base/GHC/IO/Handle/FD.hs
=====================================
@@ -13,6 +13,8 @@
--
-- Handle operations implemented by file descriptors (FDs)
--
+-- @since 4.2.0.0
+--
-----------------------------------------------------------------------------
module GHC.IO.Handle.FD (
@@ -157,6 +159,8 @@ openFile fp im =
-- raising an exception. If closing the handle raises an exception, then
-- this exception will be raised by 'withFile' rather than any exception
-- raised by @act at .
+--
+-- @since 4.16.0.0
withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile fp im act =
catchException
@@ -189,6 +193,8 @@ openFileBlocking fp im =
-- by raising an exception. If closing the handle raises an exception, then
-- this exception will be raised by 'withFile' rather than any exception raised
-- by @act at .
+--
+-- @since 4.16.0.0
withFileBlocking :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFileBlocking fp im act =
catchException
@@ -217,6 +223,8 @@ openBinaryFile fp m =
-- the file will be closed automatically. The action /should/
-- close the file when finished with it so the file does not remain
-- open until the garbage collector collects the handle.
+--
+-- @since 4.16.0.0
withBinaryFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile fp im act =
catchException
@@ -366,6 +374,8 @@ fdToHandle fdint = do
-- | Turn an existing Handle into a file descriptor. This function throws an
-- IOError if the Handle does not reference a file descriptor.
+--
+-- @since 4.10.0.0
handleToFd :: Handle -> IO FD.FD
handleToFd h = case h of
FileHandle _ mv -> do
=====================================
libraries/filepath
=====================================
@@ -1 +1 @@
-Subproject commit bb0e5cd49655b41bd3209b100f7a5a74698cbe83
+Subproject commit 367f6bffc158ef1a9055fb876e23447636853aa4
=====================================
libraries/ghc-prim/cbits/atomic.c
=====================================
@@ -279,28 +279,36 @@ extern StgWord hs_cmpxchg8(StgWord x, StgWord old, StgWord new);
StgWord
hs_cmpxchg8(StgWord x, StgWord old, StgWord new)
{
- return __sync_val_compare_and_swap((volatile StgWord8 *) x, (StgWord8) old, (StgWord8) new);
+ StgWord8 expected = (StgWord8) old;
+ __atomic_compare_exchange_n((StgWord8 *) x, &expected, (StgWord8) new, false, __ATOMIC_SEQ_CST, __ATOMIC_SEQ_CST);
+ return expected;
}
extern StgWord hs_cmpxchg16(StgWord x, StgWord old, StgWord new);
StgWord
hs_cmpxchg16(StgWord x, StgWord old, StgWord new)
{
- return __sync_val_compare_and_swap((volatile StgWord16 *) x, (StgWord16) old, (StgWord16) new);
+ StgWord16 expected = (StgWord16) old;
+ __atomic_compare_exchange_n((StgWord16 *) x, &expected, (StgWord16) new, false, __ATOMIC_SEQ_CST, __ATOMIC_SEQ_CST);
+ return expected;
}
extern StgWord hs_cmpxchg32(StgWord x, StgWord old, StgWord new);
StgWord
hs_cmpxchg32(StgWord x, StgWord old, StgWord new)
{
- return __sync_val_compare_and_swap((volatile StgWord32 *) x, (StgWord32) old, (StgWord32) new);
+ StgWord32 expected = (StgWord32) old;
+ __atomic_compare_exchange_n((StgWord32 *) x, &expected, (StgWord32) new, false, __ATOMIC_SEQ_CST, __ATOMIC_SEQ_CST);
+ return expected;
}
extern StgWord64 hs_cmpxchg64(StgWord x, StgWord64 old, StgWord64 new);
StgWord64
hs_cmpxchg64(StgWord x, StgWord64 old, StgWord64 new)
{
- return __sync_val_compare_and_swap((volatile StgWord64 *) x, old, new);
+ StgWord64 expected = (StgWord64) old;
+ __atomic_compare_exchange_n((StgWord64 *) x, &expected, (StgWord64) new, false, __ATOMIC_SEQ_CST, __ATOMIC_SEQ_CST);
+ return expected;
}
// Atomic exchange operations
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/be96d684d0e6bfa6ae0e9425f34048fab2e744d8...7eceeb0cd202af25d296759d5605b00c08f1c658
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/be96d684d0e6bfa6ae0e9425f34048fab2e744d8...7eceeb0cd202af25d296759d5605b00c08f1c658
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230728/12b2abaa/attachment-0001.html>
More information about the ghc-commits
mailing list