diff options
| author | Sebastian Graf <sebastian.graf@kit.edu> | 2021-09-10 11:19:28 +0200 |
|---|---|---|
| committer | Sebastian Graf <sebastian.graf@kit.edu> | 2021-09-17 09:36:43 +0200 |
| commit | 92e0918c6f42223ede5524e3cb91f71728331a9a (patch) | |
| tree | f28cc283e76ce110f1afb30330ffc559c066e3f6 | |
| parent | 3fb1afea019422292954785575902c62473e93e3 (diff) | |
| download | haskell-wip/exec-freq.tar.gz | |
Statically estimate execution frequency of CoreAlts (#20378)wip/exec-freq
This patch implements #20378. See `Note [Estimating CoreAlt frequencies]` in the
new module GHC.Core.Opt.ExecFreq for details.
These were the changes:
1. Introduce `newtype Freq = Freq Float` as a type that captures relative
execution frequency and use it as an additional field in `CoreAlt`.
The default when we have no estimate available is `NoFreq`, e.g., NaN.
Otherwise, all `Freq`s of a `Case` should add up to 1.
Then fix up a whole bunch of use sites.
2. Introduce a new enum `Comparison` for the different kinds of comparison
operators (LessThan, GreaterOrEqual, NotEqual, ...). Then make `Compare`
primops also declare what kind of `Comparison` they do. Then introduce a
function `isComparisonApp_maybe` in GHC.Core.Utils that we can use for our
estimates (see below).
3. Write a static analysis pass `estimateAltFreqs`, that annotates `CoreAlt`s
with their relative execution `Freq`. These `Freq`s are determined by
combining the estimates of different branch heuristics, one of which uses
the new `isComparisonApp_maybe`.
The main function `estimateAltFreqs` is currently dead, but that is bound to
change in follow-up MRs.
Fixes #20378.
57 files changed, 924 insertions, 345 deletions
diff --git a/compiler/GHC/Builtin/PrimOps.hs b/compiler/GHC/Builtin/PrimOps.hs index 9bfed53382..6dfd5bb168 100644 --- a/compiler/GHC/Builtin/PrimOps.hs +++ b/compiler/GHC/Builtin/PrimOps.hs @@ -17,7 +17,7 @@ module GHC.Builtin.PrimOps ( primOpOutOfLine, primOpCodeSize, primOpOkForSpeculation, primOpOkForSideEffects, primOpIsCheap, primOpFixity, primOpDocs, - primOpIsDiv, + primOpIsDiv, primOpIsComparison_maybe, getPrimOpResultInfo, isComparisonPrimOp, PrimOpResultInfo(..), @@ -38,7 +38,7 @@ import GHC.Builtin.Names ( gHC_PRIMOPWRAPPERS ) import GHC.Core.TyCon ( TyCon, isPrimTyCon, PrimRep(..) ) import GHC.Core.Type import GHC.Types.RepType ( tyConPrimRep1 ) -import GHC.Types.Basic ( Arity, Boxity(..) ) +import GHC.Types.Basic import GHC.Types.Fixity ( Fixity(..), FixityDirection(..) ) import GHC.Types.SrcLoc ( wiredInSrcSpan ) import GHC.Types.ForeignCall ( CLabelString ) @@ -107,14 +107,15 @@ tagToEnumKey = mkPrimOpIdUnique (primOpTag TagToEnumOp) data PrimOpInfo = Compare OccName -- string :: T -> T -> Int# + !Comparison Type | GenPrimOp OccName -- string :: \/a1..an . T1 -> .. -> Tk -> T [TyVarBinder] [Type] Type -mkCompare :: FastString -> Type -> PrimOpInfo -mkCompare str ty = Compare (mkVarOccFS str) ty +mkCompare :: FastString -> Comparison -> Type -> PrimOpInfo +mkCompare str cmp ty = Compare (mkVarOccFS str) cmp ty mkGenPrimOp :: FastString -> [TyVarBinder] -> [Type] -> Type -> PrimOpInfo mkGenPrimOp str tvs tys ty = GenPrimOp (mkVarOccFS str) tvs tys ty @@ -580,6 +581,10 @@ primOpIsDiv op = case op of _ -> False +primOpIsComparison_maybe :: PrimOp -> Maybe Comparison +primOpIsComparison_maybe op = case primOpInfo op of + Compare _occ cmp _ty -> Just cmp + _ -> Nothing {- ************************************************************************ @@ -616,7 +621,7 @@ primOpCodeSizeForeignCall = 4 primOpType :: PrimOp -> Type -- you may want to use primOpSig instead primOpType op = case primOpInfo op of - Compare _occ ty -> compare_fun_ty ty + Compare _occ _cmp ty -> compare_fun_ty ty GenPrimOp _occ tyvars arg_tys res_ty -> mkForAllTys tyvars (mkVisFunTysMany arg_tys res_ty) @@ -624,12 +629,12 @@ primOpType op primOpResultType :: PrimOp -> Type primOpResultType op = case primOpInfo op of - Compare _occ _ty -> intPrimTy + Compare _occ _cmp _ty -> intPrimTy GenPrimOp _occ _tyvars _arg_tys res_ty -> res_ty primOpOcc :: PrimOp -> OccName primOpOcc op = case primOpInfo op of - Compare occ _ -> occ + Compare occ _ _ -> occ GenPrimOp occ _ _ _ -> occ {- Note [Primop wrappers] @@ -741,7 +746,7 @@ primOpSig op arity = length arg_tys (tyvars, arg_tys, res_ty) = case (primOpInfo op) of - Compare _occ ty -> ([], [ty,ty], intPrimTy) + Compare _cmp _occ ty -> ([], [ty,ty], intPrimTy) GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty ) data PrimOpResultInfo @@ -755,7 +760,7 @@ data PrimOpResultInfo getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo getPrimOpResultInfo op = case (primOpInfo op) of - Compare _ _ -> ReturnsPrim (tyConPrimRep1 intPrimTyCon) + Compare _ _ _ -> ReturnsPrim (tyConPrimRep1 intPrimTyCon) GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep1 tc) | otherwise -> ReturnsAlg tc where diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp index bf3b879449..fe38bd99cc 100644 --- a/compiler/GHC/Builtin/primops.txt.pp +++ b/compiler/GHC/Builtin/primops.txt.pp @@ -190,9 +190,9 @@ defaults -- Note [Levity and representation polymorphic primops] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- In the types of primops in this module, --- +-- -- * The names `a,b,c,s` stand for type variables of kind Type --- +-- -- * The names `v` and `w` stand for levity-polymorphic -- type variables. -- For example: @@ -207,7 +207,7 @@ defaults -- - `v` and `w` end up written as `a` and `b` (respectively) in types, -- which means that one shouldn't write a primop type involving both -- `a` and `v`, nor `b` and `w`. --- +-- -- * The names `o` and `p` stand for representation-polymorphic -- type variables, similarly to `v` and `w` above. For example: -- op :: o -> p -> Int @@ -297,21 +297,16 @@ section "Char#" primtype Char# -primop CharGtOp "gtChar#" Compare Char# -> Char# -> Int# -primop CharGeOp "geChar#" Compare Char# -> Char# -> Int# - -primop CharEqOp "eqChar#" Compare - Char# -> Char# -> Int# +primop CharLtOp "ltChar#" (Compare Lt) Char# -> Char# -> Int# +primop CharLeOp "leChar#" (Compare Le) Char# -> Char# -> Int# +primop CharGtOp "gtChar#" (Compare Gt) Char# -> Char# -> Int# +primop CharGeOp "geChar#" (Compare Ge) Char# -> Char# -> Int# +primop CharEqOp "eqChar#" (Compare Eq) Char# -> Char# -> Int# with commutable = True - -primop CharNeOp "neChar#" Compare - Char# -> Char# -> Int# +primop CharNeOp "neChar#" (Compare Ne) Char# -> Char# -> Int# with commutable = True -primop CharLtOp "ltChar#" Compare Char# -> Char# -> Int# -primop CharLeOp "leChar#" Compare Char# -> Char# -> Int# - -primop OrdOp "ord#" GenPrimOp Char# -> Int# +primop OrdOp "ord#" GenPrimOp Char# -> Int# with code_size = 0 ------------------------------------------------------------------------ @@ -355,12 +350,14 @@ primop Int8SrlOp "uncheckedShiftRLInt8#" GenPrimOp Int8# -> Int# -> Int8# primop Int8ToWord8Op "int8ToWord8#" GenPrimOp Int8# -> Word8# with code_size = 0 -primop Int8EqOp "eqInt8#" Compare Int8# -> Int8# -> Int# -primop Int8GeOp "geInt8#" Compare Int8# -> Int8# -> Int# -primop Int8GtOp "gtInt8#" Compare Int8# -> Int8# -> Int# -primop Int8LeOp "leInt8#" Compare Int8# -> Int8# -> Int# -primop Int8LtOp "ltInt8#" Compare Int8# -> Int8# -> Int# -primop Int8NeOp "neInt8#" Compare Int8# -> Int8# -> Int# +primop Int8LtOp "ltInt8#" (Compare Lt) Int8# -> Int8# -> Int# +primop Int8LeOp "leInt8#" (Compare Le) Int8# -> Int8# -> Int# +primop Int8GtOp "gtInt8#" (Compare Gt) Int8# -> Int8# -> Int# +primop Int8GeOp "geInt8#" (Compare Ge) Int8# -> Int8# -> Int# +primop Int8EqOp "eqInt8#" (Compare Eq) Int8# -> Int8# -> Int# + with commutable = True +primop Int8NeOp "neInt8#" (Compare Ne) Int8# -> Int8# -> Int# + with commutable = True ------------------------------------------------------------------------ section "Word8#" @@ -411,12 +408,14 @@ primop Word8SrlOp "uncheckedShiftRLWord8#" GenPrimOp Word8# -> Int# -> Word8# primop Word8ToInt8Op "word8ToInt8#" GenPrimOp Word8# -> Int8# with code_size = 0 -primop Word8EqOp "eqWord8#" Compare Word8# -> Word8# -> Int# -primop Word8GeOp "geWord8#" Compare Word8# -> Word8# -> Int# -primop Word8GtOp "gtWord8#" Compare Word8# -> Word8# -> Int# -primop Word8LeOp "leWord8#" Compare Word8# -> Word8# -> Int# -primop Word8LtOp "ltWord8#" Compare Word8# -> Word8# -> Int# -primop Word8NeOp "neWord8#" Compare Word8# -> Word8# -> Int# +primop Word8LtOp "ltWord8#" (Compare Lt) Word8# -> Word8# -> Int# +primop Word8LeOp "leWord8#" (Compare Le) Word8# -> Word8# -> Int# +primop Word8GtOp "gtWord8#" (Compare Gt) Word8# -> Word8# -> Int# +primop Word8GeOp "geWord8#" (Compare Ge) Word8# -> Word8# -> Int# +primop Word8EqOp "eqWord8#" (Compare Eq) Word8# -> Word8# -> Int# + with commutable = True +primop Word8NeOp "neWord8#" (Compare Ne) Word8# -> Word8# -> Int# + with commutable = True ------------------------------------------------------------------------ section "Int16#" @@ -459,12 +458,14 @@ primop Int16SrlOp "uncheckedShiftRLInt16#" GenPrimOp Int16# -> Int# -> Int16# primop Int16ToWord16Op "int16ToWord16#" GenPrimOp Int16# -> Word16# with code_size = 0 -primop Int16EqOp "eqInt16#" Compare Int16# -> Int16# -> Int# -primop Int16GeOp "geInt16#" Compare Int16# -> Int16# -> Int# -primop Int16GtOp "gtInt16#" Compare Int16# -> Int16# -> Int# -primop Int16LeOp "leInt16#" Compare Int16# -> Int16# -> Int# -primop Int16LtOp "ltInt16#" Compare Int16# -> Int16# -> Int# -primop Int16NeOp "neInt16#" Compare Int16# -> Int16# -> Int# +primop Int16LtOp "ltInt16#" (Compare Lt) Int16# -> Int16# -> Int# +primop Int16LeOp "leInt16#" (Compare Le) Int16# -> Int16# -> Int# +primop Int16GtOp "gtInt16#" (Compare Gt) Int16# -> Int16# -> Int# +primop Int16GeOp "geInt16#" (Compare Ge) Int16# -> Int16# -> Int# +primop Int16EqOp "eqInt16#" (Compare Eq) Int16# -> Int16# -> Int# + with commutable = True +primop Int16NeOp "neInt16#" (Compare Ne) Int16# -> Int16# -> Int# + with commutable = True ------------------------------------------------------------------------ section "Word16#" @@ -515,12 +516,14 @@ primop Word16SrlOp "uncheckedShiftRLWord16#" GenPrimOp Word16# -> Int# -> Word16 primop Word16ToInt16Op "word16ToInt16#" GenPrimOp Word16# -> Int16# with code_size = 0 -primop Word16EqOp "eqWord16#" Compare Word16# -> Word16# -> Int# -primop Word16GeOp "geWord16#" Compare Word16# -> Word16# -> Int# -primop Word16GtOp "gtWord16#" Compare Word16# -> Word16# -> Int# -primop Word16LeOp "leWord16#" Compare Word16# -> Word16# -> Int# -primop Word16LtOp "ltWord16#" Compare Word16# -> Word16# -> Int# -primop Word16NeOp "neWord16#" Compare Word16# -> Word16# -> Int# +primop Word16LtOp "ltWord16#" (Compare Lt) Word16# -> Word16# -> Int# +primop Word16LeOp "leWord16#" (Compare Le) Word16# -> Word16# -> Int# +primop Word16GtOp "gtWord16#" (Compare Gt) Word16# -> Word16# -> Int# +primop Word16GeOp "geWord16#" (Compare Ge) Word16# -> Word16# -> Int# +primop Word16EqOp "eqWord16#" (Compare Eq) Word16# -> Word16# -> Int# + with commutable = True +primop Word16NeOp "neWord16#" (Compare Ne) Word16# -> Word16# -> Int# + with commutable = True ------------------------------------------------------------------------ section "Int32#" @@ -563,12 +566,14 @@ primop Int32SrlOp "uncheckedShiftRLInt32#" GenPrimOp Int32# -> Int# -> Int32# primop Int32ToWord32Op "int32ToWord32#" GenPrimOp Int32# -> Word32# with code_size = 0 -primop Int32EqOp "eqInt32#" Compare Int32# -> Int32# -> Int# -primop Int32GeOp "geInt32#" Compare Int32# -> Int32# -> Int# -primop Int32GtOp "gtInt32#" Compare Int32# -> Int32# -> Int# -primop Int32LeOp "leInt32#" Compare Int32# -> Int32# -> Int# -primop Int32LtOp "ltInt32#" Compare Int32# -> Int32# -> Int# -primop Int32NeOp "neInt32#" Compare Int32# -> Int32# -> Int# +primop Int32LtOp "ltInt32#" (Compare Lt) Int32# -> Int32# -> Int# +primop Int32LeOp "leInt32#" (Compare Le) Int32# -> Int32# -> Int# +primop Int32GtOp "gtInt32#" (Compare Gt) Int32# -> Int32# -> Int# +primop Int32GeOp "geInt32#" (Compare Ge) Int32# -> Int32# -> Int# +primop Int32EqOp "eqInt32#" (Compare Eq) Int32# -> Int32# -> Int# + with commutable = True +primop Int32NeOp "neInt32#" (Compare Ne) Int32# -> Int32# -> Int# + with commutable = True ------------------------------------------------------------------------ section "Word32#" @@ -619,12 +624,14 @@ primop Word32SrlOp "uncheckedShiftRLWord32#" GenPrimOp Word32# -> Int# -> Word32 primop Word32ToInt32Op "word32ToInt32#" GenPrimOp Word32# -> Int32# with code_size = 0 -primop Word32EqOp "eqWord32#" Compare Word32# -> Word32# -> Int# -primop Word32GeOp "geWord32#" Compare Word32# -> Word32# -> Int# -primop Word32GtOp "gtWord32#" Compare Word32# -> Word32# -> Int# -primop Word32LeOp "leWord32#" Compare Word32# -> Word32# -> Int# -primop Word32LtOp "ltWord32#" Compare Word32# -> Word32# -> Int# -primop Word32NeOp "neWord32#" Compare Word32# -> Word32# -> Int# +primop Word32LtOp "ltWord32#" (Compare Lt) Word32# -> Word32# -> Int# +primop Word32LeOp "leWord32#" (Compare Le) Word32# -> Word32# -> Int# +primop Word32GtOp "gtWord32#" (Compare Gt) Word32# -> Word32# -> Int# +primop Word32GeOp "geWord32#" (Compare Ge) Word32# -> Word32# -> Int# +primop Word32EqOp "eqWord32#" (Compare Eq) Word32# -> Word32# -> Int# + with commutable = True +primop Word32NeOp "neWord32#" (Compare Ne) Word32# -> Word32# -> Int# + with commutable = True ------------------------------------------------------------------------ section "Int64#" @@ -665,12 +672,14 @@ primop Int64SrlOp "uncheckedIShiftRL64#" GenPrimOp Int64# -> Int# -> Int64# primop Int64ToWord64Op "int64ToWord64#" GenPrimOp Int64# -> Word64# with code_size = 0 -primop Int64EqOp "eqInt64#" Compare Int64# -> Int64# -> Int# -primop Int64GeOp "geInt64#" Compare Int64# -> Int64# -> Int# -primop Int64GtOp "gtInt64#" Compare Int64# -> Int64# -> Int# -primop Int64LeOp "leInt64#" Compare Int64# -> Int64# -> Int# -primop Int64LtOp "ltInt64#" Compare Int64# -> Int64# -> Int# -primop Int64NeOp "neInt64#" Compare Int64# -> Int64# -> Int# +primop Int64LtOp "ltInt64#" (Compare Lt) Int64# -> Int64# -> Int# +primop Int64LeOp "leInt64#" (Compare Le) Int64# -> Int64# -> Int# +primop Int64GtOp "gtInt64#" (Compare Gt) Int64# -> Int64# -> Int# +primop Int64GeOp "geInt64#" (Compare Ge) Int64# -> Int64# -> Int# +primop Int64EqOp "eqInt64#" (Compare Eq) Int64# -> Int64# -> Int# + with commutable = True +primop Int64NeOp "neInt64#" (Compare Ne) Int64# -> Int64# -> Int# + with commutable = True ------------------------------------------------------------------------ section "Word64#" @@ -719,12 +728,14 @@ primop Word64SrlOp "uncheckedShiftRL64#" GenPrimOp Word64# -> Int# -> Word64# primop Word64ToInt64Op "word64ToInt64#" GenPrimOp Word64# -> Int64# with code_size = 0 -primop Word64EqOp "eqWord64#" Compare Word64# -> Word64# -> Int# -primop Word64GeOp "geWord64#" Compare Word64# -> Word64# -> Int# -primop Word64GtOp "gtWord64#" Compare Word64# -> Word64# -> Int# -primop Word64LeOp "leWord64#" Compare Word64# -> Word64# -> Int# -primop Word64LtOp "ltWord64#" Compare Word64# -> Word64# -> Int# -primop Word64NeOp "neWord64#" Compare Word64# -> Word64# -> Int# +primop Word64LtOp "ltWord64#" (Compare Lt) Word64# -> Word64# -> Int# +primop Word64LeOp "leWord64#" (Compare Le) Word64# -> Word64# -> Int# +primop Word64GtOp "gtWord64#" (Compare Gt) Word64# -> Word64# -> Int# +primop Word64GeOp "geWord64#" (Compare Ge) Word64# -> Word64# -> Int# +primop Word64EqOp "eqWord64#" (Compare Eq) Word64# -> Word64# -> Int# + with commutable = True +primop Word64NeOp "neWord64#" (Compare Ne) Word64# -> Word64# -> Int# + with commutable = True ------------------------------------------------------------------------ section "Int#" @@ -835,29 +846,27 @@ primop IntSubCOp "subIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) or too small to fit in an {\tt Int#}).} with code_size = 2 -primop IntGtOp ">#" Compare Int# -> Int# -> Int# +primop IntGtOp ">#" (Compare Gt) Int# -> Int# -> Int# with fixity = infix 4 -primop IntGeOp ">=#" Compare Int# -> Int# -> Int# +primop IntGeOp ">=#" (Compare Ge) Int# -> Int# -> Int# with fixity = infix 4 -primop IntEqOp "==#" Compare - Int# -> Int# -> Int# +primop IntEqOp "==#" (Compare Eq) Int# -> Int# -> Int# with commutable = True fixity = infix 4 -primop IntNeOp "/=#" Compare - Int# -> Int# -> Int# +primop IntNeOp "/=#" (Compare Ne) Int# -> Int# -> Int# with commutable = True fixity = infix 4 -primop IntLtOp "<#" Compare Int# -> Int# -> Int# +primop IntLtOp "<#" (Compare Lt) Int# -> Int# -> Int# with fixity = infix 4 -primop IntLeOp "<=#" Compare Int# -> Int# -> Int# +primop IntLeOp "<=#" (Compare Le) Int# -> Int# -> Int# with fixity = infix 4 -primop ChrOp "chr#" GenPrimOp Int# -> Char# +primop ChrOp "chr#" GenPrimOp Int# -> Char# with code_size = 0 primop IntToWordOp "int2Word#" GenPrimOp Int# -> Word# @@ -968,12 +977,14 @@ primop WordSrlOp "uncheckedShiftRL#" GenPrimOp Word# -> Int# -> Word# primop WordToIntOp "word2Int#" GenPrimOp Word# -> Int# with code_size = 0 -primop WordGtOp "gtWord#" Compare Word# -> Word# -> Int# -primop WordGeOp "geWord#" Compare Word# -> Word# -> Int# -primop WordEqOp "eqWord#" Compare Word# -> Word# -> Int# -primop WordNeOp "neWord#" Compare Word# -> Word# -> Int# -primop WordLtOp "ltWord#" Compare Word# -> Word# -> Int# -primop WordLeOp "leWord#" Compare Word# -> Word# -> Int# +primop WordLtOp "ltWord#" (Compare Lt) Word# -> Word# -> Int# +primop WordLeOp "leWord#" (Compare Le) Word# -> Word# -> Int# +primop WordGtOp "gtWord#" (Compare Gt) Word# -> Word# -> Int# +primop WordGeOp "geWord#" (Compare Ge) Word# -> Word# -> Int# +primop WordEqOp "eqWord#" (Compare Eq) Word# -> Word# -> Int# + with commutable = True +primop WordNeOp "neWord#" (Compare Ne) Word# -> Word# -> Int# + with commutable = True primop PopCnt8Op "popCnt8#" GenPrimOp Word# -> Word# {Count the number of set bits in the lower 8 bits of a word.} @@ -1069,26 +1080,24 @@ section "Double#" primtype Double# -primop DoubleGtOp ">##" Compare Double# -> Double# -> Int# +primop DoubleGtOp ">##" (Compare Gt) Double# -> Double# -> Int# with fixity = infix 4 -primop DoubleGeOp ">=##" Compare Double# -> Double# -> Int# +primop DoubleGeOp ">=##" (Compare Ge) Double# -> Double# -> Int# with fixity = infix 4 -primop DoubleEqOp "==##" Compare - Double# -> Double# -> Int# +primop DoubleEqOp "==##" (Compare Eq) Double# -> Double# -> Int# with commutable = True fixity = infix 4 -primop DoubleNeOp "/=##" Compare - Double# -> Double# -> Int# +primop DoubleNeOp "/=##" (Compare Ne) Double# -> Double# -> Int# with commutable = True fixity = infix 4 -primop DoubleLtOp "<##" Compare Double# -> Double# -> Int# +primop DoubleLtOp "<##" (Compare Lt) Double# -> Double# -> Int# with fixity = infix 4 -primop DoubleLeOp "<=##" Compare Double# -> Double# -> Int# +primop DoubleLeOp "<=##" (Compare Le) Double# -> Double# -> Int# with fixity = infix 4 primop DoubleAddOp "+##" GenPrimOp @@ -1235,19 +1244,17 @@ section "Float#" primtype Float# -primop FloatGtOp "gtFloat#" Compare Float# -> Float# -> Int# -primop FloatGeOp "geFloat#" Compare Float# -> Float# -> Int# +primop FloatGtOp "gtFloat#" (Compare Gt) Float# -> Float# -> Int# +primop FloatGeOp "geFloat#" (Compare Ge) Float# -> Float# -> Int# -primop FloatEqOp "eqFloat#" Compare - Float# -> Float# -> Int# +primop FloatEqOp "eqFloat#" (Compare Eq) Float# -> Float# -> Int# with commutable = True -primop FloatNeOp "neFloat#" Compare - Float# -> Float# -> Int# +primop FloatNeOp "neFloat#" (Compare Ne) Float# -> Float# -> Int# with commutable = True -primop FloatLtOp "ltFloat#" Compare Float# -> Float# -> Int# -primop FloatLeOp "leFloat#" Compare Float# -> Float# -> Int# +primop FloatLtOp "ltFloat#" (Compare Lt) Float# -> Float# -> Int# +primop FloatLeOp "leFloat#" (Compare Le) Float# -> Float# -> Int# primop FloatAddOp "plusFloat#" GenPrimOp Float# -> Float# -> Float# @@ -2149,12 +2156,14 @@ primop IntToAddrOp "int2Addr#" GenPrimOp Int# -> Addr# with code_size = 0 deprecated_msg = { This operation is strongly deprecated. } -primop AddrGtOp "gtAddr#" Compare Addr# -> Addr# -> Int# -primop AddrGeOp "geAddr#" Compare Addr# -> Addr# -> Int# -primop AddrEqOp "eqAddr#" Compare Addr# -> Addr# -> Int# -primop AddrNeOp "neAddr#" Compare Addr# -> Addr# -> Int# -primop AddrLtOp "ltAddr#" Compare Addr# -> Addr# -> Int# -primop AddrLeOp "leAddr#" Compare Addr# -> Addr# -> Int# +primop AddrLtOp "ltAddr#" (Compare Lt) Addr# -> Addr# -> Int# +primop AddrLeOp "leAddr#" (Compare Le) Addr# -> Addr# -> Int# +primop AddrGtOp "gtAddr#" (Compare Gt) Addr# -> Addr# -> Int# +primop AddrGeOp "geAddr#" (Compare Ge) Addr# -> Addr# -> Int# +primop AddrEqOp "eqAddr#" (Compare Eq) Addr# -> Addr# -> Int# + with commutable = True +primop AddrNeOp "neAddr#" (Compare Ne) Addr# -> Addr# -> Int# + with commutable = True primop IndexOffAddrOp_Char "indexCharOffAddr#" GenPrimOp Addr# -> Int# -> Char# @@ -3259,29 +3268,29 @@ primop ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- The primop `reallyUnsafePtrEquality#` does a direct pointer -- equality between two (boxed) values. Several things to note: --- +-- -- * It is levity-polymorphic. It works for TYPE (BoxedRep Lifted) and -- TYPE (BoxedRep Unlifted). But not TYPE IntRep, for example. -- This levity-polymorphism comes from the use of the type variables -- "v" and "w". See Note [Levity and representation polymorphic primops] --- +-- -- * It does not evaluate its arguments. The user of the primop is responsible -- for doing so. --- +-- -- * It is hetero-typed; you can compare pointers of different types. -- This is used in various packages such as containers & unordered-containers. --- +-- -- * It is obviously very dangerous, because -- let x = f y in reallyUnsafePtrEquality# x x -- will probably return True, whereas -- reallyUnsafePtrEquality# (f y) (f y) -- will probably return False. ("probably", because it's affected -- by CSE and inlining). --- +-- -- * reallyUnsafePtrEquality# can't fail, but it is marked as such -- to prevent it from floating out. -- See Note [reallyUnsafePtrEquality# can_fail] --- +-- -- The library GHC.Exts provides several less Wild-West functions -- for use in specific cases, namely: -- diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs index ecd9a6ee00..4d78d0599f 100644 --- a/compiler/GHC/Core.hs +++ b/compiler/GHC/Core.hs @@ -267,14 +267,15 @@ data Expr b -- Only 'Arg' should contain a 'Type' at top level, general 'Expr' should not type Arg b = Expr b --- | A case split alternative. Consists of the constructor leading to the alternative, --- the variables bound from the constructor, and the expression to be executed given that binding. --- The default alternative is @(DEFAULT, [], rhs)@ +-- | A case split alternative. Consists of the constructor leading to the +-- alternative, a static estimate for how often this alternative is taken, the +-- variables bound from the constructor, and the expression to be executed given +-- that binding. The default alternative is @('DEFAULT', 'NoFreq', [], rhs)@. -- If you edit this type, you may need to update the GHC formalism -- See Note [GHC Formalism] in GHC.Core.Lint data Alt b - = Alt AltCon [b] (Expr b) + = Alt AltCon !Freq [b] (Expr b) deriving (Data) -- | A case alternative constructor (i.e. pattern match) @@ -1578,7 +1579,7 @@ instance Outputable AltCon where ppr DEFAULT = text "__DEFAULT" cmpAlt :: Alt a -> Alt a -> Ordering -cmpAlt (Alt con1 _ _) (Alt con2 _ _) = con1 `cmpAltCon` con2 +cmpAlt (Alt con1 _ _ _) (Alt con2 _ _ _) = con1 `cmpAltCon` con2 ltAlt :: Alt a -> Alt a -> Bool ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT @@ -1679,7 +1680,7 @@ deTagBind (NonRec (TB b _) rhs) = NonRec b (deTagExpr rhs) deTagBind (Rec prs) = Rec [(b, deTagExpr rhs) | (TB b _, rhs) <- prs] deTagAlt :: TaggedAlt t -> CoreAlt -deTagAlt (Alt con bndrs rhs) = Alt con [b | TB b _ <- bndrs] (deTagExpr rhs) +deTagAlt (Alt con freq bndrs rhs) = Alt con freq [b | TB b _ <- bndrs] (deTagExpr rhs) {- ************************************************************************ @@ -1879,7 +1880,7 @@ rhssOfBind (NonRec _ rhs) = [rhs] rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs] rhssOfAlts :: [Alt b] -> [Expr b] -rhssOfAlts alts = [e | Alt _ _ e <- alts] +rhssOfAlts alts = [e | Alt _ _ _ e <- alts] -- | Collapse all the bindings in the supplied groups into a single -- list of lhs\/rhs pairs suitable for binding in a 'Rec' binding group @@ -2042,7 +2043,7 @@ data AnnExpr' bndr annot | AnnCoercion Coercion -- | A clone of the 'Alt' type but allowing annotation at every tree node -data AnnAlt bndr annot = AnnAlt AltCon [bndr] (AnnExpr bndr annot) +data AnnAlt bndr annot = AnnAlt AltCon !Freq [bndr] (AnnExpr bndr annot) -- | A clone of the 'Bind' type but allowing annotation at every tree node data AnnBind bndr annot @@ -2087,7 +2088,7 @@ deAnnotate' (AnnCase scrut v t alts) = Case (deAnnotate scrut) v t (map deAnnAlt alts) deAnnAlt :: AnnAlt bndr annot -> Alt bndr -deAnnAlt (AnnAlt con args rhs) = Alt con args (deAnnotate rhs) +deAnnAlt (AnnAlt con freq args rhs) = Alt con freq args (deAnnotate rhs) deAnnBind :: AnnBind b annot -> Bind b deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs) diff --git a/compiler/GHC/Core/FVs.hs b/compiler/GHC/Core/FVs.hs index e4663ad075..89ca7319f7 100644 --- a/compiler/GHC/Core/FVs.hs +++ b/compiler/GHC/Core/FVs.hs @@ -267,7 +267,7 @@ expr_fvs (Case scrut bndr ty alts) fv_cand in_scope acc = (expr_fvs scrut `unionFV` tyCoFVsOfType ty `unionFV` addBndr bndr (mapUnionFV alt_fvs alts)) fv_cand in_scope acc where - alt_fvs (Alt _ bndrs rhs) = addBndrs bndrs (expr_fvs rhs) + alt_fvs (Alt _ _ bndrs rhs) = addBndrs bndrs (expr_fvs rhs) expr_fvs (Let (NonRec bndr rhs) body) fv_cand in_scope acc = (rhs_fvs (bndr, rhs) `unionFV` addBndr bndr (expr_fvs body)) @@ -325,7 +325,7 @@ exprOrphNames e go (Case e _ ty as) = go e `unionNameSet` orphNamesOfType ty `unionNameSet` unionNameSets (map go_alt as) - go_alt (Alt _ _ r) = go r + go_alt (Alt _ _ _ r) = go r -- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details exprsOrphNames :: [CoreExpr] -> NameSet @@ -756,10 +756,10 @@ freeVars = go (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts alts_fvs = unionFVss alts_fvs_s - fv_alt (Alt con args rhs) = (delBindersFV args (freeVarsOf rhs2), - (AnnAlt con args rhs2)) - where - rhs2 = go rhs + fv_alt (Alt con freq args rhs) = (delBindersFV args (freeVarsOf rhs2), + (AnnAlt con freq args rhs2)) + where + rhs2 = go rhs go (Let bind body) = (bind_fvs, AnnLet bind2 body2) diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index 3b3a7232c0..ddad37bc6e 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -1320,8 +1320,8 @@ lintCaseExpr scrut var alt_ty alts = -- if there are any literal alternatives -- See GHC.Core Note [Case expression invariants] item (5) -- See Note [Rules for floating-point comparisons] in GHC.Core.Opt.ConstantFold - ; let isLitPat (Alt (LitAlt _) _ _) = True - isLitPat _ = False + ; let isLitPat (Alt (LitAlt _) _ _ _) = True + isLitPat _ = False ; checkL (not $ isFloatingTy scrut_ty && any isLitPat alts) (text "Lint warning: Scrutinising floating-point expression with literal pattern in case analysis (see #9238)." $$ text "scrut" <+> ppr scrut) @@ -1384,8 +1384,8 @@ checkCaseAlts e ty alts = increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest increasing_tag _ = True - non_deflt (Alt DEFAULT _ _) = False - non_deflt _ = True + non_deflt (Alt DEFAULT _ _ _) = False + non_deflt _ = True is_infinite_ty = case tyConAppTyCon_maybe ty of Nothing -> False @@ -1406,11 +1406,11 @@ lintCoreAlt :: Var -- Case binder -> LintM UsageEnv -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] -lintCoreAlt _ _ _ alt_ty (Alt DEFAULT args rhs) = +lintCoreAlt _ _ _ alt_ty (Alt DEFAULT _freq args rhs) = do { lintL (null args) (mkDefaultArgsMsg args) ; lintAltExpr rhs alt_ty } -lintCoreAlt _case_bndr scrut_ty _ alt_ty (Alt (LitAlt lit) args rhs) +lintCoreAlt _case_bndr scrut_ty _ alt_ty (Alt (LitAlt lit) _freq args rhs) | litIsLifted lit = failWithL integerScrutinisedMsg | otherwise @@ -1420,7 +1420,7 @@ lintCoreAlt _case_bndr scrut_ty _ alt_ty (Alt (LitAlt lit) args rhs) where lit_ty = literalType lit -lintCoreAlt case_bndr scrut_ty _scrut_mult alt_ty alt@(Alt (DataAlt con) args rhs) +lintCoreAlt case_bndr scrut_ty _scrut_mult alt_ty alt@(Alt (DataAlt con) _freq args rhs) | isNewTyCon (dataConTyCon con) = zeroUE <$ addErrL (mkNewTyDataConAltMsg scrut_ty alt) | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty @@ -2969,10 +2969,10 @@ dumpLoc (BodyOfLetRec bs@(_:_)) dumpLoc (AnExpr e) = (noSrcLoc, text "In the expression:" <+> ppr e) -dumpLoc (CaseAlt (Alt con args _)) +dumpLoc (CaseAlt (Alt con _ args _)) = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args)) -dumpLoc (CasePat (Alt con args _)) +dumpLoc (CasePat (Alt con _ args _)) = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args)) dumpLoc (CaseTy scrut) diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs index d7a78b5888..029bf7c90a 100644 --- a/compiler/GHC/Core/Make.hs +++ b/compiler/GHC/Core/Make.hs @@ -225,7 +225,7 @@ mkWildCase scrut (Scaled w scrut_ty) res_ty alts -- | Build a strict application (case e2 of x -> e1 x) mkStrictApp :: CoreExpr -> CoreExpr -> Scaled Type -> Type -> CoreExpr mkStrictApp fun arg (Scaled w arg_ty) res_ty - = Case arg arg_id res_ty [Alt DEFAULT [] (App fun (Var arg_id))] + = Case arg arg_id res_ty [Alt DEFAULT NoFreq [] (App fun (Var arg_id))] -- mkDefaultCase looks attractive here, and would be sound. -- But it uses (exprType alt_rhs) to compute the result type, -- whereas here we already know that the result type is res_ty @@ -248,8 +248,8 @@ mkIfThenElse :: CoreExpr -- ^ guard mkIfThenElse guard then_expr else_expr -- Not going to be refining, so okay to take the type of the "then" clause = mkWildCase guard (linear boolTy) (exprType then_expr) - [ Alt (DataAlt falseDataCon) [] else_expr, -- Increasing order of tag! - Alt (DataAlt trueDataCon) [] then_expr ] + [ Alt (DataAlt falseDataCon) NoFreq [] else_expr, -- Increasing order of tag! + Alt (DataAlt trueDataCon) NoFreq [] then_expr ] castBottomExpr :: CoreExpr -> Type -> CoreExpr -- (castBottomExpr e ty), assuming that 'e' diverges, @@ -560,7 +560,7 @@ mkSmallTupleSelector vars the_var scrut_var scrut mkSmallTupleSelector1 vars the_var scrut_var scrut = assert (notNull vars) $ Case scrut scrut_var (idType the_var) - [Alt (DataAlt (tupleDataCon Boxed (length vars))) vars (Var the_var)] + [Alt (DataAlt (tupleDataCon Boxed (length vars))) NoFreq vars (Var the_var)] -- | A generalization of 'mkTupleSelector', allowing the body -- of the case to be an arbitrary expression. @@ -614,7 +614,7 @@ mkSmallTupleCase [var] body _scrut_var scrut mkSmallTupleCase vars body scrut_var scrut -- One branch no refinement? = Case scrut scrut_var (exprType body) - [Alt (DataAlt (tupleDataCon Boxed (length vars))) vars body] + [Alt (DataAlt (tupleDataCon Boxed (length vars))) NoFreq vars body] {- ************************************************************************ diff --git a/compiler/GHC/Core/Map/Expr.hs b/compiler/GHC/Core/Map/Expr.hs index 9cff1d33a1..cc5bce1f52 100644 --- a/compiler/GHC/Core/Map/Expr.hs +++ b/compiler/GHC/Core/Map/Expr.hs @@ -348,11 +348,11 @@ instance TrieMap AltMap where instance Eq (DeBruijn CoreAlt) where D env1 a1 == D env2 a2 = go a1 a2 where - go (Alt DEFAULT _ rhs1) (Alt DEFAULT _ rhs2) + go (Alt DEFAULT _ _ rhs1) (Alt DEFAULT _ _ rhs2) = D env1 rhs1 == D env2 rhs2 - go (Alt (LitAlt lit1) _ rhs1) (Alt (LitAlt lit2) _ rhs2) + go (Alt (LitAlt lit1) _ _ rhs1) (Alt (LitAlt lit2) _ _ rhs2) = lit1 == lit2 && D env1 rhs1 == D env2 rhs2 - go (Alt (DataAlt dc1) bs1 rhs1) (Alt (DataAlt dc2) bs2 rhs2) + go (Alt (DataAlt dc1) _ bs1 rhs1) (Alt (DataAlt dc2) _ bs2 rhs2) = dc1 == dc2 && D (extendCMEs env1 bs1) rhs1 == D (extendCMEs env2 bs2) rhs2 go _ _ = False @@ -370,17 +370,17 @@ ftA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit }) , am_lit = mapTM (filterTM f) alit } lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a -lkA env (Alt DEFAULT _ rhs) = am_deflt >.> lkG (D env rhs) -lkA env (Alt (LitAlt lit) _ rhs) = am_lit >.> lookupTM lit >=> lkG (D env rhs) -lkA env (Alt (DataAlt dc) bs rhs) = am_data >.> lkDNamed dc +lkA env (Alt DEFAULT _ _ rhs) = am_deflt >.> lkG (D env rhs) +lkA env (Alt (LitAlt lit) _ _ rhs) = am_lit >.> lookupTM lit >=> lkG (D env rhs) +lkA env (Alt (DataAlt dc) _ bs rhs) = am_data >.> lkDNamed dc >=> lkG (D (extendCMEs env bs) rhs) xtA :: CmEnv -> CoreAlt -> XT a -> AltMap a -> AltMap a -xtA env (Alt DEFAULT _ rhs) f m = +xtA env (Alt DEFAULT _ _ rhs) f m = m { am_deflt = am_deflt m |> xtG (D env rhs) f } -xtA env (Alt (LitAlt l) _ rhs) f m = +xtA env (Alt (LitAlt l) _ _ rhs) f m = m { am_lit = am_lit m |> alterTM l |>> xtG (D env rhs) f } -xtA env (Alt (DataAlt d) bs rhs) f m = +xtA env (Alt (DataAlt d) _ bs rhs) f m = m { am_data = am_data m |> xtDNamed d |>> xtG (D (extendCMEs env bs) rhs) f } diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs index f25d04e0ed..815c4935ec 100644 --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -1058,7 +1058,7 @@ arityType env (Case scrut bndr _ alts) = takeWhileOneShot alts_type -- evaluation of the scrutinee in where env' = delInScope env bndr - arity_type_alt (Alt _con bndrs rhs) = arityType (delInScopeList env' bndrs) rhs + arity_type_alt (Alt _con _freq bndrs rhs) = arityType (delInScopeList env' bndrs) rhs alts_type = foldr1 andArityType (map arity_type_alt alts) arityType env (Let (NonRec j rhs) body) @@ -1503,7 +1503,7 @@ etaInfoApp in_scope expr eis (subst1, b1) = Core.substBndr subst b alts' = map subst_alt alts ty' = etaInfoAppTy (Core.substTy subst ty) eis - subst_alt (Alt con bs rhs) = Alt con bs' (go subst2 rhs eis) + subst_alt (Alt con freq bs rhs) = Alt con freq bs' (go subst2 rhs eis) where (subst2,bs') = Core.substBndrs subst1 bs diff --git a/compiler/GHC/Core/Opt/CSE.hs b/compiler/GHC/Core/Opt/CSE.hs index 6b5a12e9f1..172f8cd609 100644 --- a/compiler/GHC/Core/Opt/CSE.hs +++ b/compiler/GHC/Core/Opt/CSE.hs @@ -672,15 +672,15 @@ cseCase env scrut bndr ty alts arg_tys = tyConAppArgs (idType bndr3) -- See Note [CSE for case alternatives] - cse_alt (Alt (DataAlt con) args rhs) - = Alt (DataAlt con) args' (tryForCSE new_env rhs) + cse_alt (Alt (DataAlt con) freq args rhs) + = Alt (DataAlt con) freq args' (tryForCSE new_env rhs) where (env', args') = addBinders alt_env args new_env = extendCSEnv env' con_expr con_target con_expr = mkAltExpr (DataAlt con) args' arg_tys - cse_alt (Alt con args rhs) - = Alt con args' (tryForCSE env' rhs) + cse_alt (Alt con freq args rhs) + = Alt con freq args' (tryForCSE env' rhs) where (env', args') = addBinders alt_env args @@ -688,11 +688,11 @@ combineAlts :: CSEnv -> [OutAlt] -> [OutAlt] -- See Note [Combine case alternatives] combineAlts env alts | (Just alt1, rest_alts) <- find_bndr_free_alt alts - , Alt _ bndrs1 rhs1 <- alt1 + , Alt _ _ bndrs1 rhs1 <- alt1 , let filtered_alts = filterOut (identical_alt rhs1) rest_alts , not (equalLength rest_alts filtered_alts) = assertPpr (null bndrs1) (ppr alts) $ - Alt DEFAULT [] rhs1 : filtered_alts + Alt DEFAULT NoFreq [] rhs1 : filtered_alts | otherwise = alts @@ -704,12 +704,12 @@ combineAlts env alts -- See Note [Combine case alts: awkward corner] find_bndr_free_alt [] = (Nothing, []) - find_bndr_free_alt (alt@(Alt _ bndrs _) : alts) + find_bndr_free_alt (alt@(Alt _ _ bndrs _) : alts) | null bndrs = (Just alt, alts) | otherwise = case find_bndr_free_alt alts of (mb_bf, alts) -> (mb_bf, alt:alts) - identical_alt rhs1 (Alt _ _ rhs) = eqExpr in_scope rhs1 rhs + identical_alt rhs1 (Alt _ _ _ rhs) = eqExpr in_scope rhs1 rhs -- Even if this alt has binders, they will have been cloned -- If any of these binders are mentioned in 'rhs', then -- 'rhs' won't compare equal to 'rhs1' (which is from an diff --git a/compiler/GHC/Core/Opt/CallArity.hs b/compiler/GHC/Core/Opt/CallArity.hs index d8d9749941..7a52e0c499 100644 --- a/compiler/GHC/Core/Opt/CallArity.hs +++ b/compiler/GHC/Core/Opt/CallArity.hs @@ -525,8 +525,8 @@ callArityAnal arity int (Case scrut bndr ty alts) (final_ae, Case scrut' bndr ty alts') where (alt_aes, alts') = unzip $ map go alts - go (Alt dc bndrs e) = let (ae, e') = callArityAnal arity (int `delVarSetList` (bndr:bndrs)) e - in (ae, Alt dc bndrs e') + go (Alt dc f bndrs e) = let (ae, e') = callArityAnal arity (int `delVarSetList` (bndr:bndrs)) e + in (ae, Alt dc f bndrs e') alt_ae = lubRess alt_aes (scrut_ae, scrut') = callArityAnal 0 int scrut final_ae = scrut_ae `both` alt_ae diff --git a/compiler/GHC/Core/Opt/CallerCC.hs b/compiler/GHC/Core/Opt/CallerCC.hs index 3c47da66af..d20b41d91b 100644 --- a/compiler/GHC/Core/Opt/CallerCC.hs +++ b/compiler/GHC/Core/Opt/CallerCC.hs @@ -94,7 +94,7 @@ doExpr env (Let b rhs) = Let <$> doBind env b <*> doExpr env rhs doExpr env (Case scrut b ty alts) = Case <$> doExpr env scrut <*> pure b <*> pure ty <*> mapM doAlt alts where - doAlt (Alt con bs rhs) = Alt con bs <$> doExpr env rhs + doAlt (Alt con freq bs rhs) = Alt con freq bs <$> doExpr env rhs doExpr env (Cast expr co) = Cast <$> doExpr env expr <*> pure co doExpr env (Tick t e) = Tick t <$> doExpr env e doExpr _env e@(Type _) = pure e diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs index e4d04c3548..56fba28178 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/compiler/GHC/Core/Opt/ConstantFold.hs @@ -1084,8 +1084,8 @@ litEq is_eq = msum do_lit_eq platform lit expr = do guard (not (litIsLifted lit)) return (mkWildCase expr (unrestricted $ literalType lit) intPrimTy - [ Alt DEFAULT [] val_if_neq - , Alt (LitAlt lit) [] val_if_eq]) + [ Alt DEFAULT NoFreq [] val_if_neq + , Alt (LitAlt lit) NoFreq [] val_if_eq]) where val_if_eq | is_eq = trueValInt platform | otherwise = falseValInt platform @@ -1102,8 +1102,6 @@ boundsCmp op = do [a, b] <- getArgs liftMaybe $ mkRuleFn platform op a b -data Comparison = Gt | Ge | Lt | Le - mkRuleFn :: Platform -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr mkRuleFn platform Gt (Lit lit) _ | isMinBound platform lit = Just $ falseValInt platform mkRuleFn platform Le (Lit lit) _ | isMinBound platform lit = Just $ trueValInt platform diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs index f3ae2c0b43..2247751990 100644 --- a/compiler/GHC/Core/Opt/CprAnal.hs +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -204,8 +204,8 @@ cprAnalAlt -> CprType -- ^ CPR type of the scrutinee -> Alt Var -- ^ current alternative -> (CprType, Alt Var) -cprAnalAlt env scrut_ty (Alt con bndrs rhs) - = (rhs_ty, Alt con bndrs rhs') +cprAnalAlt env scrut_ty (Alt con freq bndrs rhs) + = (rhs_ty, Alt con freq bndrs rhs') where env_alt | DataAlt dc <- con diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index 5f209701a9..6f03fbea96 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -419,10 +419,10 @@ dmdAnal' env dmd (Lam var body) in WithDmdType new_dmd_type (Lam var' body') -dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs]) +dmdAnal' env dmd (Case scrut case_bndr ty [Alt con freq bndrs rhs]) -- Only one alternative. -- If it's a DataAlt, it should be the only constructor of the type. - | is_single_data_alt alt + | is_single_data_alt con = let WithDmdType rhs_ty rhs' = dmdAnal env dmd rhs WithDmdType alt_ty1 dmds = findBndrsDmds env rhs_ty bndrs @@ -434,7 +434,7 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs]) -- FORCE the result, otherwise thunks will end up retaining the -- whole DmdEnv !(!bndrs', !scrut_sd) - | DataAlt _ <- alt + | DataAlt _ <- con , id_dmds <- addCaseBndrDmd case_bndr_sd dmds -- See Note [Demand on scrutinee of a product case] = let !new_info = setBndrsDemandInfo bndrs id_dmds @@ -463,7 +463,7 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs]) -- , text "scrut_ty" <+> ppr scrut_ty -- , text "alt_ty" <+> ppr alt_ty2 -- , text "res_ty" <+> ppr res_ty ]) $ - WithDmdType res_ty (Case scrut' case_bndr' ty [Alt alt bndrs' rhs']) + WithDmdType res_ty (Case scrut' case_bndr' ty [Alt con freq bndrs' rhs']) where is_single_data_alt (DataAlt dc) = isJust $ tyConSingleAlgDataCon_maybe $ dataConTyCon dc is_single_data_alt _ = True @@ -545,7 +545,7 @@ forcesRealWorld fam_envs ty = False dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Var -> WithDmdType (Alt Var) -dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) +dmdAnalSumAlt env dmd case_bndr (Alt con freq bndrs rhs) | WithDmdType rhs_ty rhs' <- dmdAnal env dmd rhs , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr @@ -553,7 +553,7 @@ dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) id_dmds = addCaseBndrDmd case_bndr_sd dmds -- Do not put a thunk into the Alt !new_ids = setBndrsDemandInfo bndrs id_dmds - = WithDmdType alt_ty (Alt con new_ids rhs') + = WithDmdType alt_ty (Alt con freq new_ids rhs') {- Note [Analysing with absent demand] diff --git a/compiler/GHC/Core/Opt/ExecFreq.hs b/compiler/GHC/Core/Opt/ExecFreq.hs new file mode 100644 index 0000000000..6bd65bf72d --- /dev/null +++ b/compiler/GHC/Core/Opt/ExecFreq.hs @@ -0,0 +1,482 @@ +-- | Analyses concerned with how often some part of an expression is executed. +-- +-- Currently, we only estimate relative frequency of case alternatives, but we +-- may estimate static profiles for whole functions in the future (taking into +-- account loops, etc.). The basic ideas are borrowed from the imperative world: +-- +-- [1] Branch prediction for free. Ball and Larus, 1993. +-- https://dl.acm.org/doi/abs/10.1145/173262.155119 +-- +-- [2] Static branch frequency and program profile analysis. Wu and Larus, 1994. +-- https://dl.acm.org/doi/10.1145/192724.192725 +-- +-- See Note [Estimating CoreAlt frequencies] for implementation details. +-- +module GHC.Core.Opt.ExecFreq + ( estimateAltFreqs + ) +where + +import GHC.Prelude +import GHC.Core +import GHC.Core.Utils +import GHC.Core.Ppr +import GHC.Types.Basic +import GHC.Types.Literal +import GHC.Types.Id +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Builtin.PrimOps +import GHC.Utils.Misc +import GHC.Data.Maybe +import GHC.Utils.Outputable +import GHC.Utils.Trace +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.List (sortOn, groupBy, nub) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty + +{- Note [Estimating CoreAlt frequencies] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is very useful for a compiler to know when one case alternative is taken +much more often than another. For example, consider + + sum n = case n of + 0 -> 0 :: Int + _ -> n + sum (n-1) + +Here, for the vast majority of inputs, control flow enters the second +alternative, because + + 1. Most Ints aren't equal to 0 + 2. The second alternative contains a recursive call, indicating a loop of some + sort. Most loops loop more often than once, hence it's a plausible estimate + that we will not yet exit it. + +Equipped with that knowledge, the compiler can optimise 'sum' favoring +transformations that improve the second branch, even if that means the first +branch gets a bit slower. Some examples: + + * The Simplifier could decide not to inline in the cold branch, having more + code size to spend inlining in the second branch. + * The first branch may need some value boxed, but the second one doesn't. It + may be more efficient to unbox the value and re-allocate the box in the + first branch. + * Similarly, we could give 'sum' the CPR property, thereby unboxing its result + and destroying the sharing of the (then floated out) 0 CAF. + * We may float out a binding from the second alternative, even if that means + more allocation if we take the first alternative + * (Feel free to add more...) + +How do we know which alternatives are hotter/colder than others? + +This problem has long been solved in the imperative world, where there are +always just 2 alternatives in each branch decision. We'll build on + + [1] Branch prediction for free. Ball and Larus, 1993. + https://dl.acm.org/doi/abs/10.1145/173262.155119 + [2] Static branch frequency and program profile analysis. Wu and Larus, 1994. + https://dl.acm.org/doi/10.1145/192724.192725 + [3] Corpus-based static branch prediction. Calder et al., 1995. + https://dl.acm.org/doi/10.1145/223428.207118 + +[1] comes up with a set of useful branch heuristics and measures their +effectiveness. [2] builds on the branch heuristics of [1] and contributes how to +fuse evidence from different heuristics (implemented as 'fuseHeuristic'). + +We implement a couple of different Heuristics, inspired by [1]: + + 1. Opcode Heuristic (OH) captures intuition like "most Ints aren't equal to a + single constant", but goes a bit beyond that. See 'opcodeHeuristic'. + 2. Loop Branch Heuristic (LBH, see 'loopBranchHeuristic') captures the + intuition that recursive alts are taken more often than non-recursive ones. + 3. Call Heuristic (CH) says that alts with external calls are rather cold. + See 'callHeuristic'. + 4. Store Heuristic (SH) says that alts with stores are cold. We extend this to + general side-effects. See 'storeHeuristic'. + 5. Return Heuristic (RH) says that alts that quickly return are cold. We + interpret this to mean that paths are cold when they don't jump to a + (shared) join point. See 'returnHeuristic'. + +It's a bit questionable if and how (3) to (5) apply to functional programs. +They might give false indications if regarded in isolation, but in concert with +other heuristics, they might be worth it. The occurrence info that is necessary +to support (3) to (5) is a bit complicated to characterise, so they are +deactivated for now. + +Current weights of how much we can trust each individual heuristic are just +rough guesses based on the numbers reported in [1] and [2]. We should eventually +derive these weights by profiling information, training our machine learning +algorithm, so to speak. That is exactly what [3] does. +-} + +{- +************************************************************************ +* * + Env+Usage: Gathering occurrence info +* * +************************************************************************ +-} + +data Env = E + { e_level :: !Int + , e_rec_bndrs :: !(IdEnv Int) + } + +emptyEnv :: Env +emptyEnv = E { e_level = 0, e_rec_bndrs = emptyVarEnv } + +delBndrEnv :: Env -> Id -> Env +delBndrEnv env bndr = delBndrsEnv env [bndr] + +delBndrsEnv :: Env -> [Id] -> Env +delBndrsEnv env bndrs + = env { e_rec_bndrs = delVarEnvList (e_rec_bndrs env) bndrs } + +enterRec :: Env -> [Id] -> Env +enterRec env bndrs + = env { e_level = e_level env + 1 + , e_rec_bndrs = extendVarEnvList (e_rec_bndrs env) pairs } + where + pairs = zip bndrs (repeat (e_level env)) + +data Usage = U + { u_uses :: !IdSet + , u_lvls :: !(IntMap IdSet) + , u_exit_path :: !Bool + , u_ext_calls :: !Bool + , u_side_effect :: !Bool + } + +instance Outputable Usage where + ppr (U uses lvls exit_path ext_calls side_effect) = char 'U' <> braces (fcat + [ text "uses=", ppr uses + , comma, text "lvls=", ppr lvls + , if exit_path then comma <> text "exit_path" else empty + , if ext_calls then comma <> text "ext_calls" else empty + , if side_effect then comma <> text "side_effect" else empty + ]) + +emptyUsage :: Usage +emptyUsage = U + { u_uses = emptyVarSet + , u_lvls = IntMap.empty + , u_exit_path = False + , u_ext_calls = False + , u_side_effect = False } + +singleUsage :: Env -> Id -> Usage +singleUsage env b + | isGlobalId b, idArity b > 0, not $ isPrimOpId b, not $ isDataConWorkId b, not $ isDataConWrapId b + = emptyUsage { u_ext_calls = True } + | Just op <- isPrimOpId_maybe b, not $ primOpOkForSideEffects op + = emptyUsage { u_side_effect = True } + | isLocalId b + = emptyUsage { u_lvls = lvls, u_uses = unitVarSet b, u_exit_path = not (isJoinId b) && idArity b == 0 } + | otherwise = emptyUsage + where + lvls = case lookupVarEnv (e_rec_bndrs env) b of + Just lvl -> IntMap.singleton lvl (unitVarSet b) + Nothing -> IntMap.empty + +leaveScope :: Usage -> [Id] -> Usage +leaveScope u bndrs + = u { u_uses = delVarSetList (u_uses u) bndrs } + +leaveRec :: Int -> Usage -> [Id] -> Usage +leaveRec lvl u bndrs + = u { u_uses = delVarSetList (u_uses u) bndrs + , u_lvls = IntMap.alter f lvl (u_lvls u) } + where + f Nothing = Nothing + f (Just set) + | let set' = delVarSetList set bndrs + , not $ isEmptyVarSet set' + = Just set' + | otherwise + = Nothing + +lubUsages :: [Usage] -> Usage +lubUsages = foldl' f emptyUsage{u_exit_path = True} + where + f u1 u2 = U { u_uses = unionVarSet (u_uses u1) (u_uses u2) + , u_lvls = IntMap.unionWith unionVarSet (u_lvls u1) (u_lvls u2) + , u_exit_path = u_exit_path u1 && u_exit_path u2 + , u_ext_calls = u_ext_calls u1 || u_ext_calls u2 + , u_side_effect = u_side_effect u1 || u_side_effect u2 } + +thenUsage :: Usage -> Usage -> Usage +thenUsage u1 u2 = U { u_uses = unionVarSet (u_uses u1) (u_uses u2) + , u_lvls = IntMap.unionWith unionVarSet (u_lvls u1) (u_lvls u2) + , u_exit_path = u_exit_path u2 -- IMPORTANT difference to lub + , u_ext_calls = u_ext_calls u1 || u_ext_calls u2 + , u_side_effect = u_side_effect u1 || u_side_effect u2 } + +{- +************************************************************************ +* * + Main analysis traversal +* * +************************************************************************ +-} + +-- | See Note [Estimating CoreAlt frequencies]. +estimateAltFreqs :: CoreProgram -> CoreProgram +estimateAltFreqs = go emptyEnv + where + go _ [] = [] + go env (b:bs) = b' : go env' bs + where + (env', _, b') = analBind env b + +analBind :: Env -> CoreBind -> (Env, Usage, CoreBind) +analBind env (NonRec b rhs) = (delBndrEnv env b, usg, NonRec b rhs') + where + (usg, rhs') = analExpr env rhs +analBind env (Rec pairs) = (env', usg', Rec pairs') + where + (bs, rhss) = unzip pairs + env' = enterRec env bs + (usgs, rhss') = mapAndUnzip (analExpr env') rhss + pairs' = zip bs rhss' + usg' = lubUsages usgs + +analExpr :: Env -> CoreExpr -> (Usage, CoreExpr) +analExpr env e = case e of + Coercion{} -> (emptyUsage, e) + Type{} -> (emptyUsage, e) + Lit{} -> (emptyUsage, e) + (Var v) -> (singleUsage env v, e) + Cast e co | (usg, e') <- analExpr env e -> (usg, Cast e' co) + Tick t e | (usg, e') <- analExpr env e -> (usg, Tick t e') + Lam b e | (usg, e') <- analExpr (delBndrEnv env b) e -> (leaveScope usg [b], Lam b e') + App f a + | (usg_f, f') <- analExpr env f + , (usg_a, a') <- analExpr env a + -> (usg_a `thenUsage` usg_f, App f' a') + Let bind e + | (env', usg_bs, bind') <- analBind env bind + , (usg_e, e') <- analExpr env' e + , let leave = case bind of Rec{} -> leaveRec (e_level env); _ -> leaveScope + -> (leave (usg_bs `thenUsage` usg_e) (bindersOf bind), Let bind' e') + Case scrut b ty alts + | (usg_scrut, scrut') <- analExpr env scrut + , let usg_w_alts = map (analAlt (delBndrEnv env b)) alts + , (usg_alts, alts') <- applyHeuristic heuristic scrut usg_w_alts + -> (leaveScope (usg_scrut `thenUsage` lubUsages usg_alts) [b], Case scrut' b ty alts') + where + -- heuristic = traceHeuristic "combined" $ fuseHeuristics $ NonEmpty.fromList + heuristic = fuseHeuristics $ NonEmpty.fromList + [ loopBranchHeuristic + , opcodeHeuristic + , ignoreHeuristic $ traceHeuristic "CH" $ callHeuristic + , ignoreHeuristic $ traceHeuristic "SH" $ storeHeuristic + , ignoreHeuristic $ traceHeuristic "RH" $ returnHeuristic + ] + +analAlt :: Env -> CoreAlt -> (Usage, CoreAlt) +analAlt env (Alt con freq bs rhs) = (leaveScope usg bs, Alt con freq bs rhs') + where + (usg, rhs') = analExpr (delBndrsEnv env bs) rhs + +{- +************************************************************************ +* * + Branch heuristics +* * +************************************************************************ +-} + +-- | A Branch/Alt prediction heuristic. See Note [Estimating CoreAlt frequencies]. +type Heuristic = CoreExpr -> [(AltCon, [Var], Usage)] -> Maybe [Freq] + +-- | Associative. So 'Heuristic' is a Semigroup via this operation. +-- This operation is Dempster's rule of combination for the very narrow use case +-- of ours, where all masses of non-singleton sets are 0. +-- +-- See Note [Estimating CoreAlt frequencies]. +fuseHeuristic :: Heuristic -> Heuristic -> Heuristic +fuseHeuristic a b scrut alts = a scrut alts <+> b scrut alts + where + f1 <+> Nothing = f1 + Nothing <+> f2 = f2 + Just f1 <+> Just f2 = Just $! normaliseFreqs joint -- Dampster's rule of combination + where + joint = zipWithEqual "fuseHeuristic" (*) f1 f2 + +fuseHeuristics :: NonEmpty Heuristic -> Heuristic +fuseHeuristics = foldr1 fuseHeuristic + +traceHeuristic :: String -> Heuristic -> Heuristic +traceHeuristic descr heur scrut alts = pprTrace descr (pprCoreExpr scrut $$ ppr alts $$ ppr freqs) freqs + where + freqs = heur scrut alts +_ = traceHeuristic -- suppress unused warning + +ignoreHeuristic :: Heuristic -> Heuristic +ignoreHeuristic _heur _scrut _alts = Nothing + +applyHeuristic :: Heuristic -> CoreExpr -> [(Usage, CoreAlt)] -> ([Usage], [CoreAlt]) +applyHeuristic heur scrut usg_w_alts = (usgs, alts') + where + heur_alts = [ (con, bs, usg) | (usg, Alt con _ bs _) <- usg_w_alts ] + freqs = heur scrut heur_alts `orElse` uniformFreqs (length alts) + (usgs, alts) = unzip usg_w_alts + alts' = zipWith (\(Alt con _ bs rhs) freq -> Alt con freq bs rhs) alts freqs + +-- | Returns 'True' if the given predicate is neither all 'True' or all 'False' +-- on the elements of the list. +discriminates :: (a -> Bool) -> [a] -> Bool +discriminates p xs + | [_all_true_or_false] <- nub (map p xs) = False -- NB: we shortcircuit on the 2nd distinct element! + | otherwise = True + +-- | This is the Loop Branch Heuristic from [1] and [2]. +-- +-- "Predict as taken an edge back to a loop’s head. Predict as not taken an +-- edge exiting a loop." +-- +-- Our back edges are calls to recursive functions, the nesting levels of which +-- we track in 'u_lvls'. +loopBranchHeuristic :: Heuristic +loopBranchHeuristic _scrut alts + | applies = Just $! freqs + | otherwise = Nothing + where + max_back_lvl usg = case IntMap.lookupMax (u_lvls usg) of + Nothing -> -1 -- lower than all other levels + Just (lvl, _) -> lvl + max_back_lvls = map (\(con, _, usg) -> (max_back_lvl usg, con)) alts + has_back_edge = (>= 0) . fst + applies = discriminates has_back_edge max_back_lvls + sorted_back_lvls = sortOn fst max_back_lvls + lvl_batches = groupBy (\a b -> fst a == fst b) sorted_back_lvls + lvl_factor = 4 -- Factor by which we favor higher-level back edges + batches_w_counts = zip lvl_batches [ lvl_factor^i | i <- [0::Int, 1 ..] ] + -- Example: + -- * alt A has back_lvl -1 (e.g., no back edge) + -- * alts B,D have back_lvl 2 (e.g., continue outermost loops) + -- * alt C has back_lvl 14 (e.g., continues the innermost loop) + -- Then we'd get lvl_batches of [(-1, [A]), (2, [B,D]), (14, [C])] + -- and we'd get assoc counts of [ 1 , 4, 16 ], + -- so increasing with lvl_factor 4. + -- And then we simply re-align with the original alts and normalise to get + -- alts [(A,_,_), (B,_,_), (C,_,_), (D,_,_) ] + -- freqs [ 0.4 , 0.16 , 0.64 , 0.16 ] + total_count = sum $ map (\(grp, c) -> c * length grp) batches_w_counts + cons_freqs = [ (con, Freq (fromIntegral c / fromIntegral total_count)) + | (grp, c) <- batches_w_counts + , (_, con) <- grp ] + freqs = [ expectJust "con not present" $ lookup con cons_freqs | (con, _, _) <- alts ] + +-- | @usgHeuristic p yes no@ is a 'Heuristic' that applies whenever `p` is a +-- discriminating predicate on the case alternatives, weighing alternatives +-- that satisfy `p` with integer weights `yes` and those that don't with `no`. +usgHeuristic :: (Usage -> Bool) -> Int -> Int -> Heuristic +usgHeuristic p yes no _scrut alts + | applies = Just $! freqs + | otherwise = Nothing + where + applies = discriminates (\(_, _, usg) -> p usg) alts + freqs = absToRelFreqs [ if p usg then yes else no | (_, _, usg) <- alts ] + +-- | This is the Return Heuristic from [1] and [2]. +-- +-- "Predict a successor that contains a store instruction and does not +-- post-dominate will not be taken." +-- +-- We interpret "store" as primops with side-effects here. Also we don't only +-- look into direct successors, but the whole alternative +-- (for practical reasons). It doesn't work well, as exit paths tend to have no +-- side-effects and thus will win from this heuristic. +returnHeuristic :: Heuristic +returnHeuristic = usgHeuristic u_exit_path 1 4 + +-- | This is the Call Heuristic from [1] and [2]. +-- +-- "Predict a successor that contains a store instruction and does not +-- post-dominate will not be taken." +-- +-- We interpret "store" as primops with side-effects here. Also we don't only +-- look into direct successors, but the whole alternative +-- (for practical reasons). It doesn't work well, as exit paths tend to have no +-- side-effects and thus will win from this heuristic. +callHeuristic :: Heuristic +callHeuristic = usgHeuristic u_ext_calls 1 4 + +-- | This is the Store Heuristic from [1] and [2]. +-- +-- "Predict a successor that contains a store instruction and does not +-- post-dominate will not be taken." +-- +-- We interpret "store" as primops with side-effects here. Also we don't only +-- look into direct successors, but the whole alternative +-- (for practical reasons). It doesn't work well, as exit paths tend to have no +-- side-effects and thus will win from this heuristic. +storeHeuristic :: Heuristic +storeHeuristic = usgHeuristic u_side_effect 1 4 + +predictSpecificAlt :: (AltCon -> Bool) -> [(AltCon, [Var], Usage)] -> [Freq] +predictSpecificAlt p = absToRelFreqs . snd . foldr go (False, []) + where + high_freq = 5 + low_freq = 1 + go (con, _, _) (found_it, abs_freqs) = case con of + DEFAULT | not found_it -> (True, high_freq:abs_freqs) + -- DEFAULT always comes first in alts if it exists + -- Thus, it will be the last thing `go` encounters. + -- If we haven't found a matching AltCon so far, we pick DEFAULT + _ | p con -> (True, high_freq:abs_freqs) + | otherwise -> (found_it, low_freq:abs_freqs) + +predictZero, predictOne, predictDefault :: [(AltCon, [Var], Usage)] -> [Freq] + +predictZero = predictSpecificAlt p + where + p (LitAlt l) = isZeroLit l + p _ = False + +predictOne = predictSpecificAlt p + where + p (LitAlt l) = isOneLit l + p _ = False + +predictDefault = predictSpecificAlt p + where + p DEFAULT = True + p _ = False + +-- | This is the Opcode Heuristic from [1] and [2]. +-- +-- "Predict that a comparison of an integer [for us: general literal] for less +-- than zero, less than or equal to zero, or equal to a constant, will fail." +-- +-- We extend the heuristic slightly to deal with multiple literal alts, in which +-- we predict the DEFAULT alt. Predicting the `< 0` and `<= 0` cases as False +-- is a choice we might want to revisit; the original paper did it based on the +-- use of negative error codes that are prevalent in C. +opcodeHeuristic :: Heuristic +opcodeHeuristic scrut alts + | not $ any lit_alt alts = Nothing + | [_, _] <- alts = case putLitRight <$> isComparisonApp_maybe scrut of + -- putLitRight arranges it such that the Literal is the right operand + Just (cmp, _, Lit r_lit) + | isZeroLit r_lit -> Just $! case cmp of + Lt -> predictZero alts + Le -> predictZero alts + Eq -> predictZero alts + Gt -> predictOne alts + Ge -> predictOne alts + Ne -> predictOne alts + | Eq <- cmp -> Just $! predictZero alts + | Ne <- cmp -> Just $! predictOne alts + _ -> Just $! predictDefault alts + | otherwise = Just $! predictDefault alts + where + lit_alt (LitAlt{}, _, _) = True + lit_alt _ = False + +putLitRight :: (Comparison, CoreExpr, CoreExpr) -> (Comparison, CoreExpr, CoreExpr) +putLitRight (cmp, l@Lit{}, r) = (flipComparison cmp, r, l) +putLitRight orig = orig diff --git a/compiler/GHC/Core/Opt/Exitify.hs b/compiler/GHC/Core/Opt/Exitify.hs index 7da0a68989..d22cfa795d 100644 --- a/compiler/GHC/Core/Opt/Exitify.hs +++ b/compiler/GHC/Core/Opt/Exitify.hs @@ -81,7 +81,7 @@ exitifyProgram binds = map goTopLvl binds = Case (go in_scope scrut) bndr ty (map go_alt alts) where in_scope1 = in_scope `extendInScopeSet` bndr - go_alt (Alt dc pats rhs) = Alt dc pats (go in_scope' rhs) + go_alt (Alt dc freq pats rhs) = Alt dc freq pats (go in_scope' rhs) where in_scope' = in_scope1 `extendInScopeSetList` pats go in_scope (Let (NonRec bndr rhs) body) @@ -152,9 +152,9 @@ exitifyRec in_scope pairs -- Case right hand sides are in tail-call position go captured (_, AnnCase scrut bndr ty alts) = do - alts' <- forM alts $ \(AnnAlt dc pats rhs) -> do + alts' <- forM alts $ \(AnnAlt dc freq pats rhs) -> do rhs' <- go (captured ++ [bndr] ++ pats) rhs - return (Alt dc pats rhs') + return (Alt dc freq pats rhs') return $ Case (deAnnotate scrut) bndr ty alts' go captured (_, AnnLet ann_bind body) diff --git a/compiler/GHC/Core/Opt/FloatIn.hs b/compiler/GHC/Core/Opt/FloatIn.hs index 6e4b724310..8f188f9935 100644 --- a/compiler/GHC/Core/Opt/FloatIn.hs +++ b/compiler/GHC/Core/Opt/FloatIn.hs @@ -446,7 +446,7 @@ bindings are: -} -fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [AnnAlt con alt_bndrs rhs]) +fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [AnnAlt con _freq alt_bndrs rhs]) | isUnliftedType (idType case_bndr) , exprOkForSideEffects (deAnnotate scrut) -- See Note [Floating primops] @@ -485,12 +485,12 @@ fiExpr platform to_drop (_, AnnCase scrut case_bndr ty alts) scrut_fvs = freeVarsOf scrut alts_fvs = map alt_fvs alts all_alts_fvs = unionDVarSets alts_fvs - alt_fvs (AnnAlt _con args rhs) + alt_fvs (AnnAlt _con _float args rhs) = foldl' delDVarSet (freeVarsOf rhs) (case_bndr:args) -- Delete case_bndr and args from free vars of rhs -- to get free vars of alt - fi_alt to_drop (AnnAlt con args rhs) = Alt con args (fiExpr platform to_drop rhs) + fi_alt to_drop (AnnAlt con freq args rhs) = Alt con freq args (fiExpr platform to_drop rhs) ------------------ fiBind :: Platform diff --git a/compiler/GHC/Core/Opt/FloatOut.hs b/compiler/GHC/Core/Opt/FloatOut.hs index fbed53fbf3..7fa2df8ba1 100644 --- a/compiler/GHC/Core/Opt/FloatOut.hs +++ b/compiler/GHC/Core/Opt/FloatOut.hs @@ -467,7 +467,7 @@ floatExpr (Let bind body) floatExpr (Case scrut (TB case_bndr case_spec) ty alts) = case case_spec of FloatMe dest_lvl -- Case expression moves - | [Alt con@(DataAlt {}) bndrs rhs] <- alts + | [Alt con@(DataAlt {}) _freq bndrs rhs] <- alts -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') -> case floatExpr rhs of { (fsb, fdb, rhs') -> let @@ -484,9 +484,9 @@ floatExpr (Case scrut (TB case_bndr case_spec) ty alts) (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts') }} where - float_alt bind_lvl (Alt con bs rhs) + float_alt bind_lvl (Alt con freq bs rhs) = case (floatBody bind_lvl rhs) of { (fs, rhs_floats, rhs') -> - (fs, rhs_floats, Alt con [b | TB b _ <- bs] rhs') } + (fs, rhs_floats, Alt con freq [b | TB b _ <- bs] rhs') } floatRhs :: CoreBndr -> LevelledExpr diff --git a/compiler/GHC/Core/Opt/LiberateCase.hs b/compiler/GHC/Core/Opt/LiberateCase.hs index 3c9eb5c3d0..522464eaa9 100644 --- a/compiler/GHC/Core/Opt/LiberateCase.hs +++ b/compiler/GHC/Core/Opt/LiberateCase.hs @@ -254,7 +254,7 @@ libCase env (Case scrut bndr ty alts) mk_alt_env _ = env libCaseAlt :: LibCaseEnv -> Alt CoreBndr -> Alt CoreBndr -libCaseAlt env (Alt con args rhs) = Alt con args (libCase (addBinders env args) rhs) +libCaseAlt env (Alt con freq args rhs) = Alt con freq args (libCase (addBinders env args) rhs) {- Ids diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs index 7df9ead69f..fdba047480 100644 --- a/compiler/GHC/Core/Opt/OccurAnal.hs +++ b/compiler/GHC/Core/Opt/OccurAnal.hs @@ -2301,12 +2301,12 @@ occAnalLamOrRhs env binders body occAnalAlt :: OccEnv -> CoreAlt -> WithUsageDetails (Alt IdWithOccInfo) -occAnalAlt !env (Alt con bndrs rhs) +occAnalAlt !env (Alt con freq bndrs rhs) = let (WithUsageDetails rhs_usage1 rhs1) = occAnal (env `addInScope` bndrs) rhs (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs in -- See Note [Binders in case alternatives] - WithUsageDetails alt_usg (Alt con tagged_bndrs rhs1) + WithUsageDetails alt_usg (Alt con freq tagged_bndrs rhs1) {- ************************************************************************ diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs index 2d69e8eb04..054188e396 100644 --- a/compiler/GHC/Core/Opt/SetLevels.hs +++ b/compiler/GHC/Core/Opt/SetLevels.hs @@ -111,7 +111,7 @@ import GHC.Types.Unique ( hasKey ) import GHC.Types.Tickish ( tickishIsCode ) import GHC.Types.Unique.Supply import GHC.Types.Unique.DFM -import GHC.Types.Basic ( Arity, RecFlag(..), isRec ) +import GHC.Types.Basic import GHC.Builtin.Types import GHC.Builtin.Names ( runRWKey ) @@ -494,7 +494,7 @@ lvlCase :: LevelEnv -- Level of in-scope names/tyvars -> LvlM LevelledExpr -- Result expression lvlCase env scrut_fvs scrut' case_bndr ty alts -- See Note [Floating single-alternative cases] - | [AnnAlt con@(DataAlt {}) bs body] <- alts + | [AnnAlt con@(DataAlt {}) freq bs body] <- alts , exprIsHNF (deTagExpr scrut') -- See Note [Check the output scrutinee for exprIsHNF] , not (isTopLvl dest_lvl) -- Can't have top-level cases , not (floatTopLvlOnly env) -- Can float anywhere @@ -504,7 +504,7 @@ lvlCase env scrut_fvs scrut' case_bndr ty alts do { (env1, (case_bndr' : bs')) <- cloneCaseBndrs env dest_lvl (case_bndr : bs) ; let rhs_env = extendCaseBndrEnv env1 case_bndr scrut' ; body' <- lvlMFE rhs_env True body - ; let alt' = Alt con (map (stayPut dest_lvl) bs') body' + ; let alt' = Alt con freq (map (stayPut dest_lvl) bs') body' ; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty' [alt']) } | otherwise -- Stays put @@ -519,9 +519,9 @@ lvlCase env scrut_fvs scrut' case_bndr ty alts dest_lvl = maxFvLevel (const True) env scrut_fvs -- Don't abstract over type variables, hence const True - lvl_alt alts_env (AnnAlt con bs rhs) + lvl_alt alts_env (AnnAlt con freq bs rhs) = do { rhs' <- lvlMFE new_env True rhs - ; return (Alt con bs' rhs') } + ; return (Alt con freq bs' rhs') } where (new_env, bs') = substAndLvlBndrs NonRecursive alts_env incd_lvl bs @@ -704,13 +704,13 @@ lvlMFE env strict_ctxt ann_expr ; let l1r = incMinorLvlFrom rhs_env float_rhs = mkLams abs_vars_w_lvls $ Case expr1 (stayPut l1r ubx_bndr) dc_res_ty - [Alt DEFAULT [] (mkConApp dc [Var ubx_bndr])] + [Alt DEFAULT NoFreq [] (mkConApp dc [Var ubx_bndr])] ; var <- newLvlVar float_rhs Nothing is_mk_static ; let l1u = incMinorLvlFrom env use_expr = Case (mkVarApps (Var var) abs_vars) (stayPut l1u bx_bndr) expr_ty - [Alt (DataAlt dc) [stayPut l1u ubx_bndr] (Var ubx_bndr)] + [Alt (DataAlt dc) NoFreq [stayPut l1u ubx_bndr] (Var ubx_bndr)] ; return (Let (NonRec (TB var (FloatMe dest_lvl)) float_rhs) use_expr) } diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 11b0b50036..7517fc9962 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -1375,7 +1375,7 @@ simplTick env tickish expr cont tickScrut e = foldr mkTick e ticks -- Alternatives get annotated with all ticks that scope in some way, -- but we don't want to count entries. - tickAlt (Alt c bs e) = Alt c bs (foldr mkTick e ts_scope) + tickAlt (Alt c f bs e) = Alt c f bs (foldr mkTick e ts_scope) ts_scope = map mkNoCount $ filter (not . (`tickishScopesLike` NoScope)) ticks @@ -2755,7 +2755,7 @@ rebuildCase env scrut case_bndr alts cont = do { tick (KnownBranch case_bndr) ; case findAlt (LitAlt lit) alts of Nothing -> missingAlt env case_bndr alts cont - Just (Alt _ bs rhs) -> simple_rhs env [] scrut bs rhs } + Just (Alt _ _ bs rhs) -> simple_rhs env [] scrut bs rhs } | Just (in_scope', wfloats, con, ty_args, other_args) <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut @@ -2771,8 +2771,8 @@ rebuildCase env scrut case_bndr alts cont `mkApps` other_args ; case findAlt (DataAlt con) alts of Nothing -> missingAlt env0 case_bndr alts cont - Just (Alt DEFAULT bs rhs) -> simple_rhs env0 scaled_wfloats case_bndr_rhs bs rhs - Just (Alt _ bs rhs) -> knownCon env0 scrut scaled_wfloats con ty_args + Just (Alt DEFAULT _ bs rhs) -> simple_rhs env0 scaled_wfloats case_bndr_rhs bs rhs + Just (Alt _ _ bs rhs) -> knownCon env0 scrut scaled_wfloats con ty_args other_args case_bndr bs rhs cont } where @@ -2820,7 +2820,7 @@ rebuildCase env scrut case_bndr alts cont -- 2. Eliminate the case if scrutinee is evaluated -------------------------------------------------- -rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont +rebuildCase env scrut case_bndr alts@[Alt _ _ bndrs rhs] cont -- See if we can get rid of the case altogether -- See Note [Case elimination] -- mkCase made sure that if all the alternatives are equal, @@ -3054,7 +3054,7 @@ improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv -> OutExpr -> InId -> OutId -> [InAlt] -> SimplM (SimplEnv, OutExpr, OutId) -- Note [Improving seq] -improveSeq fam_envs env scrut case_bndr case_bndr1 [Alt DEFAULT _ _] +improveSeq fam_envs env scrut case_bndr case_bndr1 [Alt DEFAULT _ _ _] | Just (Reduction co ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1) = do { case_bndr2 <- newId (fsLit "nt") Many ty2 ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing @@ -3075,21 +3075,21 @@ simplAlt :: SimplEnv -> InAlt -> SimplM OutAlt -simplAlt env _ imposs_deflt_cons case_bndr' cont' (Alt DEFAULT bndrs rhs) +simplAlt env _ imposs_deflt_cons case_bndr' cont' (Alt DEFAULT freq bndrs rhs) = assert (null bndrs) $ do { let env' = addBinderUnfolding env case_bndr' (mkOtherCon imposs_deflt_cons) -- Record the constructors that the case-binder *can't* be. ; rhs' <- simplExprC env' rhs cont' - ; return (Alt DEFAULT [] rhs') } + ; return (Alt DEFAULT freq [] rhs') } -simplAlt env scrut' _ case_bndr' cont' (Alt (LitAlt lit) bndrs rhs) +simplAlt env scrut' _ case_bndr' cont' (Alt (LitAlt lit) freq bndrs rhs) = assert (null bndrs) $ do { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit) ; rhs' <- simplExprC env' rhs cont' - ; return (Alt (LitAlt lit) [] rhs') } + ; return (Alt (LitAlt lit) freq [] rhs') } -simplAlt env scrut' _ case_bndr' cont' (Alt (DataAlt con) vs rhs) +simplAlt env scrut' _ case_bndr' cont' (Alt (DataAlt con) freq vs rhs) = do { -- See Note [Adding evaluatedness info to pattern-bound variables] let vs_with_evals = addEvals scrut' con vs ; (env', vs') <- simplLamBndrs env vs_with_evals @@ -3101,7 +3101,7 @@ simplAlt env scrut' _ case_bndr' cont' (Alt (DataAlt con) vs rhs) ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app ; rhs' <- simplExprC env'' rhs cont' - ; return (Alt (DataAlt con) vs' rhs') } + ; return (Alt (DataAlt con) freq vs' rhs') } {- Note [Adding evaluatedness info to pattern-bound variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -3427,7 +3427,7 @@ altsWouldDup (alt:alts) | otherwise = not (all is_bot_alt alts) -- otherwise case: first alt is non-bot, so all the rest must be bot where - is_bot_alt (Alt _ _ rhs) = exprIsDeadEnd rhs + is_bot_alt (Alt _ _ _ rhs) = exprIsDeadEnd rhs ------------------------- mkDupableCont :: SimplEnv @@ -3615,9 +3615,9 @@ mkDupableStrictBind env arg_bndr join_rhs res_ty mkDupableAlt :: Platform -> OutId -> JoinFloats -> OutAlt -> SimplM (JoinFloats, OutAlt) -mkDupableAlt _platform case_bndr jfloats (Alt con bndrs' rhs') +mkDupableAlt _platform case_bndr jfloats (Alt con freq bndrs' rhs') | exprIsTrivial rhs' -- See point (2) of Note [Duplicating join points] - = return (jfloats, Alt con bndrs' rhs') + = return (jfloats, Alt con freq bndrs' rhs') | otherwise = do { let rhs_ty' = exprType rhs' @@ -3645,7 +3645,7 @@ mkDupableAlt _platform case_bndr jfloats (Alt con bndrs' rhs') ; join_bndr <- newJoinId final_bndrs' rhs_ty' ; let join_call = mkApps (Var join_bndr) final_args - alt' = Alt con bndrs' join_call + alt' = Alt con freq bndrs' join_call ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs) , alt') } diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index 5c3114e76b..525dda7ed3 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -2268,15 +2268,15 @@ mkCase, mkCase1, mkCase2, mkCase3 -- 1. Merge Nested Cases -------------------------------------------------- -mkCase dflags scrut outer_bndr alts_ty (Alt DEFAULT _ deflt_rhs : outer_alts) +mkCase dflags scrut outer_bndr alts_ty (Alt DEFAULT _ _ deflt_rhs : outer_alts) | gopt Opt_CaseMerge dflags , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts) <- stripTicksTop tickishFloatable deflt_rhs , inner_scrut_var == outer_bndr = do { tick (CaseMerge outer_bndr) - ; let wrap_alt (Alt con args rhs) = assert (outer_bndr `notElem` args) - (Alt con args (wrap_rhs rhs)) + ; let wrap_alt (Alt con freq args rhs) = assert (outer_bndr `notElem` args) + (Alt con freq args (wrap_rhs rhs)) -- Simplifier's no-shadowing invariant should ensure -- that outer_bndr is not shadowed by the inner patterns wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs @@ -2310,13 +2310,13 @@ mkCase dflags scrut bndr alts_ty alts = mkCase1 dflags scrut bndr alts_ty alts -- 2. Eliminate Identity Case -------------------------------------------------- -mkCase1 _dflags scrut case_bndr _ alts@(Alt _ _ rhs1 : _) -- Identity case +mkCase1 _dflags scrut case_bndr _ alts@(Alt _ _ _ rhs1 : _) -- Identity case | all identity_alt alts = do { tick (CaseIdentity case_bndr) ; return (mkTicks ticks $ re_cast scrut rhs1) } where - ticks = concatMap (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) (tail alts) - identity_alt (Alt con args rhs) = check_eq rhs con args + ticks = concatMap (\(Alt _ _ _ rhs) -> stripTicksT tickishFloatable rhs) (tail alts) + identity_alt (Alt con _freq args rhs) = check_eq rhs con args check_eq (Cast rhs co) con args -- See Note [RHS casts] = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args @@ -2358,7 +2358,7 @@ mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts mkCase2 dflags scrut bndr alts_ty alts | -- See Note [Scrutinee Constant Folding] case alts of -- Not if there is just a DEFAULT alternative - [Alt DEFAULT _ _] -> False + [Alt DEFAULT _ _ _] -> False _ -> True , gopt Opt_CaseFolding dflags , Just (scrut', tx_con, mk_orig) <- caseRules (targetPlatform dflags) scrut @@ -2394,11 +2394,11 @@ mkCase2 dflags scrut bndr alts_ty alts tx_alt :: (AltCon -> Maybe AltCon) -> (Id -> CoreExpr) -> Id -> CoreAlt -> SimplM (Maybe CoreAlt) - tx_alt tx_con mk_orig new_bndr (Alt con bs rhs) + tx_alt tx_con mk_orig new_bndr (Alt con freq bs rhs) = case tx_con con of Nothing -> return Nothing Just con' -> do { bs' <- mk_new_bndrs new_bndr con' - ; return (Just (Alt con' bs' rhs')) } + ; return (Just (Alt con' freq bs' rhs')) } where rhs' | isDeadBinder bndr = rhs | otherwise = bindNonRec bndr orig_val rhs @@ -2425,8 +2425,8 @@ mkCase2 dflags scrut bndr alts_ty alts add_default :: [CoreAlt] -> [CoreAlt] -- See Note [Literal cases] - add_default (Alt (LitAlt {}) bs rhs : alts) = Alt DEFAULT bs rhs : alts - add_default alts = alts + add_default (Alt (LitAlt {}) freq bs rhs : alts) = Alt DEFAULT freq bs rhs : alts + add_default alts = alts {- Note [Literal cases] ~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs index 718c840c96..27dd473ab7 100644 --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -1246,9 +1246,9 @@ scExpr' env (Case scrut b ty alts) } where sc_con_app con args scrut' -- Known constructor; simplify - = do { let Alt _ bs rhs = findAlt con alts - `orElse` Alt DEFAULT [] (mkImpossibleExpr ty) - alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args) + = do { let Alt _ _ bs rhs = findAlt con alts + `orElse` Alt DEFAULT NoFreq [] (mkImpossibleExpr ty) + alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args) ; scExpr alt_env' rhs } sc_vanilla scrut_usg scrut' -- Normal case @@ -1267,7 +1267,7 @@ scExpr' env (Case scrut b ty alts) ; return (foldr combineUsage scrut_usg' alt_usgs, Case scrut' b' (scSubstTy env ty) alts') } - sc_alt env scrut' b' (Alt con bs rhs) + sc_alt env scrut' b' (Alt con freq bs rhs) = do { let (env1, bs1) = extendBndrsWith RecArg env bs (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1 ; (usg, rhs') <- scExpr env2 rhs @@ -1275,7 +1275,7 @@ scExpr' env (Case scrut b ty alts) scrut_occ = case con of DataAlt dc -> ScrutOcc (unitUFM dc arg_occs) _ -> ScrutOcc emptyUFM - ; return (usg', b_occ `combineOcc` scrut_occ, Alt con bs2 rhs') } + ; return (usg', b_occ `combineOcc` scrut_occ, Alt con freq bs2 rhs') } scExpr' env (Let (NonRec bndr rhs) body) | isTyVar bndr -- Type-lets may be created by doBeta diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs index 7071932e2a..28c755dd1b 100644 --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -1185,14 +1185,14 @@ specCase :: SpecEnv , Id , [CoreAlt] , UsageDetails) -specCase env scrut' case_bndr [Alt con args rhs] +specCase env scrut' case_bndr [Alt con freq args rhs] | isDictId case_bndr -- See Note [Floating dictionaries out of cases] , interestingDict env scrut' , not (isDeadBinder case_bndr && null sc_args') = do { (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args') ; let sc_rhss = [ Case (Var case_bndr_flt) case_bndr' (idType sc_arg') - [Alt con args' (Var sc_arg')] + [Alt con freq args' (Var sc_arg')] | sc_arg' <- sc_args' ] -- Extend the substitution for RHS to map the *original* binders @@ -1216,7 +1216,7 @@ specCase env scrut' case_bndr [Alt con args rhs] flt_binds = scrut_bind : sc_binds (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds all_uds = flt_binds `addDictBinds` free_uds - alt' = Alt con args' (wrapDictBindsE dumped_dbs rhs') + alt' = Alt con freq args' (wrapDictBindsE dumped_dbs rhs') ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) } where (env_rhs, (case_bndr':args')) = substBndrs env (case_bndr:args) @@ -1245,10 +1245,10 @@ specCase env scrut case_bndr alts ; return (scrut, case_bndr', alts', uds_alts) } where (env_alt, case_bndr') = substBndr env case_bndr - spec_alt (Alt con args rhs) = do + spec_alt (Alt con freq args rhs) = do (rhs', uds) <- specExpr env_rhs rhs let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds - return (Alt con args' (wrapDictBindsE dumped_dbs rhs'), free_uds) + return (Alt con freq args' (wrapDictBindsE dumped_dbs rhs'), free_uds) where (env_rhs, args') = substBndrs env_alt args diff --git a/compiler/GHC/Core/Opt/StaticArgs.hs b/compiler/GHC/Core/Opt/StaticArgs.hs index c514054ec1..2b5f906283 100644 --- a/compiler/GHC/Core/Opt/StaticArgs.hs +++ b/compiler/GHC/Core/Opt/StaticArgs.hs @@ -223,9 +223,9 @@ satExpr (Case expr bndr ty alts) interesting_ids = do let (alts', sat_infos_alts) = unzip zipped_alts' return (Case expr' bndr ty alts', mergeIdSATInfo sat_info_expr' (mergeIdSATInfos sat_infos_alts), Nothing) where - satAlt (Alt con bndrs expr) = do + satAlt (Alt con freq bndrs expr) = do (expr', sat_info_expr) <- satTopLevelExpr expr interesting_ids - return (Alt con bndrs expr', sat_info_expr) + return (Alt con freq bndrs expr', sat_info_expr) satExpr (Let bind body) interesting_ids = do (body', sat_info_body, body_app) <- satExpr body interesting_ids diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs index 7cb9d6ad2f..e3f31aa5c5 100644 --- a/compiler/GHC/Core/Opt/WorkWrap.hs +++ b/compiler/GHC/Core/Opt/WorkWrap.hs @@ -145,12 +145,12 @@ wwExpr ww_opts (Case expr binder ty alts) = do -- See Note [Zapping Used Once info in WorkWrap] return (Case new_expr new_binder ty new_alts) where - ww_alt (Alt con binders rhs) = do + ww_alt (Alt con freq binders rhs) = do new_rhs <- wwExpr ww_opts rhs let new_binders = [ if isId b then zapIdUsedOnceInfo b else b | b <- binders ] -- See Note [Zapping Used Once info in WorkWrap] - return (Alt con new_binders new_rhs) + return (Alt con freq new_binders new_rhs) {- ************************************************************************ diff --git a/compiler/GHC/Core/Ppr.hs b/compiler/GHC/Core/Ppr.hs index f1791dfebf..fa68e12909 100644 --- a/compiler/GHC/Core/Ppr.hs +++ b/compiler/GHC/Core/Ppr.hs @@ -233,7 +233,7 @@ ppr_expr add_par expr@(App {}) _ -> parens (hang (pprParendExpr fun) 2 pp_args) } -ppr_expr add_par (Case expr var ty [Alt con args rhs]) +ppr_expr add_par (Case expr var ty [Alt con _freq args rhs]) = sdocOption sdocPrintCaseAsLet $ \case True -> add_par $ -- See Note [Print case as let] sep [ sep [ text "let! {" @@ -312,7 +312,7 @@ ppr_expr add_par (Tick tickish expr) False -> add_par (sep [ppr tickish, pprCoreExpr expr]) pprCoreAlt :: OutputableBndr a => Alt a -> SDoc -pprCoreAlt (Alt con args rhs) +pprCoreAlt (Alt con _freq args rhs) = hang (ppr_case_pat con args <+> arrow) 2 (pprCoreExpr rhs) ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs index ff57df697f..014efc4c00 100644 --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -899,7 +899,7 @@ match_alts :: RuleMatchEnv -> Maybe RuleSubst match_alts _ subst [] [] = return subst -match_alts renv subst (Alt c1 vs1 r1:alts1) (Alt c2 vs2 r2:alts2) +match_alts renv subst (Alt c1 _f1 vs1 r1:alts1) (Alt c2 _f2 vs2 r2:alts2) | c1 == c2 = do { subst1 <- match renv' subst r1 r2 ; match_alts renv subst1 alts1 alts2 } @@ -1227,7 +1227,7 @@ ruleCheck env (Cast e _) = ruleCheck env e ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e ruleCheck env (Lam _ e) = ruleCheck env e ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags` - unionManyBags [ruleCheck env r | Alt _ _ r <- as] + unionManyBags [ruleCheck env r | Alt _ _ _ r <- as] ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as) diff --git a/compiler/GHC/Core/Seq.hs b/compiler/GHC/Core/Seq.hs index 0addae9775..2ad5da4178 100644 --- a/compiler/GHC/Core/Seq.hs +++ b/compiler/GHC/Core/Seq.hs @@ -100,7 +100,7 @@ seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs seqAlts :: [CoreAlt] -> () seqAlts [] = () -seqAlts (Alt c bs e:alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts +seqAlts (Alt c _ bs e:alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts seqUnfolding :: Unfolding -> () seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top, diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index d741aa0351..25b053d8a6 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -257,7 +257,7 @@ simple_opt_expr env expr | isDeadBinder b , Just (_, [], con, _tys, es) <- exprIsConApp_maybe in_scope_env e' -- We don't need to be concerned about floats when looking for coerce. - , Just (Alt altcon bs rhs) <- findAlt (DataAlt con) as + , Just (Alt altcon _freq bs rhs) <- findAlt (DataAlt con) as = case altcon of DEFAULT -> go rhs _ -> foldr wrapLet (simple_opt_expr env' rhs) mb_prs @@ -267,7 +267,7 @@ simple_opt_expr env expr -- Note [Getting the map/coerce RULE to work] | isDeadBinder b - , [Alt DEFAULT _ rhs] <- as + , [Alt DEFAULT _freq _ rhs] <- as , isCoVarType (varType b) , (Var fun, _args) <- collectArgs e , fun `hasKey` coercibleSCSelIdKey @@ -285,8 +285,8 @@ simple_opt_expr env expr go_co co = optCoercion (soe_co_opt_opts env) (getTCvSubst subst) co ---------------------- - go_alt env (Alt con bndrs rhs) - = Alt con bndrs' (simple_opt_expr env' rhs) + go_alt env (Alt con freq bndrs rhs) + = Alt con freq bndrs' (simple_opt_expr env' rhs) where (env', bndrs') = subst_opt_bndrs env bndrs @@ -1141,7 +1141,7 @@ exprIsConApp_maybe (in_scope, id_unf) expr float = FloatLet (NonRec bndr' rhs') in go subst' (float:floats) expr cont - go subst floats (Case scrut b _ [Alt con vars expr]) cont + go subst floats (Case scrut b _ [Alt con _freq vars expr]) cont = let scrut' = subst_expr subst scrut (subst', b') = subst_bndr subst b diff --git a/compiler/GHC/Core/Stats.hs b/compiler/GHC/Core/Stats.hs index 04e6bc3274..8f051e9d0e 100644 --- a/compiler/GHC/Core/Stats.hs +++ b/compiler/GHC/Core/Stats.hs @@ -85,7 +85,7 @@ exprStats (Cast e co) = coStats co `plusCS` exprStats e exprStats (Tick _ e) = exprStats e altStats :: CoreAlt -> CoreStats -altStats (Alt _ bs r) = altBndrStats bs `plusCS` exprStats r +altStats (Alt _ _ bs r) = altBndrStats bs `plusCS` exprStats r altBndrStats :: [Var] -> CoreStats -- Charge one for the alternative, not for each binder @@ -135,4 +135,4 @@ pairSize :: (Var, CoreExpr) -> Int pairSize (b,e) = bndrSize b + exprSize e altSize :: CoreAlt -> Int -altSize (Alt _ bs e) = bndrsSize bs + exprSize e +altSize (Alt _ _ bs e) = bndrsSize bs + exprSize e diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs index 83e91ad21a..309c985642 100644 --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -374,9 +374,9 @@ substExpr subst expr where (subst', bndr') = substBndr subst bndr - go_alt subst (Alt con bndrs rhs) = Alt con bndrs' (substExpr subst' rhs) - where - (subst', bndrs') = substBndrs subst bndrs + go_alt subst (Alt con freq bndrs rhs) = Alt con freq bndrs' (substExpr subst' rhs) + where + (subst', bndrs') = substBndrs subst bndrs -- | Apply a substitution to an entire 'CoreBind', additionally returning an updated 'Subst' -- that should be used by subsequent substitutions. diff --git a/compiler/GHC/Core/Tidy.hs b/compiler/GHC/Core/Tidy.hs index aaf42eafd2..b4110b9600 100644 --- a/compiler/GHC/Core/Tidy.hs +++ b/compiler/GHC/Core/Tidy.hs @@ -82,9 +82,9 @@ tidyExpr env (Lam b e) ------------ Case alternatives -------------- tidyAlt :: TidyEnv -> CoreAlt -> CoreAlt -tidyAlt env (Alt con vs rhs) +tidyAlt env (Alt con freq vs rhs) = tidyBndrs env vs =: \ (env', vs) -> - (Alt con vs (tidyExpr env' rhs)) + (Alt con freq vs (tidyExpr env' rhs)) ------------ Tickish -------------- tidyTickish :: TidyEnv -> CoreTickish -> CoreTickish diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs index f8dadf8c16..0305cc9d19 100644 --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -224,7 +224,7 @@ inlineBoringOk e , exprIsTrivial a = go (credit-1) f go credit (Tick _ e) = go credit e -- dubious go credit (Cast e _) = go credit e - go credit (Case scrut _ _ [Alt _ _ rhs]) -- See Note [Inline unsafeCoerce] + go credit (Case scrut _ _ [Alt _ _ _ rhs]) -- See Note [Inline unsafeCoerce] | isUnsafeEqualityProof scrut = go credit rhs go _ (Var {}) = boringCxtOk go _ _ = boringCxtNotOk @@ -570,7 +570,7 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr _ -> funSize opts top_args fun (length val_args) voids ------------ - size_up_alt (Alt _con _bndrs rhs) = size_up rhs `addSizeN` 10 + size_up_alt (Alt _con _freq _bndrs rhs) = size_up rhs `addSizeN` 10 -- Don't charge for args, so that wrappers look cheap -- (See comments about wrappers with Case) -- diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index b2af755e78..68378c6e2e 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -33,6 +33,7 @@ module GHC.Core.Utils ( exprIsTickedString, exprIsTickedString_maybe, exprIsTopLevelBindable, altsAreExhaustive, + isComparisonApp_maybe, -- * Equality cheapEqExpr, cheapEqExpr', eqExpr, @@ -93,7 +94,7 @@ import GHC.Types.Tickish import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Unique -import GHC.Types.Basic ( Arity, FullArgCount ) +import GHC.Types.Basic import GHC.Types.Unique.Set import GHC.Data.FastString @@ -146,7 +147,7 @@ exprType other = pprPanic "exprType" (pprCoreExpr other) coreAltType :: CoreAlt -> Type -- ^ Returns the type of the alternatives right hand side -coreAltType alt@(Alt _ bs rhs) +coreAltType alt@(Alt _ _ bs rhs) = case occCheckExpand bs rhs_ty of -- Note [Existential variables and silly type synonyms] Just ty -> ty @@ -499,7 +500,7 @@ stripTicksE p expr = go expr go_bs (NonRec b e) = NonRec b (go e) go_bs (Rec bs) = Rec (map go_b bs) go_b (b, e) = (b, go e) - go_a (Alt c bs e) = Alt c bs (go e) + go_a (Alt c f bs e) = Alt c f bs (go e) stripTicksT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish] stripTicksT p expr = fromOL $ go expr @@ -515,7 +516,7 @@ stripTicksT p expr = fromOL $ go expr go_bs (NonRec _ e) = go e go_bs (Rec bs) = concatOL (map go_b bs) go_b (_, e) = go e - go_a (Alt _ _ e) = go e + go_a (Alt _ _ _ e) = go e {- ************************************************************************ @@ -575,7 +576,7 @@ mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT" mkDefaultCase :: CoreExpr -> Id -> CoreExpr -> CoreExpr -- Make (case x of y { DEFAULT -> e } mkDefaultCase scrut case_bndr body - = Case scrut case_bndr (exprType body) [Alt DEFAULT [] body] + = Case scrut case_bndr (exprType body) [Alt DEFAULT NoFreq [] body] mkSingleAltCase :: CoreExpr -> Id -> AltCon -> [Var] -> CoreExpr -> CoreExpr -- Use this function if possible, when building a case, @@ -583,7 +584,7 @@ mkSingleAltCase :: CoreExpr -> Id -> AltCon -> [Var] -> CoreExpr -> CoreExpr -- doesn't mention variables bound by the case -- See Note [Care with the type of a case expression] mkSingleAltCase scrut case_bndr con bndrs body - = Case scrut case_bndr case_ty [Alt con bndrs body] + = Case scrut case_bndr case_ty [Alt con NoFreq bndrs body] where body_ty = exprType body @@ -627,16 +628,16 @@ This makes it easy to find, though it makes matching marginally harder. -- | Extract the default case alternative findDefault :: [Alt b] -> ([Alt b], Maybe (Expr b)) -findDefault (Alt DEFAULT args rhs : alts) = assert (null args) (alts, Just rhs) -findDefault alts = (alts, Nothing) +findDefault (Alt DEFAULT _ args rhs : alts) = assert (null args) (alts, Just rhs) +findDefault alts = (alts, Nothing) addDefault :: [Alt b] -> Maybe (Expr b) -> [Alt b] addDefault alts Nothing = alts -addDefault alts (Just rhs) = Alt DEFAULT [] rhs : alts +addDefault alts (Just rhs) = Alt DEFAULT NoFreq [] rhs : alts isDefaultAlt :: Alt b -> Bool -isDefaultAlt (Alt DEFAULT _ _) = True -isDefaultAlt _ = False +isDefaultAlt (Alt DEFAULT _ _ _) = True +isDefaultAlt _ = False -- | Find the case alternative corresponding to a particular -- constructor: panics if no such constructor exists @@ -645,11 +646,11 @@ findAlt :: AltCon -> [Alt b] -> Maybe (Alt b) -- See Note [Unreachable code] findAlt con alts = case alts of - (deflt@(Alt DEFAULT _ _):alts) -> go alts (Just deflt) - _ -> go alts Nothing + (deflt@(Alt DEFAULT _ _ _):alts) -> go alts (Just deflt) + _ -> go alts Nothing where go [] deflt = deflt - go (alt@(Alt con1 _ _) : alts) deflt + go (alt@(Alt con1 _ _ _) : alts) deflt = case con `cmpAltCon` con1 of LT -> deflt -- Missed it already; the alts are in increasing order EQ -> Just alt @@ -736,7 +737,7 @@ filterAlts _tycon inst_tys imposs_cons alts = (imposs_deflt_cons, addDefault trimmed_alts maybe_deflt) where (alts_wo_default, maybe_deflt) = findDefault alts - alt_cons = [con | Alt con _ _ <- alts_wo_default] + alt_cons = [con | Alt con _ _ _ <- alts_wo_default] trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default @@ -748,9 +749,9 @@ filterAlts _tycon inst_tys imposs_cons alts -- OR by a non-DEFAULT branch in this case expression. impossible_alt :: [Type] -> Alt b -> Bool - impossible_alt _ (Alt con _ _) | con `Set.member` imposs_cons_set = True - impossible_alt inst_tys (Alt (DataAlt con) _ _) = dataConCannotMatch inst_tys con - impossible_alt _ _ = False + impossible_alt _ (Alt con _ _ _) | con `Set.member` imposs_cons_set = True + impossible_alt inst_tys (Alt (DataAlt con) _ _ _) = dataConCannotMatch inst_tys con + impossible_alt _ _ = False -- | Refine the default alternative to a 'DataAlt', if there is a unique way to do so. -- See Note [Refine DEFAULT case alternatives] @@ -762,7 +763,7 @@ refineDefaultAlt :: [Unique] -- ^ Uniques for constructing new binders -> [CoreAlt] -> (Bool, [CoreAlt]) -- ^ 'True', if a default alt was replaced with a 'DataAlt' refineDefaultAlt us mult tycon tys imposs_deflt_cons all_alts - | Alt DEFAULT _ rhs : rest_alts <- all_alts + | Alt DEFAULT _ _ rhs : rest_alts <- all_alts , isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples. , not (isNewTyCon tycon) -- We can have a newtype, if we are just doing an eval: -- case x of { DEFAULT -> e } @@ -779,7 +780,7 @@ refineDefaultAlt us mult tycon tys imposs_deflt_cons all_alts [] -> (False, rest_alts) -- It matches exactly one constructor, so fill it in: - [con] -> (True, mergeAlts rest_alts [Alt (DataAlt con) (ex_tvs ++ arg_ids) rhs]) + [con] -> (True, mergeAlts rest_alts [Alt (DataAlt con) NoFreq (ex_tvs ++ arg_ids) rhs]) -- We need the mergeAlts to keep the alternatives in the right order where (ex_tvs, arg_ids) = dataConRepInstPat us mult con tys @@ -962,25 +963,26 @@ combineIdenticalAlts :: [AltCon] -- Constructors that cannot match DEFAULT [CoreAlt]) -- New alternatives -- See Note [Combine identical alternatives] -- True <=> we did some combining, result is a single DEFAULT alternative -combineIdenticalAlts imposs_deflt_cons (Alt con1 bndrs1 rhs1 : rest_alts) +combineIdenticalAlts imposs_deflt_cons (Alt con1 freq1 bndrs1 rhs1 : rest_alts) | all isDeadBinder bndrs1 -- Remember the default , not (null elim_rest) -- alternative comes first = (True, imposs_deflt_cons', deflt_alt : filtered_rest) where (elim_rest, filtered_rest) = partition identical_to_alt1 rest_alts - deflt_alt = Alt DEFAULT [] (mkTicks (concat tickss) rhs1) + elim_freqs = sum [ freq | Alt _ freq _ _ <- elim_rest ] + deflt_alt = Alt DEFAULT (elim_freqs + freq1) [] (mkTicks (concat tickss) rhs1) -- See Note [Care with impossible-constructors when combining alternatives] imposs_deflt_cons' = imposs_deflt_cons `minusList` elim_cons - elim_cons = elim_con1 ++ map (\(Alt con _ _) -> con) elim_rest + elim_cons = elim_con1 ++ map (\(Alt con _ _ _) -> con) elim_rest elim_con1 = case con1 of -- Don't forget con1! DEFAULT -> [] -- See Note [ _ -> [con1] cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2 - identical_to_alt1 (Alt _con bndrs rhs) + identical_to_alt1 (Alt _con _freq bndrs rhs) = all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1 - tickss = map (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) elim_rest + tickss = map (\(Alt _ _ _ rhs) -> stripTicksT tickishFloatable rhs) elim_rest combineIdenticalAlts imposs_cons alts = (False, imposs_cons, alts) @@ -991,7 +993,7 @@ scaleAltsBy :: Mult -> [CoreAlt] -> [CoreAlt] scaleAltsBy w alts = map scaleAlt alts where scaleAlt :: CoreAlt -> CoreAlt - scaleAlt (Alt con bndrs rhs) = Alt con (map scaleBndr bndrs) rhs + scaleAlt (Alt con freq bndrs rhs) = Alt con freq (map scaleBndr bndrs) rhs scaleBndr :: CoreBndr -> CoreBndr scaleBndr b = scaleVarBy w b @@ -1332,7 +1334,7 @@ exprIsCheapX ok_app e go _ (Coercion {}) = True go n (Cast e _) = go n e go n (Case scrut _ _ alts) = ok scrut && - and [ go n rhs | Alt _ _ rhs <- alts ] + and [ go n rhs | Alt _ _ _ rhs <- alts ] go n (Tick t e) | tickishCounts t = False | otherwise = go n e go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e @@ -1617,7 +1619,7 @@ expr_ok primop_ok (Case scrut bndr _ alts) = -- See Note [exprOkForSpeculation: case expressions] expr_ok primop_ok scrut && isUnliftedType (idType bndr) - && all (\(Alt _ _ rhs) -> expr_ok primop_ok rhs) alts + && all (\(Alt _ _ _ rhs) -> expr_ok primop_ok rhs) alts && altsAreExhaustive alts expr_ok primop_ok other_expr @@ -1707,7 +1709,7 @@ altsAreExhaustive :: [Alt b] -> Bool -- False <=> they may or may not be altsAreExhaustive [] = False -- Should not happen -altsAreExhaustive (Alt con1 _ _ : alts) +altsAreExhaustive (Alt con1 _ _ _ : alts) = case con1 of DEFAULT -> True LitAlt {} -> False @@ -2022,6 +2024,16 @@ exprIsTickedString_maybe (Tick t e) | otherwise = exprIsTickedString_maybe e exprIsTickedString_maybe _ = Nothing +-- | Is the expression an application to a primitive comparison operator +-- ('primOpIsComparison_maybe')? If so, return the kind of 'Comparison' +-- and the two argument expressions. +isComparisonApp_maybe :: CoreExpr -> Maybe (Comparison, CoreExpr, CoreExpr) +isComparisonApp_maybe e = do + App (App (Var f) a1) a2 <- pure e + op <- isPrimOpId_maybe f + cmp <- primOpIsComparison_maybe op + pure (cmp, a1, a2) + {- ************************************************************************ * * @@ -2201,7 +2213,7 @@ eqExpr in_scope e1 e2 go _ _ _ = False ----------- - go_alt env (Alt c1 bs1 e1) (Alt c2 bs2 e2) + go_alt env (Alt c1 _f1 bs1 e1) (Alt c2 _f2 bs2 e2) = c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2 eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool @@ -2246,7 +2258,7 @@ diffExpr top env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) -- See Note [Empty case alternatives] in GHC.Data.TrieMap = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2) where env' = rnBndr2 env b1 b2 - diffAlt (Alt c1 bs1 e1) (Alt c2 bs2 e2) + diffAlt (Alt c1 _f1 bs1 e1) (Alt c2 _f2 bs2 e2) | c1 /= c2 = [text "alt-cons " <> ppr c1 <> text " /= " <> ppr c2] | otherwise = diffExpr top (rnBndrs2 env' bs1 bs2) e1 e2 diffExpr _ _ e1 e2 diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs index 2356f6c7f5..fc1ee7bb1f 100644 --- a/compiler/GHC/CoreToIface.hs +++ b/compiler/GHC/CoreToIface.hs @@ -583,7 +583,7 @@ toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) < --------------------- toIfaceAlt :: CoreAlt -> IfaceAlt -toIfaceAlt (Alt c bs r) = IfaceAlt (toIfaceCon c) (map getOccFS bs) (toIfaceExpr r) +toIfaceAlt (Alt c _f bs r) = IfaceAlt (toIfaceCon c) (map getOccFS bs) (toIfaceExpr r) --------------------- toIfaceCon :: AltCon -> IfaceConAlt diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs index a258a424dc..5d13fc3dc6 100644 --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -455,7 +455,7 @@ coreToStgExpr (Case scrut bndr _ alts) ; return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2) } where vars_alt :: CoreAlt -> CtsM (AltCon, [Var], StgExpr) - vars_alt (Alt con binders rhs) + vars_alt (Alt con _freq binders rhs) | DataAlt c <- con, c == unboxedUnitDataCon = -- This case is a bit smelly. -- See Note [Nullary unboxed tuple] in GHC.Core.Type @@ -506,7 +506,7 @@ mkStgAltType bndr alts -- grabbing the one from a constructor alternative -- if one exists. look_for_better_tycon - | ((Alt (DataAlt con) _ _) : _) <- data_alts = + | ((Alt (DataAlt con) _ _ _) : _) <- data_alts = AlgAlt (dataConTyCon con) | otherwise = assert (null data_alts) diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index 30c28a6db2..4ecf2f6233 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -839,7 +839,7 @@ cpeRhsE env (Case scrut bndr _ alts) | isUnsafeEqualityProof scrut , isDeadBinder bndr -- We can only discard the case if the case-binder -- is dead. It usually is, but see #18227 - , [Alt _ [co_var] rhs] <- alts + , [Alt _ _ [co_var] rhs] <- alts , let Pair ty1 ty2 = coVarTypes co_var the_co = mkUnivCo prov Nominal (cpSubstTy env ty1) (cpSubstTy env ty2) prov = CorePrepProv True -- True <=> kind homogeneous @@ -866,10 +866,10 @@ cpeRhsE env (Case scrut bndr ty alts) ; return (floats, Case scrut' bndr2 ty alts'') } where - sat_alt env (Alt con bs rhs) + sat_alt env (Alt con freq bs rhs) = do { (env2, bs') <- cpCloneBndrs env bs ; rhs' <- cpeBodyNF env2 rhs - ; return (Alt con bs' rhs') } + ; return (Alt con freq bs' rhs') } -- --------------------------------------------------------------------------- -- CpeBody: produces a result satisfying CpeBody @@ -1023,9 +1023,9 @@ cpeApp top_env expr Lam s body -> cpe_app (extendCorePrepEnvExpr env s s0) body rest (n-2) _ -> cpe_app env k (CpeApp s0 : rest) (n-1) ; let touchId = mkPrimOpId TouchOp - expr = Case k' y result_ty [Alt DEFAULT [] rhs] + expr = Case k' y result_ty [Alt DEFAULT NoFreq [] rhs] rhs = let scrut = mkApps (Var touchId) [Type arg_rep, Type arg_ty, arg, Var realWorldPrimId] - in Case scrut s2 result_ty [Alt DEFAULT [] (Var y)] + in Case scrut s2 result_ty [Alt DEFAULT NoFreq [] (Var y)] ; (floats', expr') <- cpeBody env expr ; return (floats `appendFloats` floats', expr') } @@ -1650,7 +1650,7 @@ wrapBinds :: Floats -> CpeBody -> CpeBody wrapBinds (Floats _ binds) body = foldrOL mk_bind body binds where - mk_bind (FloatCase rhs bndr con bs _) body = Case rhs bndr (exprType body) [Alt con bs body] + mk_bind (FloatCase rhs bndr con bs _) body = Case rhs bndr (exprType body) [Alt con NoFreq bs body] mk_bind (FloatLet bind) body = Let bind body mk_bind (FloatTick tickish) body = mkTick tickish body diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs index 5cfd057299..bdb0ab7834 100644 --- a/compiler/GHC/HsToCore/Arrows.hs +++ b/compiler/GHC/HsToCore/Arrows.hs @@ -199,7 +199,7 @@ coreCaseTuple uniqs scrut_var vars body coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr coreCasePair scrut_var var1 var2 body = Case (Var scrut_var) scrut_var (exprType body) - [Alt (DataAlt (tupleDataCon Boxed 2)) [var1, var2] body] + [Alt (DataAlt (tupleDataCon Boxed 2)) NoFreq [var1, var2] body] mkCorePairTy :: Type -> Type -> Type mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2] diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs index 602de4070a..dfd831d0da 100644 --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -917,7 +917,7 @@ decomposeRuleLhs dflags orig_bndrs orig_lhs where (bs, body') = split_lets body -- handle "unlifted lets" too, needed for "map/coerce" - split_lets (Case r d _ [Alt DEFAULT _ body]) + split_lets (Case r d _ [Alt DEFAULT NoFreq _ body]) | isCoVar d = ((d,r):bs, body') where (bs, body') = split_lets body diff --git a/compiler/GHC/HsToCore/Foreign/Call.hs b/compiler/GHC/HsToCore/Foreign/Call.hs index 26331002f3..dd2ae44b5d 100644 --- a/compiler/GHC/HsToCore/Foreign/Call.hs +++ b/compiler/GHC/HsToCore/Foreign/Call.hs @@ -156,7 +156,7 @@ unboxArg arg \ body -> Case (mkIfThenElse arg (mkIntLit platform 1) (mkIntLit platform 0)) prim_arg (exprType body) - [Alt DEFAULT [] body]) + [Alt DEFAULT NoFreq [] body]) -- Data types with a single constructor, which has a single, primitive-typed arg -- This deals with Int, Float etc; also Ptr, ForeignPtr @@ -166,7 +166,7 @@ unboxArg arg do case_bndr <- newSysLocalDs Many arg_ty prim_arg <- newSysLocalDs Many data_con_arg_ty1 return (Var prim_arg, - \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) [prim_arg] body] + \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) NoFreq [prim_arg] body] ) -- Byte-arrays, both mutable and otherwise; hack warning @@ -181,7 +181,7 @@ unboxArg arg = do case_bndr <- newSysLocalDs Many arg_ty vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs (map unrestricted data_con_arg_tys) return (Var arr_cts_var, - \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) vars body] + \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) NoFreq vars body] ) | otherwise @@ -273,7 +273,7 @@ mk_alt return_result (Nothing, wrap_result) (wrap_result (panic "boxResult")) ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy] - the_alt = Alt (DataAlt (tupleDataCon Unboxed 1)) [state_id] the_rhs + the_alt = Alt (DataAlt (tupleDataCon Unboxed 1)) NoFreq [state_id] the_rhs return (ccall_res_ty, the_alt) @@ -286,7 +286,7 @@ mk_alt return_result (Just prim_res_ty, wrap_result) ; let the_rhs = return_result (Var state_id) (wrap_result (Var result_id)) ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty] - the_alt = Alt (DataAlt (tupleDataCon Unboxed 2)) [state_id, result_id] the_rhs + the_alt = Alt (DataAlt (tupleDataCon Unboxed 2)) NoFreq [state_id, result_id] the_rhs ; return (ccall_res_ty, the_alt) } @@ -321,8 +321,8 @@ resultWrapper result_ty ; let platform = targetPlatform dflags ; let marshal_bool e = mkWildCase e (unrestricted intPrimTy) boolTy - [ Alt DEFAULT [] (Var trueDataConId ) - , Alt (LitAlt (mkLitInt platform 0)) [] (Var falseDataConId)] + [ Alt DEFAULT NoFreq [] (Var trueDataConId ) + , Alt (LitAlt (mkLitInt platform 0)) NoFreq [] (Var falseDataConId)] ; return (Just intPrimTy, marshal_bool) } -- Newtypes diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs index 3f649903a1..2a13fdd58c 100644 --- a/compiler/GHC/HsToCore/ListComp.hs +++ b/compiler/GHC/HsToCore/ListComp.hs @@ -26,6 +26,7 @@ import GHC.HsToCore.Utils import GHC.Driver.Session import GHC.Core.Utils +import GHC.Types.Basic import GHC.Types.Id import GHC.Core.Type import GHC.Builtin.Types @@ -293,8 +294,8 @@ deBindComp pat core_list1 quals core_list2 = do let rhs = Lam u1 $ Case (Var u1) u1 res_ty - [Alt (DataAlt nilDataCon) [] core_list2 - ,Alt (DataAlt consDataCon) [u2, u3] core_match] + [Alt (DataAlt nilDataCon) NoFreq [] core_list2 + ,Alt (DataAlt consDataCon) NoFreq [u2, u3] core_match] -- Increasing order of tag return (Let (Rec [(h, rhs)]) letrec_body) @@ -421,8 +422,8 @@ mkZipBind elt_tys = do mk_case (as, a', as') rest = Case (Var as) as elt_tuple_list_ty - [ Alt (DataAlt nilDataCon) [] (mkNilExpr elt_tuple_ty) - , Alt (DataAlt consDataCon) [a', as'] rest] + [ Alt (DataAlt nilDataCon) NoFreq [] (mkNilExpr elt_tuple_ty) + , Alt (DataAlt consDataCon) NoFreq [a', as'] rest] -- Increasing order of tag diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index 67a478907c..162b5450aa 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -27,7 +27,7 @@ import GHC.Platform import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr) -import GHC.Types.Basic ( Origin(..), isGenerated, Boxity(..) ) +import GHC.Types.Basic import GHC.Types.SourceText import GHC.Driver.Session import GHC.Hs @@ -259,7 +259,7 @@ matchEmpty var res_ty = return [MR_Fallible mk_seq] where mk_seq fail = return $ mkWildCase (Var var) (idScaledType var) res_ty - [Alt DEFAULT [] fail] + [Alt DEFAULT NoFreq [] fail] matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) -- Real true variables, just like in matchVar, SLPJ p 94 diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs index c1426474be..c12f8650d2 100644 --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -262,7 +262,7 @@ mkViewMatchResult var' viewExpr = fmap $ mkCoreLet $ NonRec var' viewExpr mkEvalMatchResult :: Id -> Type -> MatchResult CoreExpr -> MatchResult CoreExpr mkEvalMatchResult var ty = fmap $ \e -> - Case (Var var) var ty [Alt DEFAULT [] e] + Case (Var var) var ty [Alt DEFAULT NoFreq [] e] mkGuardedMatchResult :: CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr mkGuardedMatchResult pred_expr mr = MR_Fallible $ \fail -> do @@ -278,13 +278,13 @@ mkCoPrimCaseMatchResult var ty match_alts where mk_case fail = do alts <- mapM (mk_alt fail) sorted_alts - return (Case (Var var) var ty (Alt DEFAULT [] fail : alts)) + return (Case (Var var) var ty (Alt DEFAULT NoFreq [] fail : alts)) sorted_alts = sortWith fst match_alts -- Right order for a Case mk_alt fail (lit, mr) = assert (not (litIsLifted lit)) $ do body <- runMatchResult fail mr - return (Alt (LitAlt lit) [] body) + return (Alt (LitAlt lit) NoFreq [] body) data CaseAlt a = MkCaseAlt{ alt_pat :: a, alt_bndrs :: [Var], @@ -369,7 +369,7 @@ mkDataConCase var ty alts@(alt1 :| _) , alt_result = match_result } = flip adjustMatchResultDs match_result $ \body -> do case dataConBoxer con of - Nothing -> return (Alt (DataAlt con) args body) + Nothing -> return (Alt (DataAlt con) NoFreq args body) Just (DCB boxer) -> do us <- newUniqueSupply let (rep_ids, binds) = initUs_ us (boxer ty_args args) @@ -377,12 +377,12 @@ mkDataConCase var ty alts@(alt1 :| _) -- Upholds the invariant that the binders of a case expression -- must be scaled by the case multiplicity. See Note [Case -- expression invariants] in CoreSyn. - return (Alt (DataAlt con) rep_ids' (mkLets binds body)) + return (Alt (DataAlt con) NoFreq rep_ids' (mkLets binds body)) mk_default :: MatchResult (Maybe CoreAlt) mk_default | exhaustive_case = MR_Infallible $ return Nothing - | otherwise = MR_Fallible $ \fail -> return $ Just (Alt DEFAULT [] fail) + | otherwise = MR_Fallible $ \fail -> return $ Just (Alt DEFAULT NoFreq [] fail) mentioned_constructors = mkUniqSet $ map alt_pat sorted_alts un_mentioned_constructors @@ -537,7 +537,7 @@ There are a few subtleties in the desugaring of `seq`: mkCoreAppDs :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr mkCoreAppDs _ (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg2 | f `hasKey` seqIdKey -- Note [Desugaring seq], points (1) and (2) - = Case arg1 case_bndr ty2 [Alt DEFAULT [] arg2] + = Case arg1 case_bndr ty2 [Alt DEFAULT NoFreq [] arg2] where case_bndr = case arg1 of Var v1 | isInternalName (idName v1) @@ -1066,8 +1066,8 @@ mkBinaryTickBox ixT ixF e = do trueBox = Tick (HpcTick this_mod ixT) (Var trueDataConId) -- return $ Case e bndr1 boolTy - [ Alt (DataAlt falseDataCon) [] falseBox - , Alt (DataAlt trueDataCon) [] trueBox + [ Alt (DataAlt falseDataCon) NoFreq [] falseBox + , Alt (DataAlt trueDataCon) NoFreq [] trueBox ] diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index 41b1ad6b9e..75c26de2a0 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -512,7 +512,7 @@ collectCostCentres mod_name binds rules Type{} -> cs Coercion{} -> cs - go_alts = foldl' (\cs (Alt _con _bndrs e) -> go cs e) + go_alts = foldl' (\cs (Alt _con _freq _bndrs e) -> go cs e) go_bind :: S.Set CostCentre -> CoreBind -> S.Set CostCentre go_bind cs (NonRec b e) = @@ -896,7 +896,7 @@ dffvExpr (Case e b _ as) = dffvExpr e >> extendScope b (mapM_ dffvAlt as) dffvExpr _other = return () dffvAlt :: CoreAlt -> DFFV () -dffvAlt (Alt _ xs r) = extendScopeList xs (dffvExpr r) +dffvAlt (Alt _ _ xs r) = extendScopeList xs (dffvExpr r) dffvBind :: (Id, CoreExpr) -> DFFV () dffvBind(x,r) diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index 6806c887cc..150253fd02 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -1579,13 +1579,13 @@ tcIfaceAlt :: CoreExpr -> Mult -> (TyCon, [Type]) tcIfaceAlt _ _ _ (IfaceAlt IfaceDefault names rhs) = assert (null names) $ do rhs' <- tcIfaceExpr rhs - return (Alt DEFAULT [] rhs') + return (Alt DEFAULT NoFreq [] rhs') tcIfaceAlt _ _ _ (IfaceAlt (IfaceLitAlt lit) names rhs) = assert (null names) $ do lit' <- tcIfaceLit lit rhs' <- tcIfaceExpr rhs - return (Alt (LitAlt lit') [] rhs') + return (Alt (LitAlt lit') NoFreq [] rhs') -- A case alternative is made quite a bit more complicated -- by the fact that we omit type annotations because we can @@ -1607,7 +1607,7 @@ tcIfaceDataAlt mult con inst_tys arg_strs rhs ; rhs' <- extendIfaceEnvs ex_tvs $ extendIfaceIdEnv arg_ids $ tcIfaceExpr rhs - ; return (Alt (DataAlt con) (ex_tvs ++ arg_ids) rhs') } + ; return (Alt (DataAlt con) NoFreq (ex_tvs ++ arg_ids) rhs') } {- ************************************************************************ diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index 963fe9f9b1..8995048055 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -1611,10 +1611,10 @@ zonkCoreExpr env (Case scrut b ty alts) return $ Case scrut' b' ty' alts' zonkCoreAlt :: ZonkEnv -> CoreAlt -> TcM CoreAlt -zonkCoreAlt env (Alt dc bndrs rhs) +zonkCoreAlt env (Alt dc freq bndrs rhs) = do (env1, bndrs') <- zonkCoreBndrsX env bndrs rhs' <- zonkCoreExpr env1 rhs - return $ Alt dc bndrs' rhs' + return $ Alt dc freq bndrs' rhs' zonkCoreBind :: ZonkEnv -> CoreBind -> TcM (ZonkEnv, CoreBind) zonkCoreBind env (NonRec v e) diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs index b28ef41cae..4fd2ee1daa 100644 --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -17,8 +17,12 @@ types that {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# OPTIONS_GHC -ddump-simpl -ddump-to-file #-} module GHC.Types.Basic ( LeftOrRight(..), @@ -43,6 +47,8 @@ module GHC.Types.Basic ( OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag, + Comparison(..), flipComparison, + Boxity(..), isBoxed, PprPrec(..), topPrec, sigPrec, opPrec, funPrec, starPrec, appPrec, @@ -68,6 +74,8 @@ module GHC.Types.Basic ( TailCallInfo(..), tailCallInfo, zapOccTailCallInfo, isAlwaysTailCalled, + Freq(NoFreq, Freq), uniformFreqs, absToRelFreqs, normaliseFreqs, + EP(..), DefMethSpec(..), @@ -802,6 +810,32 @@ higher than 'funPrec' but lower than 'appPrec': {- ************************************************************************ * * + Comparison +* * +************************************************************************ +-} + +-- | Classifies a comparison operation +data Comparison + = Eq -- ^ Equal + | Ne -- ^ Not equal + | Lt -- ^ Less than + | Le -- ^ Less than or Equal + | Gt -- ^ Greater than + | Ge -- ^ Greater than or equal + +-- | Turns 'Gt' into 'Lt', etc., as if operands were flipped. +-- Makes use of (anti-)commutativity. +flipComparison :: Comparison -> Comparison +flipComparison Lt = Gt +flipComparison Le = Ge +flipComparison Gt = Lt +flipComparison Ge = Le +flipComparison cmp = cmp + +{- +************************************************************************ +* * Tuples * * ************************************************************************ @@ -1141,6 +1175,41 @@ instance Outputable (DefMethSpec ty) where ppr VanillaDM = text "{- Has default method -}" ppr (GenericDM {}) = text "{- Has generic default method -}" + +{- +************************************************************************ +* * + Branch frequency +* * +************************************************************************ +-} + + +-- | A type representing execution frequency of a particular branch/case alternative +newtype Freq = Freq { unFreq :: Float } + deriving (Eq, Ord, Num, Fractional, Data, Outputable) + +-- | A 'Freq' saying there was no frequency annotation. +pattern NoFreq :: Freq +pattern NoFreq <- (isNegativeZero . unFreq -> True) where + NoFreq = Freq (-0.0) + +-- | @n@ uniformly distributed list of 'Freq's that sum up to 1. +uniformFreqs :: Int -> [Freq] +uniformFreqs n = replicate n (Freq (1 / fromIntegral n)) + +-- | Turns @[1,2,3,2]@ into @[0.125, 0.25, 0.375, 0.25]@ +absToRelFreqs :: [Int] -> [Freq] +absToRelFreqs abs = [ Freq (fromIntegral a / total) | a <- abs ] + where + total = fromIntegral $ sum abs + +-- | Turns @[0.1,0.2,0.3,0.2]@ into @[0.125, 0.25, 0.375, 0.25]@ +normaliseFreqs :: [Freq] -> [Freq] +normaliseFreqs freqs = [ Freq (f / total) | Freq f <- freqs ] + where + Freq total = sum freqs + {- ************************************************************************ * * diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index 88a7a211cd..44fd5d0b4a 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -1501,7 +1501,7 @@ seqId = pcMiscPrelId seqName ty info [x,y] = mkTemplateLocals [alphaTy, openBetaTy] rhs = mkLams ([runtimeRep2TyVar, alphaTyVar, openBetaTyVar, x, y]) $ - Case (Var x) x openBetaTy [Alt DEFAULT [] (Var y)] + Case (Var x) x openBetaTy [Alt DEFAULT NoFreq [] (Var y)] ------------------------------------------------ lazyId :: Id -- See Note [lazyId magic] @@ -1624,7 +1624,7 @@ coerceId = pcMiscPrelId coerceName ty info [eqR,x,eq] = mkTemplateLocals [eqRTy, a, eqRPrimTy] rhs = mkLams (bndrs ++ [eqR, x]) $ mkWildCase (Var eqR) (unrestricted eqRTy) b $ - [Alt (DataAlt coercibleDataCon) [eq] (Cast (Var x) (mkCoVarCo eq))] + [Alt (DataAlt coercibleDataCon) NoFreq [eq] (Cast (Var x) (mkCoVarCo eq))] {- Note [seqId magic] diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 2023fbe3da..461c0ee73c 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -337,6 +337,7 @@ Library GHC.Core.Opt.CprAnal GHC.Core.Opt.CSE GHC.Core.Opt.DmdAnal + GHC.Core.Opt.ExecFreq GHC.Core.Opt.Exitify GHC.Core.Opt.FloatIn GHC.Core.Opt.FloatOut diff --git a/testsuite/tests/callarity/unittest/CallArity1.hs b/testsuite/tests/callarity/unittest/CallArity1.hs index 7f51426823..49d6050c67 100644 --- a/testsuite/tests/callarity/unittest/CallArity1.hs +++ b/testsuite/tests/callarity/unittest/CallArity1.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TupleSections, PatternSynonyms #-} import GHC.Core import GHC.Core.Utils +import GHC.Types.Basic import GHC.Types.Id import GHC.Core.Type import GHC.Core.Multiplicity ( pattern Many ) @@ -74,7 +75,7 @@ exprs = (mkLams [y] $ Var y) ) $ mkLams [z] $ Var d `mkVarApps` [x]) $ Case (go `mkLApps` [0, 0]) z intTy - [Alt DEFAULT [] (Var f `mkVarApps` [z,z])] + [Alt DEFAULT NoFreq [] (Var f `mkVarApps` [z,z])] , ("go2 (in function call)",) $ mkRFun go [x] (mkLetNonRec d (mkACase (Var go `mkVarApps` [x]) @@ -217,7 +218,7 @@ allBoundIds (Let (Rec binds) body) = allBoundIds (App e1 e2) = allBoundIds e1 `unionVarSet` allBoundIds e2 allBoundIds (Case scrut _ _ alts) = allBoundIds scrut `unionVarSet` unionVarSets - [ allBoundIds e | Alt _ _ e <- alts ] + [ allBoundIds e | Alt _ _ _ e <- alts ] allBoundIds (Lam _ e) = allBoundIds e allBoundIds (Tick _ e) = allBoundIds e allBoundIds (Cast e _) = allBoundIds e diff --git a/testsuite/tests/plugins/HomePackagePlugin.hs b/testsuite/tests/plugins/HomePackagePlugin.hs index 9349e833b1..284b9a35eb 100644 --- a/testsuite/tests/plugins/HomePackagePlugin.hs +++ b/testsuite/tests/plugins/HomePackagePlugin.hs @@ -31,4 +31,4 @@ replaceInExpr (Case e b ty alts) = Case (replaceInExpr e) b ty (map replaceInAlt replaceInExpr (Type ty) = Type ty replaceInAlt :: CoreAlt -> CoreAlt -replaceInAlt (Alt ac bs e) = Alt ac bs (replaceInExpr e) +replaceInAlt (Alt ac fq bs e) = Alt ac fq bs (replaceInExpr e) diff --git a/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs index caa41cef16..7b5e26701d 100644 --- a/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs +++ b/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs @@ -83,4 +83,4 @@ changeExpr anns mb_replacement e = let go = changeExpr anns mb_replacement in ca _ -> return e changeAlt :: VarEnv [ReplaceWith] -> Maybe String -> CoreAlt -> CoreM CoreAlt -changeAlt anns mb_replacement (Alt con bs e) = liftM (\e' -> Alt con bs e') (changeExpr anns mb_replacement e) +changeAlt anns mb_replacement (Alt con fq bs e) = liftM (\e' -> Alt con fq bs e') (changeExpr anns mb_replacement e) diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index 06a4922aa3..fa4605fb69 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -830,10 +830,10 @@ mkPOI_LHS_text i mkPOI_RHS_text :: Entry -> String mkPOI_RHS_text i = case cat i of - Compare + Compare cmp -> case ty i of TyF t1 (TyF _ _) - -> "mkCompare " ++ sl_name i ++ ppType t1 + -> "mkCompare " ++ sl_name i ++ cmp ++ " " ++ ppType t1 _ -> error "Type error in comparison op" GenPrimOp -> let (argTys, resTy) = flatTys (ty i) diff --git a/utils/genprimopcode/Parser.y b/utils/genprimopcode/Parser.y index f39af24c7c..a32b8d8824 100644 --- a/utils/genprimopcode/Parser.y +++ b/utils/genprimopcode/Parser.y @@ -120,7 +120,7 @@ pWithOptions : with pOptions { $2 } | {- empty -} { [] } pCategory :: { Category } -pCategory : compare { Compare } +pCategory : '(' compare upperName ')' { Compare $3 } | genprimop { GenPrimOp } pDesc :: { String } @@ -148,7 +148,7 @@ pVectors : pVector ',' pVectors { [$1] ++ $3 } pVector :: { (String, String, Int) } pVector : '<' upperName ',' upperName ',' integer '>' { ($2, $4, $6) } - + pType :: { Ty } pType : paT '->' pType { TyF $1 $3 } | paT '=>' pType { TyC $1 $3 } diff --git a/utils/genprimopcode/Syntax.hs b/utils/genprimopcode/Syntax.hs index e215a89478..f087cdff94 100644 --- a/utils/genprimopcode/Syntax.hs +++ b/utils/genprimopcode/Syntax.hs @@ -65,7 +65,7 @@ data Option -- categorises primops data Category - = Compare | GenPrimOp + = Compare String | GenPrimOp deriving Show -- types @@ -74,7 +74,7 @@ data Ty | TyC Ty Ty -- We only allow one constraint, keeps the grammar simpler | TyApp TyCon [Ty] | TyVar TyVar - | TyUTup [Ty] -- unboxed tuples; just a TyCon really, + | TyUTup [Ty] -- unboxed tuples; just a TyCon really, -- but convenient like this deriving (Eq,Show) @@ -115,9 +115,9 @@ data SourceText = SourceText String {- Do some simple sanity checks: * all the default field names are unique * for each PrimOpSpec, all override field names are unique - * for each PrimOpSpec, all overridden field names + * for each PrimOpSpec, all overridden field names have a corresponding default value - * that primop types correspond in certain ways to the + * that primop types correspond in certain ways to the Category: eg if Comparison, the type must be of the form T -> T -> Bool. Dies with "error" if there's a problem, else returns (). @@ -130,7 +130,7 @@ sanityTop :: Info -> () sanityTop (Info defs entries) = let opt_names = map get_attrib_name defs primops = filter is_primop entries - in + in if length opt_names /= length (nub opt_names) then error ("non-unique default attribute names: " ++ show opt_names ++ "\n") else myseqAll (map (sanityPrimOp opt_names) primops) () @@ -153,7 +153,7 @@ sanityPrimOp def_names p else () sane_ty :: Category -> Ty -> Bool -sane_ty Compare (TyF t1 (TyF t2 td)) +sane_ty (Compare _cmp) (TyF t1 (TyF t2 td)) | t1 == t2 && td == TyApp (TyCon "Int#") [] = True sane_ty GenPrimOp _ = True @@ -170,7 +170,7 @@ get_attrib_name (OptionFixity _) = "fixity" lookup_attrib :: String -> [Option] -> Maybe Option lookup_attrib _ [] = Nothing -lookup_attrib nm (a:as) +lookup_attrib nm (a:as) = if get_attrib_name a == nm then Just a else lookup_attrib nm as is_vector :: Entry -> Bool |