[Git][ghc/ghc][wip/mco-in-exprIsConApp] Wibble
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Mon Apr 1 14:41:54 UTC 2024
Simon Peyton Jones pushed to branch wip/mco-in-exprIsConApp at Glasgow Haskell Compiler / GHC
Commits:
70b12b2c by Simon Peyton Jones at 2024-04-01T15:41:40+01:00
Wibble
- - - - -
2 changed files:
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/SimpleOpt.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -3033,20 +3033,20 @@ pushCoDataCon :: DataCon -> [CoreExpr] -> MCoercion
-- where co :: (T t1 .. tn) ~ to_ty
-- The left-hand one must be a T, because exprIsConApp returned True
-- but the right-hand one might not be. (Though it usually will.)
-pushCoDataCon dc dc_args MRefl = Just (push_dc_refl dc dc_args)
+pushCoDataCon dc dc_args MRefl = Just $! (push_dc_refl dc dc_args)
pushCoDataCon dc dc_args (MCo co) = push_dc_gen dc dc_args co (coercionKind co)
push_dc_refl :: DataCon -> [CoreExpr] -> (DataCon, [Type], [CoreExpr])
push_dc_refl dc dc_args
= (dc, map exprToType univ_ty_args, rest_args)
where
- (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args
+ !(univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args
push_dc_gen :: DataCon -> [CoreExpr] -> Coercion -> Pair Type
-> Maybe (DataCon, [Type], [CoreExpr])
push_dc_gen dc dc_args co (Pair from_ty to_ty)
| from_ty `eqType` to_ty -- try cheap test first
- = Just (push_dc_refl dc dc_args)
+ = Just $! (push_dc_refl dc dc_args)
| Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty
, to_tc == dataConTyCon dc
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -1251,7 +1251,7 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr
-- See Note [Push coercions in exprIsConApp_maybe]
= go subst floats expr (CC args' (m_co1' `mkTransMCo` m_co2))
- go subst floats (App fun arg) (CC args co)
+ go subst floats (App fun arg) (CC args mco)
| let arg_type = exprType arg
, not (isTypeArg arg) && needsCaseBinding arg_type arg
-- An unlifted argument that’s not ok for speculation must not simply be
@@ -1274,17 +1274,17 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr
bndr = uniqAway (subst_in_scope subst) (mkWildValBinder ManyTy arg_type)
float = FloatCase arg' bndr DEFAULT []
subst' = subst_extend_in_scope subst bndr
- in go subst' (float:floats) fun (CC (Var bndr : args) co)
+ in go subst' (float:floats) fun (CC (Var bndr : args) mco)
| otherwise
- = go subst floats fun (CC (subst_expr subst arg : args) co)
+ = go subst floats fun (CC (subst_expr subst arg : args) mco)
- go subst floats (Lam bndr body) (CC (arg:args) co)
+ go subst floats (Lam bndr body) (CC (arg:args) mco)
| do_beta_by_substitution bndr arg
- = go (extend subst bndr arg) floats body (CC args co)
+ = go (extend subst bndr arg) floats body (CC args mco)
| otherwise
= let (subst', bndr') = subst_bndr subst bndr
float = FloatLet (NonRec bndr' arg)
- in go subst' (float:floats) body (CC args co)
+ in go subst' (float:floats) body (CC args mco)
go subst floats (Let (NonRec bndr rhs) expr) cont
| not (isJoinId bndr)
@@ -1309,12 +1309,12 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr
(lookupIdSubst sub v)
cont
- go (Left in_scope) floats (Var fun) cont@(CC args co)
+ go (Left in_scope) floats (Var fun) cont@(CC args mco)
| Just con <- isDataConWorkId_maybe fun
, count isValArg args == idArity fun
= succeedWith in_scope floats $
- pushCoDataCon con args co
+ pushCoDataCon con args mco
-- Look through data constructor wrappers: they inline late (See Note
-- [Activation for data constructor wrappers]) but we want to do
@@ -1334,7 +1334,7 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr
-- simplOptExpr initialises the in-scope set with exprFreeVars,
-- but that doesn't account for DFun unfoldings
= succeedWith in_scope floats $
- pushCoDataCon con (map (substExpr subst) dfun_args) co
+ pushCoDataCon con (map (substExpr subst) dfun_args) mco
-- Look through unfoldings, but only arity-zero one;
-- if arity > 0 we are effectively inlining a function call,
@@ -1352,7 +1352,7 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr
, [arg] <- args
, Just (LitString str) <- exprIsLiteral_maybe ise arg
= succeedWith in_scope floats $
- dealWithStringLiteral fun str co
+ dealWithStringLiteral fun str mco
where
unfolding = id_unf fun
extend_in_scope unf_fvs
@@ -1408,9 +1408,9 @@ dealWithStringLiteral :: Var -> BS.ByteString -> MCoercion
-- This is not possible with user-supplied empty literals, GHC.Core.Make.mkStringExprFS
-- turns those into [] automatically, but just in case something else in GHC
-- generates a string literal directly.
-dealWithStringLiteral fun str co =
+dealWithStringLiteral fun str mco =
case utf8UnconsByteString str of
- Nothing -> pushCoDataCon nilDataCon [Type charTy] co
+ Nothing -> pushCoDataCon nilDataCon [Type charTy] mco
Just (char, charTail) ->
let char_expr = mkConApp charDataCon [mkCharLit char]
-- In singleton strings, just add [] instead of unpackCstring# ""#.
@@ -1419,7 +1419,7 @@ dealWithStringLiteral fun str co =
else App (Var fun)
(Lit (LitString charTail))
- in pushCoDataCon consDataCon [Type charTy, char_expr, rest] co
+ in pushCoDataCon consDataCon [Type charTy, char_expr, rest] mco
{-
Note [Unfolding DFuns]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/70b12b2c7b2ec36c87ed4e19afcbaae687d703fa
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/70b12b2c7b2ec36c87ed4e19afcbaae687d703fa
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240401/0f0f70df/attachment-0001.html>
More information about the ghc-commits
mailing list