[Git][ghc/ghc][wip/T23109] 2 commits: Get rid of newtype classes in CorePrep not CoreToStg
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Thu Apr 11 14:44:26 UTC 2024
Simon Peyton Jones pushed to branch wip/T23109 at Glasgow Haskell Compiler / GHC
Commits:
7526aaac by Simon Peyton Jones at 2024-04-11T15:43:31+01:00
Get rid of newtype classes in CorePrep not CoreToStg
- - - - -
00d4ce0a by Simon Peyton Jones at 2024-04-11T15:43:53+01:00
SetLevels
Experimental: don't float constants, except to top level
- - - - -
4 changed files:
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/CoreToStg.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Types/Id/Make.hs
Changes:
=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -703,7 +703,7 @@ lvlMFE env strict_ctxt ann_expr
-- We can save work if we can move a redex outside a value lambda
-- But if float_is_new_lam is True, then the redex is wrapped in a
-- a new lambda, so no work is saved
- saves_work = escapes_value_lam && not float_is_new_lam
+ saves_work = escapes_value_lam && not (exprIsHNF expr) && not float_is_new_lam
escapes_value_lam = dest_lvl `ltMajLvl` (le_ctxt_lvl env)
-- See Note [Escaping a value lambda]
=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -531,13 +531,7 @@ coreToStgApp f args ticks = do
app = case idDetails f of
DataConWorkId dc
| saturated
- , let tc = dataConTyCon dc
- -> if isClassTyCon tc && isNewTyCon tc then
- case args' of
- [StgVarArg id] -> StgApp id []
- [StgLitArg lit] -> StgLit lit
- _ -> pprPanic "coreToStgApp" (ppr dc <+> ppr args')
- else if isUnboxedSumDataCon dc then
+ -> if isUnboxedSumDataCon dc then
StgConApp dc NoNumber args' (sumPrimReps args)
else
StgConApp dc NoNumber args' []
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -59,7 +59,7 @@ import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Id
import GHC.Types.Id.Info
-import GHC.Types.Id.Make ( realWorldPrimId )
+import GHC.Types.Id.Make ( realWorldPrimId, wrapNewTypeBody )
import GHC.Types.Basic
import GHC.Types.Name ( NamedThing(..), nameSrcSpan, isInternalName )
import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
@@ -1084,6 +1084,10 @@ cpeApp top_env expr
| not (isTyCoArg arg) = True
has_value_arg (_:rest) = has_value_arg rest
+ cpe_app env (Var v) args
+ | Just (payload, args') <- isNewTypeClassApp v args
+ = cpe_app env payload args'
+
cpe_app env (Var v) args
= do { v1 <- fiddleCCall v
; let e2 = lookupCorePrepEnv env v1
@@ -1172,8 +1176,8 @@ cpeApp top_env expr
rebuild_app'
:: CorePrepEnv
- -> [ArgInfo] -- The arguments (inner to outer)
- -> CpeApp
+ -> [ArgInfo] -- The arguments (inner to outer); substitution not applied
+ -> CpeApp -- Substitution already applied
-> Floats
-> [Demand]
-> [CoreTickish]
@@ -1185,12 +1189,9 @@ cpeApp top_env expr
rebuild_app' env (a : as) fun' floats ss rt_ticks req_depth = case a of
-- See Note [Ticks and mandatory eta expansion]
- _
- | not (null rt_ticks)
- , req_depth <= 0
- ->
- let tick_fun = foldr mkTick fun' rt_ticks
- in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth
+ _ | not (null rt_ticks), req_depth <= 0
+ -> let tick_fun = foldr mkTick fun' rt_ticks
+ in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth
CpeApp (Type arg_ty)
-> rebuild_app' env as (App fun' (Type arg_ty)) floats ss rt_ticks req_depth
@@ -1204,11 +1205,12 @@ cpeApp top_env expr
(_ : ss_rest, True) -> (topDmd, ss_rest)
(ss1 : ss_rest, False) -> (ss1, ss_rest)
([], _) -> (topDmd, [])
- (fs, arg') <- cpeArg top_env ss1 arg
+ (fs, arg') <- cpeArg env ss1 arg
rebuild_app' env as (App fun' arg') (fs `zipFloats` floats) ss_rest rt_ticks (req_depth-1)
CpeCast co
-> rebuild_app' env as (Cast fun' co) floats ss rt_ticks req_depth
+
-- See Note [Ticks and mandatory eta expansion]
CpeTick tickish
| tickishPlace tickish == PlaceRuntime
@@ -1226,6 +1228,24 @@ isLazyExpr (Tick _ e) = isLazyExpr e
isLazyExpr (Var f `App` _ `App` _) = f `hasKey` lazyIdKey
isLazyExpr _ = False
+isNewTypeClassApp :: Id -> [ArgInfo] -> Maybe (CoreExpr, [ArgInfo])
+isNewTypeClassApp v args
+ | Just data_con <- isDataConWorkId_maybe v
+ , let tycon = dataConTyCon data_con
+ , isNewTyCon tycon
+ , let get_payload 0 rev_arg_tys (CpeApp payload : args')
+ = Just (wrapNewTypeBody tycon (reverse rev_arg_tys) payload, args')
+ get_payload n rev_arg_tys (CpeApp (Type ty) : args)
+ = get_payload (n-1) (ty:rev_arg_tys) args
+ get_payload _ _ _
+ = Nothing
+ = assertPpr (isClassTyCon tycon) (ppr v) $
+ -- Newtype data constructors are already inlined
+ -- /except/ for newtype classes
+ get_payload (tyConArity tycon) [] args
+
+ | otherwise = Nothing
+
{- Note [runRW magic]
~~~~~~~~~~~~~~~~~~~~~
Some definitions, for instance @runST@, must have careful control over float out
=====================================
compiler/GHC/Types/Id/Make.hs
=====================================
@@ -20,7 +20,7 @@ module GHC.Types.Id.Make (
mkFCallId,
- unwrapNewTypeBody, wrapFamInstBody,
+ wrapNewTypeBody, unwrapNewTypeBody, wrapFamInstBody,
DataConBoxer(..), vanillaDataConBoxer,
mkDataConRep, mkDataConWorkId,
DataConBangOpts (..), BangOpts (..),
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6696873e91d463ef522019968169a0e195ab0662...00d4ce0ac8bfc70c8b512995cd2caa71a9eb0542
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6696873e91d463ef522019968169a0e195ab0662...00d4ce0ac8bfc70c8b512995cd2caa71a9eb0542
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/20240411/014d8e9e/attachment-0001.html>
More information about the ghc-commits
mailing list