Jaro Reinders pushed to branch wip/reduce-type-in-stg at Glasgow Haskell Compiler / GHC Commits: d400c2d8 by Jaro Reinders at 2026-06-19T12:47:45+02:00 Clean up interface and expand note - - - - - 10 changed files: - compiler/GHC/CoreToStg.hs - compiler/GHC/Stg/BcPrep.hs - compiler/GHC/Stg/Syntax.hs - compiler/GHC/Stg/Unarise.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm/Foreign.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToCmm/Utils.hs - compiler/GHC/StgToJS/Expr.hs - compiler/GHC/StgToJS/Utils.hs Changes: ===================================== compiler/GHC/CoreToStg.hs ===================================== @@ -447,7 +447,7 @@ coreToStgExpr expr@(Lam {}) fun_ty = mkLamTypes val_bndrs body_ty -- This type is a bit ill-formed but it doesn't matter rhs = StgRhsClosure noExtFieldSilent currentCCS - ReEntrant val_bndrs body' (MkStgKind (typeKind body_ty)) + ReEntrant val_bndrs body' (typeStgKind body_ty) tmp_fun = mkSysLocal (fsLit "pap") uniq ManyTy fun_ty ; return (StgLet noExtFieldSilent (StgNonRec tmp_fun rhs) $ StgApp tmp_fun []) } @@ -607,7 +607,7 @@ mkStgApp f how_bound core_args stg_args res_ty f_arity = stgArity f how_bound n_val_args = length stg_args -- StgArgs are all value arguments exactly_saturated = f_arity == n_val_args - res_kind = MkStgKind (typeKind res_ty) + res_kind = typeStgKind res_ty -- Given Core arguments to an unboxed sum datacon, return the 'PrimRep's @@ -751,7 +751,7 @@ coreToMkStgRhs bndr expr = do let mk_rhs = MkStgRhs { rhs_args = bndrs , rhs_expr = body' - , rhs_kind = MkStgKind (typeKind (exprType body)) + , rhs_kind = typeStgKind (exprType body) , rhs_is_join = isJoinId bndr } pure mk_rhs ===================================== compiler/GHC/Stg/BcPrep.hs ===================================== @@ -50,7 +50,7 @@ bcPrepRHS con@StgRhsCon{} = pure con bcPrepExpr :: StgExpr -> BcPrepM StgExpr -- explicitly match all constructors so we get a warning if we miss any bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _) rhs) - | isLiftedTypeKind tick_kind = do + | isLiftedTypeStgKind tick_kind = do id <- newId tick_ty rhs' <- bcPrepExpr rhs let expr' = StgTick bp rhs' @@ -59,7 +59,7 @@ bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _) rhs) ReEntrant [] expr' - (MkStgKind tick_kind) + tick_kind ) letExp = StgLet noExtFieldSilent bnd (StgApp id []) pure letExp @@ -72,10 +72,10 @@ bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _) rhs) ReEntrant [voidArgId] expr' - (MkStgKind tick_kind) + tick_kind ) pure $ StgLet noExtFieldSilent bnd (StgApp id [StgVarArg realWorldPrimId]) - where tick_kind = typeKind tick_ty + where tick_kind = typeStgKind tick_ty bcPrepExpr (StgTick tick rhs) = StgTick tick <$> bcPrepExpr rhs bcPrepExpr (StgLet xlet bnds expr) = ===================================== compiler/GHC/Stg/Syntax.hs ===================================== @@ -14,7 +14,8 @@ generation. -} module GHC.Stg.Syntax ( - StgKind(..), + StgKind(getStgKind), typeStgKind, stgKindPrimRep, stgKindPrimRep1, + stgKindPrimRepU, isUnboxedTupleStgKind, isLiftedTypeStgKind, StgFArgType(..), collectStgFArgTypes, @@ -80,7 +81,13 @@ import GHC.Types.CostCentre ( CostCentreStack ) import GHC.Core ( AltCon ) import GHC.Core.DataCon import GHC.Core.TyCon ( PrimRep(..), PrimOrVoidRep(..), TyCon ) -import GHC.Core.Type ( Type, tyConAppTyCon ) +import GHC.Core.Type + ( Type, + tyConAppTyCon, + typeKind, + isUnboxedTupleKind, + kindRep_maybe, + isLiftedRuntimeRep ) import GHC.Core.Ppr( {- instances -} ) import GHC.Types.ForeignCall ( ForeignCall ) @@ -88,10 +95,19 @@ import GHC.Types.Id import GHC.Types.Tickish ( StgTickish ) import GHC.Types.Var.Set import GHC.Types.Literal ( Literal, literalType ) -import GHC.Types.RepType ( typePrimRep, typePrimRep1, typePrimRepU, typePrimRep_maybe, unwrapType ) +import GHC.Types.RepType + ( typePrimRep, + typePrimRep1, + typePrimRepU, + typePrimRep_maybe, + kindPrimRep, + kindPrimRep1, + kindPrimRep_maybe, + unwrapType ) import GHC.Utils.Outputable import GHC.Utils.Panic.Plain +import GHC.Utils.Panic ( pprPanic ) import GHC.Builtin.PrimOps ( PrimOp, PrimCall ) @@ -112,27 +128,54 @@ import GHC.Builtin.Types.Prim -- Kind is otherwise equal to. -- See Note [Kinds in STG] newtype StgKind = MkStgKind { getStgKind :: Kind } +-- getStgKind is only used to do some silly pretty printing in the JS backend. + +typeStgKind :: Type -> StgKind +typeStgKind = MkStgKind . typeKind + +stgKindPrimRep1 :: StgKind -> PrimRep +stgKindPrimRep1 = kindPrimRep1 . getStgKind + +stgKindPrimRepU :: StgKind -> PrimOrVoidRep +stgKindPrimRepU (MkStgKind kind) = case kindPrimRep_maybe kind of + Just [] -> VoidRep + Just [r] -> NVRep r + r -> pprPanic "stgKindPrimRepU" (ppr r) + +stgKindPrimRep :: StgKind -> [PrimRep] +stgKindPrimRep = kindPrimRep . getStgKind + +isUnboxedTupleStgKind :: StgKind -> Bool +isUnboxedTupleStgKind = isUnboxedTupleKind . getStgKind + +isLiftedTypeStgKind :: StgKind -> Bool +isLiftedTypeStgKind (MkStgKind kind) + = case kindRep_maybe kind of + Just rep -> isLiftedRuntimeRep rep + Nothing -> False {- Note [Kinds in STG] ~~~~~~~~~~~~~~~~~~~ - -Whereas Core is type-annotated, STG is kind-annotated. +Whereas Core is well-typed, STG is well-kinded. Just as many different values may have a single type, so many different types may have a single kind. So kinds are a "coarser approximation" to the values being manipulated; and that is what we want in STG. -There are two reasons for this: +There are two reasons for wanting a coarser type system: (1) It is easier for third party projects to compile to STG. The type system of another language might not be compatible with GHC's type system. In such a case the kind system is often still compatible because it is so much coarser. - Example projects are Jaro Reinders' agda2stg and Csaba Hruska's external-stg. + Examples of such projects are: + + - agda2stg: https://github.com/noughtmare/agda2stg + - external-stg-interpreter: https://github.com/grin-compiler/ghc-whole-program-compiler-project/tree/mas... (2) It allows for more aggressive optimizations. In STG we may do - type-incorrect things that are kind-correct. For example consider - the following function: + type-incorrect things that are still kind-correct. For example + consider the following function: f :: Either a b -> Either a c f = \x -> case x of r @@ -146,10 +189,12 @@ There are two reasons for this: Left _ -> r <------------- NB Right _ -> error "urk" + See Note [Case 2: CSEing case binders] for the full details of this + optimization. + This is not type-safe in Core, but it is kind-safe in STG. So, using the coarser notion of kinds in STG allows us to do more aggressive - optimizations. Note, however, that we do not implement any such - optimizations yet. + optimizations. Note that the kinds do not always accurately reflect the final runtime representation. For example, on the JS backend the kind 'TYPE Int64Rep' @@ -813,7 +858,6 @@ to move these around together, notably in StgOpApp and COpStmt. Note [tagToEnum# in STG] ~~~~~~~~~~~~~~~~~~~~~~~~ - STG is untyped, but 'tagToEnum#' needs type information, so we make it a special STG operation which stores the type constructor information alongside it. @@ -833,7 +877,6 @@ To preserve this information we desugar the 'tagToEnum#' primop into a special 'StgTagToEnumOp' which has an extra field to store the type constructor information. This desugaring happens when converting Core to STG, which is the last moment that we still have access to the type information. - -} data StgOp ===================================== compiler/GHC/Stg/Unarise.hs ===================================== @@ -889,7 +889,7 @@ castArgRename ops in_arg rhs = ((op,ty,uq):rest_ops) -> let out_id' = mkCastVar uq ty -- out_name `setIdUnique` uq `setIdType` ty sub_cast = castArgRename rest_ops (StgVarArg out_id') - in mkCast in_arg op out_id' (MkStgKind (typeKind ty)) $ sub_cast rhs + in mkCast in_arg op out_id' (typeStgKind ty) $ sub_cast rhs -- Construct a case binder used when casting sums, of a given type and unique. mkCastVar :: Unique -> Type -> Id @@ -899,7 +899,7 @@ 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 (kindPrimRep1 (getStgKind out_kind)) + alt_ty = PrimAlt (stgKindPrimRep1 out_kind) in (StgCase scrut out_id alt_ty [alt]) -- | Build a unboxed sum term from arguments of an alternative. ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -645,12 +645,6 @@ schemeE d s p (StgCase scrut _ _ []) = schemeE d s p scrut schemeE d s p (StgCase scrut bndr _ alts) = doCase d s p scrut bndr alts -stgKindPrimRepU :: StgKind -> PrimOrVoidRep -stgKindPrimRepU (MkStgKind kind) = case kindPrimRep_maybe kind of - Just [] -> VoidRep - Just [r] -> NVRep r - r -> pprPanic "stgKindPrimRepU" (ppr r) - {- Ticked Expressions ------------------ ===================================== compiler/GHC/StgToCmm/Foreign.hs ===================================== @@ -72,7 +72,7 @@ cgForeignCall :: ForeignCall -- the op cgForeignCall (CCall (CCallSpec target cconv safety)) arg_tys stg_args res_kind = do { cmm_args <- getFCallArgs stg_args arg_tys -- ; traceM $ show cmm_args - ; (res_regs, res_hints) <- newUnboxedTupleRegs (getStgKind res_kind) + ; (res_regs, res_hints) <- newUnboxedTupleRegs res_kind ; let ((call_args, arg_hints), cmm_target) = case target of StaticTarget _ _ ForeignValue -> ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -36,7 +36,6 @@ import GHC.Cmm.Graph import GHC.Stg.Syntax import GHC.Cmm import GHC.Unit ( rtsUnit ) -import GHC.Core.Type ( typeKind ) import GHC.Core.TyCon ( isEnumerationTyCon ) import GHC.Cmm.CLabel import GHC.Cmm.Info ( closureInfoPtr ) @@ -105,7 +104,7 @@ cgOpApp (StgTagToEnumOp tyc) args = do cmmPrimOpApp :: StgToCmmConfig -> PrimOp -> [CmmExpr] -> FCode ReturnKind cmmPrimOpApp cfg primop cmm_args = let PrimopCmmEmit _inline f = emitPrimOp cfg primop cmm_args - in f (MkStgKind (typeKind (primOpResultType primop))) + in f (typeStgKind (primOpResultType primop)) externalPrimop :: PrimOp -> [CmmExpr] -> PrimopCmmEmit externalPrimop primop args = outOfLinePrimop (callExternalPrimop primop args) @@ -1919,7 +1918,7 @@ emitPrimOp cfg primop = pure [reg] ReturnsTuple - -> do (regs, _hints) <- newUnboxedTupleRegs (getStgKind res_kind) + -> do (regs, _hints) <- newUnboxedTupleRegs res_kind pure regs f res_kind regs emitReturn (map (CmmReg . CmmLocal) regs) ===================================== compiler/GHC/StgToCmm/Utils.hs ===================================== @@ -50,6 +50,7 @@ module GHC.StgToCmm.Utils ( import GHC.Prelude hiding ( head, init, last, tail ) import GHC.Platform +import GHC.Stg.Syntax import GHC.StgToCmm.Monad import GHC.StgToCmm.Closure import GHC.StgToCmm.Lit (mkSimpleLit, newStringCLit) @@ -65,7 +66,6 @@ import GHC.StgToCmm.CgUtils import GHC.Types.ForeignCall import GHC.Types.Id.Info -import GHC.Core.Type import GHC.Core.TyCon import GHC.Runtime.Heap.Layout import GHC.Unit @@ -76,7 +76,6 @@ import GHC.Types.Unique import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Types.RepType import GHC.Types.CostCentre import GHC.Types.IPE @@ -320,22 +319,20 @@ assignTemp e = do { platform <- getPlatform ; emitAssign (CmmLocal reg) e ; return reg } -newUnboxedTupleRegs :: HasDebugCallStack => Kind -> FCode ([LocalReg], [ForeignHint]) +newUnboxedTupleRegs :: HasDebugCallStack => StgKind -> 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 - = 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) + = assert (isUnboxedTupleStgKind res_kind) $ + let reps = stgKindPrimRep res_kind + in 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) } ------------------------------------------------------------------------- -- emitMultiAssign ===================================== compiler/GHC/StgToJS/Expr.hs ===================================== @@ -366,7 +366,7 @@ resultSize kind = result where result = result_reps `zip` result_slots result_slots = fmap (slotCount . primRepSize) result_reps - result_reps = kindPrimRep (getStgKind kind) + result_reps = stgKindPrimRep 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/StgToJS/Utils.hs ===================================== @@ -205,9 +205,7 @@ typeJSRep :: HasDebugCallStack => Type -> [JSRep] typeJSRep t = map primRepToJSRep (typePrimRep t) stgKindJSRep :: HasDebugCallStack => StgKind -> [JSRep] -stgKindJSRep (MkStgKind k) = case kindPrimRep_maybe k of - Just rs -> map primRepToJSRep rs - Nothing -> pprPanic "kindJSRep" (ppr k) +stgKindJSRep = map primRepToJSRep . stgKindPrimRep -- only use if you know it's not an unboxed tuple unaryTypeJSRep :: HasDebugCallStack => UnaryType -> JSRep View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d400c2d86603e9bece2d97e24286e233... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d400c2d86603e9bece2d97e24286e233... You're receiving this email because of your account on gitlab.haskell.org.
participants (1)
-
Jaro Reinders (@jaro)