Jaro Reinders pushed to branch wip/reduce-type-in-stg at Glasgow Haskell Compiler / GHC Commits: 5d9f2aee by Jaro Reinders at 2026-04-22T11:53:14+02:00 Do almost all the todos - - - - - 5 changed files: - compiler/GHC/Core/Type.hs - compiler/GHC/Stg/Unarise.hs - compiler/GHC/StgToCmm/Utils.hs - compiler/GHC/StgToJS/Expr.hs - compiler/GHC/Types/RepType.hs Changes: ===================================== compiler/GHC/Core/Type.hs ===================================== @@ -70,7 +70,7 @@ module GHC.Core.Type ( isLitTy, getRuntimeRep, splitRuntimeRep_maybe, kindRep_maybe, kindRep, - getLevity, levityType_maybe, + getLevity, levityType_maybe, isUnboxedTupleKind, mkCastTy, mkCoercionTy, splitCastTy_maybe, @@ -2802,6 +2802,12 @@ isFixedRuntimeRepKind k -- the isLiftedTypeKind check is necessary b/c of Constraint isConcreteType k +isUnboxedTupleKind :: HasDebugCallStack => Kind -> Bool +isUnboxedTupleKind kind + = tyConAppTyCon (kindRep kind) `hasKey` tupleRepDataConKey + -- NB: Do not use typePrimRep, as that can't tell the difference between + -- unboxed tuples and unboxed sums + -- | Tests whether the given type is concrete, i.e. it -- whether it consists only of concrete type constructors, -- concrete type variables, and applications. ===================================== compiler/GHC/Stg/Unarise.hs ===================================== @@ -882,7 +882,6 @@ mapSumIdBinders alt_bndr args rhs rho0 -- Convert the argument to the given type, and wrap the conversion -- around the given expression. Use the given Id as a name for the -- converted value. --- TODO: the 'Type' in the argument here should probably be 'StgKind' castArgRename :: [(PrimOp,Type,Unique)] -> StgArg -> StgExpr -> StgExpr castArgRename ops in_arg rhs = case ops of @@ -896,17 +895,11 @@ castArgRename ops in_arg rhs = mkCastVar :: Unique -> Type -> Id mkCastVar uq ty = mkSysLocal (fsLit "cst_sum") uq ManyTy ty --- TODO: move/rename this -stgKindPrimRep1 :: HasDebugCallStack => StgKind -> PrimRep -stgKindPrimRep1 (MkStgKind k) = case kindPrimRep_maybe k of - Just [rep] -> rep - r -> pprPanic "kindPrimRepU" (ppr k $$ ppr r) - mkCast :: StgArg -> PrimOp -> OutId -> StgKind -> StgExpr -> StgExpr mkCast arg_in cast_op out_id out_kind in_rhs = let scrut = StgOpApp (StgPrimOp cast_op) [arg_in] alt = GenStgAlt { alt_con = DEFAULT, alt_bndrs = [], alt_rhs = in_rhs} - alt_ty = PrimAlt (stgKindPrimRep1 out_kind) + alt_ty = PrimAlt (kindPrimRep1 (getStgKind out_kind)) in (StgCase scrut out_id alt_ty [alt]) -- | Build a unboxed sum term from arguments of an alternative. ===================================== compiler/GHC/StgToCmm/Utils.hs ===================================== @@ -92,7 +92,6 @@ import Control.Monad import qualified Data.Map.Strict as Map import qualified Data.IntMap.Strict as I import qualified Data.Semigroup (Semigroup(..)) -import GHC.Builtin.Names (tupleRepDataConKey) -------------------------------------------------------------------------- -- @@ -321,24 +320,22 @@ assignTemp e = do { platform <- getPlatform ; emitAssign (CmmLocal reg) e ; return reg } -newUnboxedTupleRegs :: Kind -> FCode ([LocalReg], [ForeignHint]) +newUnboxedTupleRegs :: HasDebugCallStack => Kind -> FCode ([LocalReg], [ForeignHint]) -- Choose suitable local regs to use for the components -- of an unboxed tuple that we are about to return to -- the Sequel. If the Sequel is a join point, using the -- regs it wants will save later assignments. newUnboxedTupleRegs res_kind - -- TODO: clean up this messy assert. It is basically isUnboxedTupleType, but then for kinds. - = assert (Just True == ((\x -> tyConAppTyCon x `hasKey` tupleRepDataConKey) <$> kindRep_maybe res_kind)) $ - do { platform <- getPlatform - ; sequel <- getSequel - ; regs <- choose_regs platform sequel - ; massert (regs `equalLength` reps) - ; return (regs, map primRepForeignHint reps) } - where - -- TODO: this is partial - Just reps = kindPrimRep_maybe res_kind - choose_regs _ (AssignTo regs _) = return regs - choose_regs platform _ = mapM (newTemp . primRepCmmType platform) reps + = assert (isUnboxedTupleKind res_kind) $ + case kindPrimRep_maybe res_kind of + Just reps -> + do { platform <- getPlatform + ; sequel <- getSequel + ; regs <- case sequel of + AssignTo regs _ -> regs <$ massert (regs `equalLength` reps) + _ -> mapM (newTemp . primRepCmmType platform) reps + ; return (regs, map primRepForeignHint reps) } + Nothing -> pprPanic "newUnboxedTupleRegs applied to non-unboxed-tuple kind" (ppr res_kind) ------------------------------------------------------------------------- -- emitMultiAssign ===================================== compiler/GHC/StgToJS/Expr.hs ===================================== @@ -372,7 +372,7 @@ resultSize kind = result where result = result_reps `zip` result_slots result_slots = fmap (slotCount . primRepSize) result_reps - result_reps = stgKindPrimRep kind + result_reps = kindPrimRep (getStgKind kind) -- | Ensure that the set of identifiers has valid 'RuntimeRep's. This function -- returns a no-op when 'csRuntimeAssert' in 'StgToJSConfig' is False. ===================================== compiler/GHC/Types/RepType.hs ===================================== @@ -14,6 +14,7 @@ module GHC.Types.RepType countFunRepArgs, countConRepArgs, dataConRuntimeRepStrictness, tyConPrimRep, runtimeRepPrimRep_maybe, kindPrimRep_maybe, typePrimRep_maybe, + kindPrimRep, kindPrimRep1, -- * Unboxed sum representation type ubxSumRepType, layoutUbxSum, repSlotTy, SlotTy (..), @@ -566,9 +567,12 @@ to process the LiftedRep and WordRep, concatenating the results. -- no runtime representation (void) or multiple (unboxed tuple/sum) -- See also Note [Getting from RuntimeRep to PrimRep] typePrimRep :: HasDebugCallStack => Type -> [PrimRep] -typePrimRep ty = kindPrimRep (text "typePrimRep" <+> - parens (ppr ty <+> dcolon <+> ppr (typeKind ty))) - (typeKind ty) +typePrimRep ty = + let ki = typeKind ty in + case kindPrimRep_maybe ki of + Just reps -> reps + Nothing -> + pprPanic "typePrimRep" (ppr ty <+> dcolon <+> ppr ki) -- | Discovers the primitive representation of a 'Type'. Returns -- a list of 'PrimRep': it's a list because of the possibility of @@ -599,20 +603,29 @@ typePrimRepU ty = case typePrimRep ty of -- See also Note [Getting from RuntimeRep to PrimRep] tyConPrimRep :: HasDebugCallStack => TyCon -> [PrimRep] tyConPrimRep tc - = kindPrimRep (text "kindRep tc" <+> ppr tc $$ ppr res_kind) - res_kind + = case kindPrimRep_maybe res_kind of + Just reps -> reps + Nothing -> pprPanic "kindRep tc" (ppr tc $$ ppr res_kind) where res_kind = tyConResKind tc -- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's -- of values of types of this kind. -- See also Note [Getting from RuntimeRep to PrimRep] -kindPrimRep :: HasDebugCallStack => SDoc -> Kind -> [PrimRep] -kindPrimRep doc ki - | Just runtime_rep <- kindRep_maybe ki - = runtimeRepPrimRep doc runtime_rep -kindPrimRep doc ki - = pprPanic "kindPrimRep" (ppr ki $$ doc) +kindPrimRep :: HasDebugCallStack => Kind -> [PrimRep] +kindPrimRep ki + = case kindPrimRep_maybe ki of + Just reps -> reps + Nothing -> pprPanic "kindPrimRep" (ppr ki) + +-- | Like 'kindPrimRep', but assumes that there is exactly one 'PrimRep' output. +-- This assumption holds after unarise, see Note [Post-unarisation invariants]. +-- Before unarise it may or may not hold. +-- See also Note [RuntimeRep and PrimRep] and Note [VoidRep] +kindPrimRep1 :: HasDebugCallStack => Kind -> PrimRep +kindPrimRep1 k = case kindPrimRep_maybe k of + Just [rep] -> rep + r -> pprPanic "kindPrimRep1" (ppr k $$ ppr r) -- NB: We could implement the partial methods by calling into the maybe -- variants here. But then both would need to pass around the doc argument. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5d9f2aee8ca0768e7a73f476d85574b1... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5d9f2aee8ca0768e7a73f476d85574b1... You're receiving this email because of your account on gitlab.haskell.org.