[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: Update Match Datatype
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Jul 27 18:12:42 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
31fcd2fa by David Knothe at 2023-07-27T14:12:27-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.
- - - - -
750390d2 by David Binder at 2023-07-27T14:12:30-04:00
Improve documentation for Data.Fixed
- - - - -
be96d684 by Ben Gamari at 2023-07-27T14:12:30-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.
- - - - -
8 changed files:
- 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/ghc-prim/cbits/atomic.c
Changes:
=====================================
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/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/6ff1259815849f0f3abb00a6a9168b4baadc72b5...be96d684d0e6bfa6ae0e9425f34048fab2e744d8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6ff1259815849f0f3abb00a6a9168b4baadc72b5...be96d684d0e6bfa6ae0e9425f34048fab2e744d8
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/20230727/8d5aa75e/attachment-0001.html>
More information about the ghc-commits
mailing list