[Git][ghc/ghc][wip/reduce-type-in-stg] Clean up interface and expand note

19 Jun 2026


      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.

    

Jaro Reinders (＠jaro)

tags

participants (1)