Simon Peyton Jones pushed to branch wip/T26989 at Glasgow Haskell Compiler / GHC Commits: 74d3772d by Simon Peyton Jones at 2026-05-02T00:55:09+01:00 Make builtin rules return arguments - - - - - 11 changed files: - compiler/GHC/Core.hs - compiler/GHC/Core/Make.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/HsToCore/Pmc/Solver.hs - compiler/GHC/Types/Id/Make.hs Changes: ===================================== compiler/GHC/Core.hs ===================================== @@ -84,9 +84,13 @@ module GHC.Core ( IsOrphan(..), isOrphan, notOrphan, chooseOrphanAnchor, -- * Core rule data types - CoreRule(..), + CoreRule(..), RuleMatch(..), RuleName, RuleFun, IdUnfoldingFun, InScopeEnv(..), RuleOpts, + -- * Floats + FloatBind(..), FloatBinds, emptyFloatBinds, isEmptyFloatBinds, + floatBinders, floatsBinders, + -- ** Operations on 'CoreRule's ruleArity, ruleName, ruleIdName, ruleActivation, setRuleIdName, ruleModule, @@ -116,6 +120,8 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Data.OrdList + import Data.Data hiding (TyCon) import Data.Int import Data.List.NonEmpty (nonEmpty) @@ -1574,7 +1580,25 @@ data CoreRule } -- See Note [Extra args in the target] in GHC.Core.Rules -type RuleFun = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr +type RuleFun = RuleOpts -> InScopeEnv + -> Id -> [CoreExpr] -- Function applied to these arguments + -> Maybe RuleMatch + +data RuleMatch + = RM { rm_rule :: CoreRule + , rm_rhs :: CoreExpr -- Rhs of the rule + , rm_args :: [CoreExpr] -- The args of the RHS + , rm_floats :: FloatBinds -- Floated let-bindings + -- See Note [Matching lets] + } + -- E.g. match r = RULE forall x,y. f (Just (y,x)) = g x y True + -- target f (let v = ev in Just (ey, ex)) ez + -- We get the RuleMatch + -- RMM { rm_rule = r, rm_rhs = \xy. g x y True + -- , rm_args = [ex, ey] + -- , rm_floats = Let v=ev } + -- The leftover `ez` is not returned; the caller is responsible for + -- counting (ruleArity r) arguments -- | The 'InScopeSet' in the 'InScopeEnv' is a /superset/ of variables that are -- currently in scope. See Note [The InScopeSet invariant]. @@ -1622,6 +1646,37 @@ isLocalRule (Rule { ru_local = is_local }) = is_local setRuleIdName :: Name -> CoreRule -> CoreRule setRuleIdName nm ru = ru { ru_fn = nm } +{- +************************************************************************ +* * + Floats +* * +************************************************************************ +-} + +type FloatBinds = OrdList FloatBind + +emptyFloatBinds :: FloatBinds +emptyFloatBinds = nilOL + +isEmptyFloatBinds :: FloatBinds -> Bool +isEmptyFloatBinds = isNilOL + +data FloatBind + = FloatLet CoreBind + | FloatCase CoreExpr CoreBndr AltCon [CoreBndr] + -- case e of y { C ys -> ... } + -- See Note [Floating single-alternative cases] in GHC.Core.Opt.SetLevels + | FloatTick CoreTickish + +floatsBinders :: FloatBinds -> [Var] +floatsBinders fs = foldr ((++) . floatBinders) [] fs + +floatBinders :: FloatBind -> [Var] +floatBinders (FloatLet bnd) = bindersOf bnd +floatBinders (FloatCase _ b _ bs) = b:bs +floatBinders (FloatTick {}) = [] + {- ************************************************************************ * * ===================================== compiler/GHC/Core/Make.hs ===================================== @@ -18,11 +18,6 @@ module GHC.Core.Make ( mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith, MkStringIds (..), getMkStringIds, - -- * Floats - FloatBind(..), FloatBinds, - wrapFloat, wrapFloats, floatBindings, - emptyFloatBinds, isEmptyFloatBinds, - -- * Constructing small tuples mkCoreVarTupTy, mkCoreTup, mkCoreUnboxedTuple, mkCoreUnboxedSum, mkCoreTupBoxity, unitExpr, @@ -43,6 +38,9 @@ module GHC.Core.Make ( -- * Constructing Maybe expressions mkNothingExpr, mkJustExpr, + -- * Floats + wrapFloat, wrapFloats, + -- * Error Ids mkRuntimeErrorApp, mkImpossibleExpr, mkAbsentErrorApp, errorIds, rEC_CON_ERROR_ID, @@ -63,7 +61,6 @@ import GHC.Types.Basic( TypeOrConstraint(..) ) import GHC.Types.Demand import GHC.Types.Name hiding ( varName ) import GHC.Types.Literal -import GHC.Types.Tickish import GHC.Types.Unique.Supply import GHC.Core @@ -740,54 +737,6 @@ mkSmallTupleCase vars body scrut_var scrut = Case scrut scrut_var (exprType body) [Alt (DataAlt (tupleDataCon Boxed (length vars))) vars body] -{- -************************************************************************ -* * - Floats -* * -************************************************************************ --} - -type FloatBinds = OrdList FloatBind - -emptyFloatBinds :: FloatBinds -emptyFloatBinds = nilOL - -isEmptyFloatBinds :: FloatBinds -> Bool -isEmptyFloatBinds = isNilOL - -data FloatBind - = FloatLet CoreBind - | FloatCase CoreExpr Id AltCon [Var] - -- case e of y { C ys -> ... } - -- See Note [Floating single-alternative cases] in GHC.Core.Opt.SetLevels - | FloatTick CoreTickish - -instance Outputable FloatBind where - ppr (FloatTick t) = text "TICK" <+> ppr t - ppr (FloatLet b) = text "LET" <+> ppr b - ppr (FloatCase e b c bs) = hang (text "CASE" <+> ppr e <+> text "of" <+> ppr b) - 2 (ppr c <+> ppr bs) - -wrapFloat :: FloatBind -> CoreExpr -> CoreExpr -wrapFloat (FloatTick t) body = mkTick t body -wrapFloat (FloatLet defns) body = Let defns body -wrapFloat (FloatCase e b con bs) body = mkSingleAltCase e b con bs body - --- | Applies the floats from right to left. That is @wrapFloats [b1, b2, …, bn] --- u = let b1 in let b2 in … in let bn in u@ -wrapFloats :: FloatBinds -> CoreExpr -> CoreExpr -wrapFloats floats expr = foldrOL wrapFloat expr floats - -bindBindings :: CoreBind -> [Var] -bindBindings (NonRec b _) = [b] -bindBindings (Rec bnds) = map fst bnds - -floatBindings :: FloatBind -> [Var] -floatBindings (FloatLet bnd) = bindBindings bnd -floatBindings (FloatCase _ b _ bs) = b:bs -floatBindings (FloatTick {}) = [] - {- ************************************************************************ * * @@ -867,6 +816,25 @@ mkJustExpr :: Type -> CoreExpr -> CoreExpr mkJustExpr ty val = mkConApp justDataCon [Type ty, val] +{- +************************************************************************ +* * + Manipulating Floats +* * +************************************************************************ +-} + +wrapFloat :: FloatBind -> CoreExpr -> CoreExpr +wrapFloat (FloatTick t) body = mkTick t body +wrapFloat (FloatLet defns) body = Let defns body +wrapFloat (FloatCase e b con bs) body = mkSingleAltCase e b con bs body + +-- | Applies the floats from right to left. That is @wrapFloats [b1, b2, …, bn] +-- u = let b1 in let b2 in … in let bn in u@ +wrapFloats :: FloatBinds -> CoreExpr -> CoreExpr +wrapFloats floats expr = foldrOL wrapFloat expr floats + + {- ************************************************************************ * * ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -870,7 +870,7 @@ primOpRules nm = \case -- useful shorthands mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule -mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules) +mkPrimOpRule nm arity rules = Just $ mkBasicRule1 nm arity (msum rules) mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool) -> [RuleM CoreExpr] -> Maybe CoreRule @@ -1679,16 +1679,35 @@ but that is only a historical accident. ************************************************************************ -} -mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule +mkBasicRule1 :: Name -> Int -> RuleM CoreExpr -> CoreRule -- Gives the Rule the same name as the primop itself -mkBasicRule op_name n_args rm - = BuiltinRule { ru_name = occNameFS (nameOccName op_name), - ru_fn = op_name, - ru_nargs = n_args, - ru_try = runRuleM rm } - -newtype RuleM r = RuleM - { runRuleM :: RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe r } +mkBasicRule1 op_name n_args rm + = mkBasicRule (occNameFS (nameOccName op_name)) op_name n_args rm + +mkBasicRule :: RuleName -> Name -> Int -> RuleM CoreExpr -> CoreRule +-- The Builtin rules in this module all produce an expression +-- with no args; hence rm_args = []. The `rm_rhs` is the complete +-- result of the rule rewrite. This is OK because it's always +-- small (I think). +mkBasicRule rule_name op_name n_args rm + = rule + where + rule = BuiltinRule { ru_name = rule_name + , ru_fn = op_name + , ru_nargs = n_args + , ru_try = try } + + try opts in_scope fn args + = case runRuleM rm opts in_scope fn args of + Nothing -> Nothing + Just rhs -> Just (RM { rm_rule = rule + , rm_rhs = rhs + , rm_args = [] + , rm_floats = emptyFloatBinds }) + +type CFRuleFun r = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe r + +newtype RuleM r = RuleM { runRuleM :: CFRuleFun r } deriving (Functor) instance Applicative RuleM where @@ -2132,28 +2151,16 @@ is fine. builtinRules :: [CoreRule] -- Rules for non-primops that can't be expressed using a RULE pragma builtinRules - = [BuiltinRule { ru_name = fsLit "CStringFoldrLit", - ru_fn = unpackCStringFoldrName, - ru_nargs = 4, ru_try = match_cstring_foldr_lit_C }, - BuiltinRule { ru_name = fsLit "CStringFoldrLitUtf8", - ru_fn = unpackCStringFoldrUtf8Name, - ru_nargs = 4, ru_try = match_cstring_foldr_lit_utf8 }, - BuiltinRule { ru_name = fsLit "CStringAppendLit", - ru_fn = unpackCStringAppendName, - ru_nargs = 2, ru_try = match_cstring_append_lit_C }, - BuiltinRule { ru_name = fsLit "CStringAppendLitUtf8", - ru_fn = unpackCStringAppendUtf8Name, - ru_nargs = 2, ru_try = match_cstring_append_lit_utf8 }, - BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName, - ru_nargs = 2, ru_try = match_eq_string }, - BuiltinRule { ru_name = fsLit "CStringLength", ru_fn = cstringLengthName, - ru_nargs = 1, ru_try = match_cstring_length }, - BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName, - ru_nargs = 2, ru_try = \_ _ _ -> match_inline }, - - mkBasicRule unsafeEqualityProofName 3 unsafeEqualityProofRule, - - mkBasicRule divIntName 2 $ msum + = [ mkBasicRule1 unpackCStringFoldrName 4 (RuleM match_cstring_foldr_lit_C) + , mkBasicRule1 unpackCStringFoldrUtf8Name 4 (RuleM match_cstring_foldr_lit_utf8) + , mkBasicRule1 unpackCStringAppendName 2 (RuleM match_cstring_append_lit_C) + , mkBasicRule1 unpackCStringAppendUtf8Name 2 (RuleM match_cstring_append_lit_utf8) + , mkBasicRule1 eqStringName 2 (RuleM match_eq_string) + , mkBasicRule1 cstringLengthName 1 (RuleM match_cstring_length) + , mkBasicRule1 inlineIdName 2 (RuleM match_inline) + , mkBasicRule1 unsafeEqualityProofName 3 unsafeEqualityProofRule + + , mkBasicRule1 divIntName 2 $ msum [ nonZeroLit 1 >> binaryLit (intOp2 div) , leftZero , do @@ -2161,9 +2168,9 @@ builtinRules Just n <- return $ exactLog2 d platform <- getPlatform return $ Var (primOpId IntSraOp) `App` arg `App` mkIntVal platform n - ], + ] - mkBasicRule modIntName 2 $ msum + , mkBasicRule1 modIntName 2 $ msum [ nonZeroLit 1 >> binaryLit (intOp2 mod) , leftZero , do @@ -2322,15 +2329,9 @@ builtinBignumRules = encodeLitDouble LitDouble ] where - mkRule str name nargs f = BuiltinRule - { ru_name = fsLit str - , ru_fn = name - , ru_nargs = nargs - , ru_try = runRuleM $ do - env <- getRuleOpts - guard (roBignumRules env) - f - } + mkRule str name nargs f = mkBasicRule (fsLit str) name nargs rm + where + rm = do { env <- getRuleOpts; guard (roBignumRules env); f } integer_to_lit str name convert = mkRule str name 1 $ do [a0] <- getArgs @@ -2506,15 +2507,15 @@ builtinBignumRules = -- -- CString version -match_cstring_append_lit_C :: RuleFun +match_cstring_append_lit_C :: CFRuleFun CoreExpr match_cstring_append_lit_C = match_cstring_append_lit unpackCStringAppendIdKey unpackCStringIdKey -- CStringUTF8 version -match_cstring_append_lit_utf8 :: RuleFun +match_cstring_append_lit_utf8 :: CFRuleFun CoreExpr match_cstring_append_lit_utf8 = match_cstring_append_lit unpackCStringAppendUtf8IdKey unpackCStringUtf8IdKey {-# INLINE match_cstring_append_lit #-} -match_cstring_append_lit :: Unique -> Unique -> RuleFun +match_cstring_append_lit :: Unique -> Unique -> CFRuleFun CoreExpr match_cstring_append_lit append_key unpack_key _ env _ [lit1, e2] | Just (LitString s1) <- exprIsLiteral_maybe env lit1 , (strTicks, Var unpk `App` lit2) <- stripStrTopTicks env e2 @@ -2540,15 +2541,15 @@ match_cstring_append_lit _ _ _ _ _ _ = Nothing -- See also Note [String literals in GHC] in CString.hs -- CString version -match_cstring_foldr_lit_C :: RuleFun +match_cstring_foldr_lit_C :: CFRuleFun CoreExpr match_cstring_foldr_lit_C = match_cstring_foldr_lit unpackCStringFoldrIdKey -- CStringUTF8 version -match_cstring_foldr_lit_utf8 :: RuleFun +match_cstring_foldr_lit_utf8 :: CFRuleFun CoreExpr match_cstring_foldr_lit_utf8 = match_cstring_foldr_lit unpackCStringFoldrUtf8IdKey {-# INLINE match_cstring_foldr_lit #-} -match_cstring_foldr_lit :: Unique -> RuleFun +match_cstring_foldr_lit :: Unique -> CFRuleFun CoreExpr match_cstring_foldr_lit foldVariant _ env _ [ Type ty1 , lit1 @@ -2595,7 +2596,7 @@ stripStrTopTicksT e = stripTicksTopT tickishFloatable e -- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2 -- Also matches unpackCStringUtf8# -match_eq_string :: RuleFun +match_eq_string :: CFRuleFun CoreExpr match_eq_string _ env _ [e1, e2] | (ticks1, Var unpk1 `App` lit1) <- stripStrTopTicks env e1 , (ticks2, Var unpk2 `App` lit2) <- stripStrTopTicks env e2 @@ -2628,7 +2629,7 @@ match_eq_string _ _ _ _ = Nothing -- helpful when using OverloadedStrings to create a ByteString since the -- function computing the length of such ByteStrings can often be constant -- folded. -match_cstring_length :: RuleFun +match_cstring_length :: CFRuleFun CoreExpr match_cstring_length rule_env env _ [lit1] | Just (LitString str) <- exprIsLiteral_maybe env lit1 -- If elemIndex returns Just, it has the index of the first embedded NUL @@ -2676,8 +2677,8 @@ The moving parts are simple: Also, don't forget about 'inline's type argument! -} -match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_inline (Type _ : e : _) = go e +match_inline :: CFRuleFun CoreExpr +match_inline _ _ _ (Type _ : e : _) = go e -- Maybe Monad ahead: where go (Var f) = -- Ignore the IdUnfoldingFun here! @@ -2689,7 +2690,7 @@ match_inline (Type _ : e : _) = go e go (Tick t e) = do { app <- go e; pure (Tick t app) } go _ = Nothing -match_inline _ = Nothing +match_inline _ _ _ _ = Nothing -------------------------------------------------------- -- Note [Constant folding through nested expressions] ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -42,7 +42,7 @@ import GHC.Core.Opt.Arity ( ArityType, exprArity, arityTypeBotSigs_maybe , typeArity, arityTypeArity, etaExpandAT ) import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe ) import GHC.Core.FVs ( mkRuleInfo {- exprsFreeIds -} ) -import GHC.Core.Rules ( RuleMatch(..), lookupRule, getRules ) +import GHC.Core.Rules ( lookupRule, getRules ) import GHC.Core.Multiplicity import GHC.Hs.Extension @@ -2486,11 +2486,11 @@ simplOutId env fun cont else return Nothing ; case mb_match of { Just (RM { rm_rule = rule, rm_rhs = rhs - , rm_args = rhs_args, rm_binds = wrap }) + , rm_args = rhs_args, rm_floats = float_bs }) -> simplExprF env rhs' $ dropContArgs (ruleArity rule) cont where - rhs' = GHC.Core.Make.wrapFloats wrap $ + rhs' = GHC.Core.Make.wrapFloats float_bs $ mkApps rhs rhs_args ; Nothing -> @@ -2765,15 +2765,15 @@ fireRuleAFTER :: SimplEnv -> RuleMatch -> SimplM (SimplFloats, CoreExpr) fireRuleAFTER env rule_match arg_specs cont | RM { rm_rule = rule, rm_rhs = rhs, rm_args = rhs_args - , rm_binds = wrap, rm_bndrs = bndrs } <- rule_match - = do { let env' = env `addNewInScopeIds` bndrs + , rm_floats = float_bs } <- rule_match + = do { let env' = env `addNewInScopeIds` floatsBinders float_bs ; (floats, e') <- simplExprF env' rhs $ pushOutArgs (exprType rhs) rhs_args $ pushArgSpecs (drop (ruleArity rule) arg_specs) cont ; return $ - if isEmptyFloatBinds wrap -- Not very pretty + if isEmptyFloatBinds float_bs -- Not very pretty then (floats, e') - else (emptyFloats env', GHC.Core.Make.wrapFloats wrap $ + else (emptyFloats env', GHC.Core.Make.wrapFloats float_bs $ wrapFloats floats e') } @@ -3895,10 +3895,10 @@ wrapDataConFloats env wfloats case_bndr cont thing_inside -- scale_float scales case-floats by the multiplicity of the continuation hole -- (see Note [Scaling in case-of-case]). -- Let floats are _not_ scaled, because they are aliases anyway. - scale_float (GHC.Core.Make.FloatCase scrut case_bndr con vars) - = GHC.Core.Make.FloatCase scrut (scale_id case_bndr) con (map scale_id vars) - scale_float flt@(GHC.Core.Make.FloatLet {}) = flt - scale_float flt@(GHC.Core.Make.FloatTick {}) = flt + scale_float (GHC.Core.FloatCase scrut case_bndr con vars) + = GHC.Core.FloatCase scrut (scale_id case_bndr) con (map scale_id vars) + scale_float flt@(GHC.Core.FloatLet {}) = flt + scale_float flt@(GHC.Core.FloatTick {}) = flt scale_id id = scaleVarBy holeScaling id ===================================== compiler/GHC/Core/Opt/SpecConstr.hs ===================================== @@ -2906,8 +2906,8 @@ betterPat is (CP { cp_qvars = vs1, cp_args = as1 }) (CP { cp_qvars = vs2, cp_args = as2 }) | equalLength as1 as2 = case matchExprs ise vs1 as1 as2 of - Just (ms,_,_) -> all exprIsTrivial ms - Nothing -> False + Just (ms,_) -> all exprIsTrivial ms + Nothing -> False | otherwise -- We must handle patterns of unequal length separately (#24282) = False -- For the pattern with more args, the last arg is "interesting" ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -1823,8 +1823,8 @@ specLookupRule env fn args is_active rules | otherwise = case lookupRule ropts in_scope_env is_active fn args rules of Just (RM { rm_rule = rule, rm_rhs = rule_rhs - , rm_binds = wrap, rm_args = rule_args }) - -> Just (rule, wrapFloats wrap (mkApps rule_rhs rule_args)) + , rm_floats = float_bs, rm_args = rule_args }) + -> Just (rule, wrapFloats float_bs (mkApps rule_rhs rule_args)) Nothing -> Nothing where dflags = se_dflags env ===================================== compiler/GHC/Core/Ppr.hs ===================================== @@ -80,6 +80,12 @@ instance OutputableBndr b => Outputable (Expr b) where instance OutputableBndr b => Outputable (Alt b) where ppr expr = pprCoreAlt expr +instance Outputable FloatBind where + ppr (FloatTick t) = text "TICK" <+> ppr t + ppr (FloatLet b) = text "LET" <+> ppr b + ppr (FloatCase e b c bs) = hang (text "CASE" <+> ppr e <+> text "of" <+> ppr b) + 2 (ppr c <+> ppr bs) + {- ************************************************************************ * * ===================================== compiler/GHC/Core/Rules.hs ===================================== @@ -543,22 +543,6 @@ map. ************************************************************************ -} -data RuleMatch - = RM { rm_rule :: CoreRule - , rm_rhs :: CoreExpr - , rm_args :: [CoreExpr] - , rm_binds :: FloatBinds -- Floated let-bindings - -- See Note [Matching lets] - , rm_bndrs :: [Var] -- Binders of rm_binds - } - -- E.g. match r = RULE forall x,y. f (Just (y,x)) = g x y True - -- target f (let v = ev in Just (ey, ex)) ez - -- We get the RuleMatch - -- RMM { rm_rule = r, rm_rhs = \xy. g x y True - -- , rm_args = [ex, ey] - -- , rm_binds = Let v=ev, rm_bndrs = [v] ) - -- The leftover `ez` is not returned; the caller is responsible for - -- counting (ruleArity r) arguments -- | The main rule matching function. Attempts to apply all (active) -- supplied rules to this instance of an application in a given @@ -592,7 +576,7 @@ lookupRule opts rule_env@(ISE in_scope _) is_active fn args rules go ms [] = ms go ms (r:rs) | Just rm <- matchRule opts rule_env is_active fn args' rough_args r - = go (rm { rm_binds = toOL (map FloatTick ticks) `appOL` rm_binds rm } : ms) rs + = go (rm { rm_floats = toOL (map FloatTick ticks) `appOL` rm_floats rm } : ms) rs | otherwise = -- pprTrace "match failed" (ppr r $$ ppr args $$ -- ppr [ (arg_id, maybeUnfoldingTemplate unf) @@ -741,14 +725,9 @@ matchRule :: HasDebugCallStack -- of the actual arguments. matchRule opts rule_env _is_active fn args _rough_args - rule@(BuiltinRule { ru_try = match_fn }) + (BuiltinRule { ru_try = match_fn }) = do { guard (roBuiltinRules opts) - ; rhs <- match_fn opts rule_env fn args - ; return (RM { rm_rule = rule - , rm_rhs = rhs - , rm_args = [] - , rm_binds = emptyFloatBinds - , rm_bndrs = [] }) } + ; match_fn opts rule_env fn args } matchRule _opts rule_env is_active _fn target_es rough_args rule@(Rule { ru_act = act, ru_rough = tpl_tops @@ -758,25 +737,22 @@ matchRule _opts rule_env is_active _fn target_es rough_args | ruleCantMatch tpl_tops rough_args = Nothing | otherwise - = do { (matched_es, bind_wrapper, wrap_bndrs) - <- matchExprs rule_env tpl_vars tpl_args target_es - + = do { (matched_es, float_bs) <- matchExprs rule_env tpl_vars tpl_args target_es ; return (RM { rm_rule = rule , rm_rhs = mkLams tpl_vars rhs , rm_args = matched_es - , rm_binds = bind_wrapper - , rm_bndrs = wrap_bndrs }) } + , rm_floats = float_bs }) } matchExprs :: HasDebugCallStack => InScopeEnv -> [Var] -> [CoreExpr] -> [CoreExpr] - -> Maybe ( [CoreExpr] -- 1-1 with the incoming [Var] - , FloatBinds, [Var]) -- Floated binds + -> Maybe ( [CoreExpr] -- 1-1 with the incoming [Var] + , FloatBinds ) -- Floated binds matchExprs (ISE in_scope id_unf) tmpl_vars tmpl_es target_es = do { rule_subst <- match_exprs init_menv emptyRuleSubst tmpl_es target_es ; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst) (mkEmptySubst in_scope) $ tmpl_vars `zip` tmpl_vars1 - ; return (matched_es, rs_binds rule_subst, rs_bndrs rule_subst) } + ; return (matched_es, rs_binds rule_subst) } where (init_rn_env, tmpl_vars1) = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars -- See Note [Cloning the template binders] ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -32,9 +32,9 @@ import GHC.Builtin.Types.Prim import GHC.Core.Utils import GHC.Core.Opt.Arity import GHC.Core.Lint ( EndPassConfig(..), endPassIO ) -import GHC.Core +import GHC.Core hiding( FloatBind(..) ) import GHC.Core.Subst -import GHC.Core.Make hiding( FloatBind(..) ) -- We use our own FloatBind here +import GHC.Core.Make import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.TyCon @@ -2108,6 +2108,8 @@ instance Outputable FloatInfo where -- See Note [Floating in CorePrep] -- and Note [BindInfo and FloatInfo] +-- This data type is very like GHC.Core.FloatBind, +-- but with extra info on the let-bindings data FloatingBind = Float !CoreBind !BindInfo !FloatInfo -- Never a join-point binding | UnsafeEqualityCase !CoreExpr !CoreBndr !AltCon ![CoreBndr] ===================================== compiler/GHC/HsToCore/Pmc/Solver.hs ===================================== @@ -65,7 +65,7 @@ import GHC.Core.Map.Expr import GHC.Core.Predicate (typeDeterminesValue, mkNomEqPred) import GHC.Core.SimpleOpt (simpleOptExpr, exprIsConApp_maybe) import GHC.Core.Utils (exprType) -import GHC.Core.Make (mkListExpr, mkCharExpr, mkImpossibleExpr, isEmptyFloatBinds) +import GHC.Core.Make (mkListExpr, mkCharExpr, mkImpossibleExpr) import GHC.Data.FastString import GHC.Types.SrcLoc ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -513,11 +513,7 @@ mkDictSelId name clas -- This is the built-in rule that goes -- op (dfT d1 d2) ---> opT d1 d2 - rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS` - occNameFS (getOccName name) - , ru_fn = name - , ru_nargs = n_ty_args + 1 - , ru_try = dictSelRule val_index n_ty_args } + rule = dictSelRule name n_ty_args val_index -- The strictness signature is of the form U(AAAVAAAA) -> T -- where the V depends on which item we are selecting @@ -561,20 +557,35 @@ mkDictSelRhs clas val_index -- varToCoreExpr needed for equality superclass selectors -- sel a b d = case x of { MkC _ (g:a~b) _ -> CO g } -dictSelRule :: Int -> Arity -> RuleFun +dictSelRule :: Name -> Arity -> Int -> CoreRule -- Tries to persuade the argument to look like a constructor -- application, using exprIsConApp_maybe, and then selects -- from it -- sel_i t1..tk (D t1..tk op1 ... opm) = opi -- -- See Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance -dictSelRule val_index n_ty_args _ in_scope_env _ args - | (dict_arg : _) <- drop n_ty_args args - , Just (_, floats, _, _, con_args) - <- exprIsConApp_maybe in_scope_env dict_arg - = Just (wrapFloats floats $ getNth con_args val_index) - | otherwise - = Nothing +dictSelRule name val_index n_ty_args + = rule + where + rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS` + occNameFS (getOccName name) + , ru_fn = name + , ru_nargs = n_ty_args + 1 + , ru_try = try } + + + try :: RuleFun + try _opts in_scope_env _fn args + | (dict_arg : _) <- drop n_ty_args args + , Just (_, floats, _, _, con_args) <- exprIsConApp_maybe in_scope_env dict_arg + , let meth_e = getNth con_args val_index + meth_id = mkTemplateLocal 1 (exprType meth_e) + = Just (RM { rm_floats = floats + , rm_rhs = Lam meth_id (Var meth_id) + , rm_args = [meth_e] + , rm_rule = rule }) + | otherwise + = Nothing {- ************************************************************************ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/74d3772d054e96fd2a25f3b810307966... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/74d3772d054e96fd2a25f3b810307966... You're receiving this email because of your account on gitlab.haskell.org.