[Git][ghc/ghc][wip/stg-arg-rep] Refactor: introduce stgArgRep
Krzysztof Gogolewski (@monoidal)
gitlab at gitlab.haskell.org
Tue Sep 26 22:12:49 UTC 2023
Krzysztof Gogolewski pushed to branch wip/stg-arg-rep at Glasgow Haskell Compiler / GHC
Commits:
a525fa6e by Krzysztof Gogolewski at 2023-09-27T00:12:24+02:00
Refactor: introduce stgArgRep
The function 'stgArgType' returns the type in STG. But this violates
the abstraction: in STG we're supposed to operate on PrimReps.
This introduces
stgArgRep ty = typePrimRep (stgArgType ty)
stgArgRep1 ty = typePrimRep1 (stgArgType ty)
stgArgRep_maybe ty = typePrimRep_maybe (stgArgType ty)
stgArgType is still directly used for unboxed tuples (should be fixable), FFI
and in ticky.
- - - - -
11 changed files:
- compiler/GHC/CoreToStg.hs
- compiler/GHC/Stg/Lint.hs
- compiler/GHC/Stg/Syntax.hs
- compiler/GHC/Stg/Unarise.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToCmm/Closure.hs
- compiler/GHC/StgToCmm/Expr.hs
- compiler/GHC/StgToCmm/Layout.hs
- compiler/GHC/StgToCmm/Ticky.hs
- compiler/GHC/StgToJS/Arg.hs
- compiler/GHC/Types/RepType.hs
Changes:
=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -602,7 +602,7 @@ coreToStgArgs (arg : args) = do -- Non-type argument
ticks' = map (coreToStgTick arg_ty) (stripTicksT (not . tickishIsCode) arg)
arg' = getStgArgFromTrivialArg arg
arg_rep = typePrimRep arg_ty
- stg_arg_rep = typePrimRep (stgArgType arg')
+ stg_arg_rep = stgArgRep arg'
bad_args = not (primRepsCompatible platform arg_rep stg_arg_rep)
massertPpr (length ticks' <= 1) (text "More than one Tick in trivial arg:" <+> ppr arg)
=====================================
compiler/GHC/Stg/Lint.hs
=====================================
@@ -178,7 +178,7 @@ lintStgTopBindings platform logger diag_opts opts extra_vars this_mod unarised w
lintStgConArg :: StgArg -> LintM ()
lintStgConArg arg = do
unarised <- lf_unarised <$> getLintFlags
- when unarised $ case typePrimRep_maybe (stgArgType arg) of
+ when unarised $ case stgArgRep_maybe arg of
-- Note [Post-unarisation invariants], invariant 4
Just [_] -> pure ()
badRep -> addErrL $
@@ -192,7 +192,7 @@ lintStgConArg arg = do
lintStgFunArg :: StgArg -> LintM ()
lintStgFunArg arg = do
unarised <- lf_unarised <$> getLintFlags
- when unarised $ case typePrimRep_maybe (stgArgType arg) of
+ when unarised $ case stgArgRep_maybe arg of
-- Note [Post-unarisation invariants], invariant 3
Just [] -> pure ()
Just [_] -> pure ()
@@ -371,7 +371,7 @@ lintStgAppReps fun args = do
-- and we abort kind checking.
fun_arg_tys_reps, actual_arg_reps :: [Maybe [PrimRep]]
fun_arg_tys_reps = map typePrimRep_maybe fun_arg_tys'
- actual_arg_reps = map (typePrimRep_maybe . stgArgType) args
+ actual_arg_reps = map stgArgRep_maybe args
match_args :: [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()
match_args (Nothing:_) _ = return ()
=====================================
compiler/GHC/Stg/Syntax.hs
=====================================
@@ -56,6 +56,10 @@ module GHC.Stg.Syntax (
stgRhsArity, freeVarsOfRhs,
isDllConApp,
stgArgType,
+ stgArgRep,
+ stgArgRep1,
+ stgArgRep_maybe,
+
stgCaseBndrInScope,
-- ppr
@@ -86,7 +90,7 @@ import GHC.Types.Name ( isDynLinkName )
import GHC.Types.Tickish ( StgTickish )
import GHC.Types.Var.Set
import GHC.Types.Literal ( Literal, literalType )
-import GHC.Types.RepType ( typePrimRep1, typePrimRep )
+import GHC.Types.RepType ( typePrimRep1, typePrimRep, typePrimRep_maybe )
import GHC.Unit.Module ( Module )
import GHC.Utils.Outputable
@@ -181,15 +185,30 @@ isAddrRep _ = False
-- | Type of an @StgArg@
--
-- Very half baked because we have lost the type arguments.
+--
+-- This function should be avoided: in STG we aren't supposed to
+-- look at types, but only PrimReps.
+-- Use 'stgArgRep', 'stgArgRep_maybe', 'stgArgRep1' instaed.
stgArgType :: StgArg -> Type
stgArgType (StgVarArg v) = idType v
stgArgType (StgLitArg lit) = literalType lit
+stgArgRep :: StgArg -> [PrimRep]
+stgArgRep ty = typePrimRep (stgArgType ty)
+
+stgArgRep_maybe :: StgArg -> Maybe [PrimRep]
+stgArgRep_maybe ty = typePrimRep_maybe (stgArgType ty)
+
+-- | Assumes that the argument has one PrimRep, which holds after unarisation.
+-- See Note [Post-unarisation invariants] in GHC.Stg.Unarise.
+stgArgRep1 :: StgArg -> PrimRep
+stgArgRep1 ty = typePrimRep1 (stgArgType ty)
+
-- | Given an alt type and whether the program is unarised, return whether the
-- case binder is in scope.
--
-- Case binders of unboxed tuple or unboxed sum type always dead after the
--- unariser has run. See Note [Post-unarisation invariants].
+-- unariser has run. See Note [Post-unarisation invariants] in GHC.Stg.Unarise.
stgCaseBndrInScope :: AltType -> Bool {- ^ unarised? -} -> Bool
stgCaseBndrInScope alt_ty unarised =
case alt_ty of
=====================================
compiler/GHC/Stg/Unarise.hs
=====================================
@@ -446,10 +446,10 @@ instance Outputable UnariseVal where
-- See Note [UnariseEnv]
extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho env x (MultiVal args)
- = assert (all (isNvUnaryType . stgArgType) args)
+ = assert (all (isNvUnaryRep . stgArgRep) args)
env { ue_rho = extendVarEnv (ue_rho env) x (MultiVal args) }
extendRho env x (UnaryVal val)
- = assert (isNvUnaryType (stgArgType val))
+ = assert (isNvUnaryRep (stgArgRep val))
env { ue_rho = extendVarEnv (ue_rho env) x (UnaryVal val) }
-- Properly shadow things from an outer scope.
-- See Note [UnariseEnv]
@@ -745,7 +745,7 @@ mapTupleIdBinders
-> UnariseEnv
-> UnariseEnv
mapTupleIdBinders ids args0 rho0
- = assert (not (any (isZeroBitTy . stgArgType) args0)) $
+ = assert (not (any (null . stgArgRep) args0)) $
let
ids_unarised :: [(Id, [PrimRep])]
ids_unarised = map (\id -> (id, typePrimRep (idType id))) ids
@@ -779,13 +779,13 @@ mapSumIdBinders
-> UniqSM (UnariseEnv, OutStgExpr)
mapSumIdBinders alt_bndr args rhs rho0
- = assert (not (any (isZeroBitTy . stgArgType) args)) $ do
+ = assert (not (any (null . stgArgRep) args)) $ do
uss <- listSplitUniqSupply <$> getUniqueSupplyM
let
fld_reps = typePrimRep (idType alt_bndr)
-- Slots representing the whole sum
- arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args
+ arg_slots = map primRepSlot $ concatMap stgArgRep args
-- The slots representing the field of the sum we bind.
id_slots = map primRepSlot $ fld_reps
layout1 = layoutUbxSum arg_slots id_slots
@@ -879,7 +879,7 @@ mkUbxSum dc ty_args args0 us
= let
_ :| sum_slots = ubxSumRepType (map typePrimRep ty_args)
-- drop tag slot
- field_slots = (mapMaybe (typeSlotTy . stgArgType) args0)
+ field_slots = (mapMaybe (repSlotTy . stgArgRep) args0)
tag = dataConTag dc
layout' = layoutUbxSum sum_slots field_slots
@@ -912,9 +912,9 @@ mkUbxSum dc ty_args args0 us
castArg :: UniqSupply -> SlotTy -> StgArg -> Maybe (StgArg,UniqSupply,StgExpr -> StgExpr)
castArg us slot_ty arg
-- Cast the argument to the type of the slot if required
- | slotPrimRep slot_ty /= typePrimRep1 (stgArgType arg)
+ | slotPrimRep slot_ty /= stgArgRep1 arg
, out_ty <- primRepToType $ slotPrimRep slot_ty
- , (ops,types) <- unzip $ getCasts (typePrimRep1 $ stgArgType arg) $ typePrimRep1 out_ty
+ , (ops,types) <- unzip $ getCasts (stgArgRep1 arg) $ typePrimRep1 out_ty
, not . null $ ops
= let (us1,us2) = splitUniqSupply us
cast_uqs = uniqsFromSupply us1
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -57,7 +57,7 @@ import GHC.Builtin.Uniques
import GHC.Data.FastString
import GHC.Utils.Panic
import GHC.Utils.Exception (evaluate)
-import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds, argPrimRep )
+import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds )
import GHC.StgToCmm.Layout
import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)
import GHC.Data.Bitmap
@@ -1385,16 +1385,16 @@ generatePrimCall d s p target _mb_unit _result_ty args
non_void _ = True
nv_args :: [StgArg]
- nv_args = filter (non_void . argPrimRep) args
+ nv_args = filter (non_void . stgArgRep1) args
(args_info, args_offsets) =
layoutNativeCall profile
NativePrimCall
0
- (primRepCmmType platform . argPrimRep)
+ (primRepCmmType platform . stgArgRep1)
nv_args
- prim_args_offsets = mapFst argPrimRep args_offsets
+ prim_args_offsets = mapFst stgArgRep1 args_offsets
shifted_args_offsets = mapSnd (+ d) args_offsets
push_target = PUSH_UBX (LitLabel target Nothing IsFunction) 1
=====================================
compiler/GHC/StgToCmm/Closure.hs
=====================================
@@ -19,7 +19,6 @@ module GHC.StgToCmm.Closure (
DynTag, tagForCon, isSmallFamily,
idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps,
- argPrimRep,
NonVoid(..), fromNonVoid, nonVoidIds, nonVoidStgArgs,
assertNonVoidIds, assertNonVoidStgArgs,
@@ -161,13 +160,13 @@ assertNonVoidIds ids = assert (not (any (isZeroBitTy . idType) ids)) $
coerce ids
nonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]
-nonVoidStgArgs args = [NonVoid arg | arg <- args, not (isZeroBitTy (stgArgType arg))]
+nonVoidStgArgs args = [NonVoid arg | arg <- args, not (null (stgArgRep arg))]
-- | Used in places where some invariant ensures that all these arguments are
-- non-void; e.g. constructor arguments.
-- See Note [Post-unarisation invariants] in "GHC.Stg.Unarise".
assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]
-assertNonVoidStgArgs args = assert (not (any (isZeroBitTy . stgArgType) args)) $
+assertNonVoidStgArgs args = assert (not (any (null . stgArgRep) args)) $
coerce args
@@ -179,27 +178,22 @@ assertNonVoidStgArgs args = assert (not (any (isZeroBitTy . stgArgType) args)) $
-- | Assumes that there is precisely one 'PrimRep' of the type. This assumption
-- holds after unarise.
--- See Note [Post-unarisation invariants]
+-- See Note [Post-unarisation invariants] in GHC.Stg.Unarise.
idPrimRep :: Id -> PrimRep
idPrimRep id = typePrimRep1 (idType id)
-- See also Note [VoidRep] in GHC.Types.RepType
-- | Assumes that Ids have one PrimRep, which holds after unarisation.
--- See Note [Post-unarisation invariants]
+-- See Note [Post-unarisation invariants] in GHC.Stg.Unarise.
addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)]
addIdReps = map (\id -> let id' = fromNonVoid id
in NonVoid (idPrimRep id', id'))
-- | Assumes that arguments have one PrimRep, which holds after unarisation.
--- See Note [Post-unarisation invariants]
+-- See Note [Post-unarisation invariants] in GHC.Stg.Unarise.
addArgReps :: [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]
addArgReps = map (\arg -> let arg' = fromNonVoid arg
- in NonVoid (argPrimRep arg', arg'))
-
--- | Assumes that the argument has one PrimRep, which holds after unarisation.
--- See Note [Post-unarisation invariants]
-argPrimRep :: StgArg -> PrimRep
-argPrimRep arg = typePrimRep1 (stgArgType arg)
+ in NonVoid (stgArgRep1 arg', arg'))
------------------------------------------------------
-- Building LambdaFormInfo
=====================================
compiler/GHC/StgToCmm/Expr.hs
=====================================
@@ -1001,7 +1001,7 @@ cgIdApp fun_id args = do
fun = idInfoToAmode fun_info
lf_info = cg_lf fun_info
n_args = length args
- v_args = length $ filter (isZeroBitTy . stgArgType) args
+ v_args = length $ filter (null . stgArgRep) args
case getCallMethod cfg fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop of
-- A value in WHNF, so we can just return it.
ReturnIt
=====================================
compiler/GHC/StgToCmm/Layout.hs
=====================================
@@ -331,7 +331,7 @@ getArgRepsAmodes args = do
| V <- rep = return (V, Nothing)
| otherwise = do expr <- getArgAmode (NonVoid arg)
return (rep, Just expr)
- where rep = toArgRep platform (argPrimRep arg)
+ where rep = toArgRep platform (stgArgRep1 arg)
nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
nonVArgs [] = []
@@ -605,7 +605,7 @@ getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
-- so the result list may be shorter than the argument list
getNonVoidArgAmodes [] = return []
getNonVoidArgAmodes (arg:args)
- | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args
+ | isVoidRep (stgArgRep1 arg) = getNonVoidArgAmodes args
| otherwise = do { amode <- getArgAmode (NonVoid arg)
; amodes <- getNonVoidArgAmodes args
; return ( amode : amodes ) }
=====================================
compiler/GHC/StgToCmm/Ticky.hs
=====================================
@@ -587,7 +587,7 @@ tickyDirectCall :: RepArity -> [StgArg] -> FCode ()
tickyDirectCall arity args
| args `lengthIs` arity = tickyKnownCallExact
| otherwise = do tickyKnownCallExtraArgs
- tickySlowCallPat (map argPrimRep (drop arity args))
+ tickySlowCallPat (map stgArgRep1 (drop arity args))
tickyKnownCallTooFewArgs :: FCode ()
tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")
@@ -610,7 +610,7 @@ tickySlowCall lf_info args = do
if isKnownFun lf_info
then tickyKnownCallTooFewArgs
else tickyUnknownCall
- tickySlowCallPat (map argPrimRep args)
+ tickySlowCallPat (map stgArgRep1 args)
tickySlowCallPat :: [PrimRep] -> FCode ()
tickySlowCallPat args = ifTicky $ do
=====================================
compiler/GHC/StgToJS/Arg.hs
=====================================
@@ -118,7 +118,7 @@ genStaticArg a = case a of
Nothing -> reg
Just expr -> unfloated expr
where
- r = unaryTypeJSRep . stgArgType $ a
+ r = primRepToJSRep $ stgArgRep1 a
reg
| isVoid r =
return []
@@ -160,7 +160,7 @@ genArg a = case a of
where
-- if our argument is a joinid, it can be an unboxed tuple
r :: HasDebugCallStack => JSRep
- r = unaryTypeJSRep . stgArgType $ a
+ r = primRepToJSRep $ stgArgRep1 a
unfloated :: HasDebugCallStack => CgStgExpr -> G [JExpr]
unfloated = \case
=====================================
compiler/GHC/Types/RepType.hs
=====================================
@@ -4,7 +4,7 @@
module GHC.Types.RepType
(
-- * Code generator views onto Types
- UnaryType, NvUnaryType, isNvUnaryType,
+ UnaryType, NvUnaryType, isNvUnaryRep,
unwrapType,
-- * Predicates on types
@@ -19,7 +19,7 @@ module GHC.Types.RepType
runtimeRepPrimRep_maybe, kindPrimRep_maybe, typePrimRep_maybe,
-- * Unboxed sum representation type
- ubxSumRepType, layoutUbxSum, typeSlotTy, SlotTy (..),
+ ubxSumRepType, layoutUbxSum, repSlotTy, SlotTy (..),
slotPrimRep, primRepSlot,
-- * Is this type known to be data?
@@ -76,12 +76,9 @@ type UnaryType = Type
-- UnaryType : never an unboxed tuple or sum;
-- can be Void# or (# #)
-isNvUnaryType :: Type -> Bool
-isNvUnaryType ty
- | [_] <- typePrimRep ty
- = True
- | otherwise
- = False
+isNvUnaryRep :: [PrimRep] -> Bool
+isNvUnaryRep [_] = True
+isNvUnaryRep _ = False
-- INVARIANT: the result list is never empty.
typePrimRepArgs :: HasDebugCallStack => Type -> NonEmpty PrimRep
@@ -307,11 +304,11 @@ instance Outputable SlotTy where
ppr FloatSlot = text "FloatSlot"
ppr (VecSlot n e) = text "VecSlot" <+> ppr n <+> ppr e
-typeSlotTy :: UnaryType -> Maybe SlotTy
-typeSlotTy ty = case typePrimRep ty of
+repSlotTy :: [PrimRep] -> Maybe SlotTy
+repSlotTy reps = case reps of
[] -> Nothing
[rep] -> Just (primRepSlot rep)
- reps -> pprPanic "typeSlotTy" (ppr ty $$ ppr reps)
+ _ -> pprPanic "repSlotTy" (ppr reps)
primRepSlot :: PrimRep -> SlotTy
primRepSlot VoidRep = pprPanic "primRepSlot" (text "No slot for VoidRep")
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a525fa6ead441fd645a2864b39b638c3fbe823ff
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a525fa6ead441fd645a2864b39b638c3fbe823ff
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/20230926/83f7f5a3/attachment-0001.html>
More information about the ghc-commits
mailing list