Jaro Reinders pushed to branch wip/reduce-type-in-stg at Glasgow Haskell Compiler / GHC Commits: f7411bb6 by Jaro Reinders at 2026-02-27T12:01:45+00:00 Fix issues and remove Type from StgFCallOp - - - - - e8ccf617 by Jaro Reinders at 2026-02-27T12:57:32+00:00 Remove Type from StgRhsClosure - - - - - 14f8cd8d by Jaro Reinders at 2026-02-27T17:58:58+00:00 Remove redundant whitespace - - - - - 10 changed files: - compiler/GHC/CoreToStg.hs - compiler/GHC/Stg/BcPrep.hs - compiler/GHC/Stg/Make.hs - compiler/GHC/Stg/Syntax.hs - compiler/GHC/Stg/Unarise.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Foreign.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Expr.hs Changes: ===================================== compiler/GHC/CoreToStg.hs ===================================== @@ -566,7 +566,7 @@ mkStgApp f how_bound core_args stg_args res_ty -- A regular foreign call. FCallId call -> assert exactly_saturated $ - StgOpApp (StgFCallOp call (idType f)) stg_args res_kind + StgOpApp (StgFCallOp call (collectStgFArgTypes (idType f))) stg_args res_kind TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,stg_args) @@ -722,7 +722,7 @@ coreToMkStgRhs bndr expr = do let mk_rhs = MkStgRhs { rhs_args = args' , rhs_expr = body' - , rhs_type = exprType body + , rhs_kind = MkStgKind (typeKind (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 (typeKind tick_ty) = do + | isLiftedTypeKind 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' - tick_ty + (MkStgKind tick_kind) ) letExp = StgLet noExtFieldSilent bnd (StgApp id []) pure letExp @@ -72,9 +72,10 @@ bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _) rhs) ReEntrant [voidArgId] expr' - tick_ty + (MkStgKind tick_kind) ) pure $ StgLet noExtFieldSilent bnd (StgApp id [StgVarArg realWorldPrimId]) + where tick_kind = typeKind tick_ty bcPrepExpr (StgTick tick rhs) = StgTick tick <$> bcPrepExpr rhs bcPrepExpr (StgLet xlet bnds expr) = ===================================== compiler/GHC/Stg/Make.hs ===================================== @@ -11,7 +11,6 @@ import GHC.Prelude import GHC.Unit.Module import GHC.Core.DataCon -import GHC.Core.Type (Type) import GHC.Stg.Syntax import GHC.Stg.Utils (stripStgTicksTop) @@ -27,7 +26,7 @@ import GHC.Types.Tickish data MkStgRhs = MkStgRhs { rhs_args :: [Id] -- ^ Empty for thunks , rhs_expr :: StgExpr -- ^ RHS expression - , rhs_type :: Type -- ^ RHS type (only used in the JS backend: layering violation) + , rhs_kind :: StgKind -- ^ RHS kind (only used in the JS backend: layering violation) , rhs_is_join :: !Bool -- ^ Is it a RHS for a join-point? } @@ -37,7 +36,7 @@ data MkStgRhs = MkStgRhs mkTopStgRhs :: (Module -> DataCon -> [StgArg] -> Bool) -> Bool -> Module -> CollectedCCs -> Id -> MkStgRhs -> (StgRhs, CollectedCCs) -mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs bndr mk_rhs@(MkStgRhs bndrs rhs typ _) +mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs bndr mk_rhs@(MkStgRhs bndrs rhs kind _) -- try to make a StgRhsCon first | Just rhs_con <- mkTopStgRhsCon_maybe (allow_toplevel_con_app this_mod) mk_rhs = ( rhs_con, ccs ) @@ -47,20 +46,20 @@ mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs bnd ( StgRhsClosure noExtFieldSilent dontCareCCS ReEntrant - bndrs rhs typ + bndrs rhs kind , ccs ) -- Otherwise it's a CAF, see Note [Cost-centre initialization plan]. | opt_AutoSccsOnIndividualCafs = ( StgRhsClosure noExtFieldSilent caf_ccs - upd_flag [] rhs typ + upd_flag [] rhs kind , collectCC caf_cc caf_ccs ccs ) | otherwise = ( StgRhsClosure noExtFieldSilent all_cafs_ccs - upd_flag [] rhs typ + upd_flag [] rhs kind , ccs ) where @@ -82,7 +81,7 @@ mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs bnd -- Generate a non-top-level RHS. Cost-centre is always currentCCS, -- see Note [Cost-centre initialization plan]. mkStgRhs :: Id -> MkStgRhs -> StgRhs -mkStgRhs bndr mk_rhs@(MkStgRhs bndrs rhs typ is_join) +mkStgRhs bndr mk_rhs@(MkStgRhs bndrs rhs kind is_join) -- try to make a StgRhsCon first | Just rhs_con <- mkStgRhsCon_maybe mk_rhs = rhs_con @@ -90,7 +89,7 @@ mkStgRhs bndr mk_rhs@(MkStgRhs bndrs rhs typ is_join) | otherwise = StgRhsClosure noExtFieldSilent currentCCS - upd_flag bndrs rhs typ + upd_flag bndrs rhs kind where upd_flag | is_join = JumpedTo | not (null bndrs) = ReEntrant @@ -151,22 +150,22 @@ isPAP env _ = False -- | Try to make a non top-level StgRhsCon if appropriate mkStgRhsCon_maybe :: MkStgRhs -> Maybe StgRhs -mkStgRhsCon_maybe (MkStgRhs bndrs rhs typ is_join) +mkStgRhsCon_maybe (MkStgRhs bndrs rhs kind is_join) | [] <- bndrs , not is_join , (ticks, StgConApp con mn args _) <- stripStgTicksTop (not . tickishIsCode) rhs - = Just (StgRhsCon currentCCS con mn ticks args typ) + = Just (StgRhsCon currentCCS con mn ticks args kind) | otherwise = Nothing -- | Try to make a top-level StgRhsCon if appropriate mkTopStgRhsCon_maybe :: (DataCon -> [StgArg] -> Bool) -> MkStgRhs -> Maybe StgRhs -mkTopStgRhsCon_maybe allow_static_con_app (MkStgRhs bndrs rhs typ is_join) +mkTopStgRhsCon_maybe allow_static_con_app (MkStgRhs bndrs rhs kind is_join) | [] <- bndrs , not is_join -- shouldn't happen at top-level , (ticks, StgConApp con mn args _) <- stripStgTicksTop (not . tickishIsCode) rhs , allow_static_con_app con args - = Just (StgRhsCon dontCareCCS con mn ticks args typ) + = Just (StgRhsCon dontCareCCS con mn ticks args kind) | otherwise = Nothing ===================================== compiler/GHC/Stg/Syntax.hs ===================================== @@ -16,6 +16,9 @@ generation. module GHC.Stg.Syntax ( StgKind(..), + StgFArgType(..), + collectStgFArgTypes, + StgArg(..), GenStgTopBinding(..), GenStgBinding(..), GenStgExpr(..), GenStgRhs(..), @@ -77,7 +80,7 @@ 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 ) +import GHC.Core.Type ( Type, tyConAppTyCon ) import GHC.Core.Ppr( {- instances -} ) import GHC.Types.ForeignCall ( ForeignCall ) @@ -85,7 +88,7 @@ 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 ) +import GHC.Types.RepType ( typePrimRep, typePrimRep1, typePrimRepU, typePrimRep_maybe, unwrapType ) import GHC.Utils.Outputable import GHC.Utils.Panic.Plain @@ -96,6 +99,14 @@ import Data.ByteString ( ByteString ) import Data.Data ( Data ) import Data.List ( intersperse ) import GHC.Tc.Utils.TcType (Kind) +import GHC.Core.TyCo.Rep (Type(..)) +import GHC.Builtin.Types.Prim + ( arrayPrimTyCon, + byteArrayPrimTyCon, + mutableArrayPrimTyCon, + mutableByteArrayPrimTyCon, + smallArrayPrimTyCon, + smallMutableArrayPrimTyCon ) newtype StgKind = MkStgKind { getStgKind :: Kind } @@ -414,7 +425,7 @@ data GenStgRhs pass [BinderP pass] -- ^ arguments; if empty, then not a function; -- as above, order is important. (GenStgExpr pass) -- ^ body - Type -- ^ result type + StgKind -- ^ result kind {- An example may be in order. Consider: @@ -444,7 +455,7 @@ important): ConstructorNumber [StgTickish] [StgArg] -- Saturated Args. See Note [Constructor applications in STG] - Type -- Type, for rewriting to an StgRhsClosure + StgKind -- Kind, for rewriting to an StgRhsClosure -- | Like 'GHC.Hs.Extension.NoExtField', but with an 'Outputable' instance that -- returns 'empty'. @@ -701,6 +712,51 @@ isUpdatable SingleEntry = False isUpdatable Updatable = True isUpdatable JumpedTo = False +-- The minimum amount of information needed to determine +-- the offset to apply to an argument to a foreign call. +-- See Note [Unlifted boxed arguments to foreign calls] +data StgFArgType + = StgPlainType + | StgArrayType + | StgSmallArrayType + | StgByteArrayType + +-- From a function, extract information needed to determine +-- the offset of each argument when used as a C FFI argument. +-- See Note [Unlifted boxed arguments to foreign calls] +collectStgFArgTypes :: Type -> [StgFArgType] +collectStgFArgTypes = go [] + where + -- Skip foralls + go bs (ForAllTy _ res) = go bs res + go bs (AppTy{}) = reverse bs + go bs (TyConApp{}) = reverse bs + go bs (LitTy{}) = reverse bs + go bs (TyVarTy{}) = reverse bs + go _ (CastTy{}) = panic "myCollectTypeArgs: CastTy" + go _ (CoercionTy{}) = panic "myCollectTypeArgs: CoercionTy" + go bs (FunTy {ft_arg = arg, ft_res=res}) = + go (typeToStgFArgType arg:bs) res + +-- Choose the offset based on the type. For anything other +-- than an unlifted boxed type, there is no offset. +-- See Note [Unlifted boxed arguments to foreign calls] +typeToStgFArgType :: Type -> StgFArgType +typeToStgFArgType typ + | tycon == arrayPrimTyCon = StgArrayType + | tycon == mutableArrayPrimTyCon = StgArrayType + | tycon == smallArrayPrimTyCon = StgSmallArrayType + | tycon == smallMutableArrayPrimTyCon = StgSmallArrayType + | tycon == byteArrayPrimTyCon = StgByteArrayType + | tycon == mutableByteArrayPrimTyCon = StgByteArrayType + | otherwise = StgPlainType + where + -- Should be a tycon app, since this is a foreign call. We look + -- through newtypes so the offset does not change if a user replaces + -- a type in a foreign function signature with a representationally + -- equivalent newtype. + tycon = tyConAppTyCon (unwrapType typ) + {- ************************************************************************ * * @@ -717,11 +773,12 @@ data StgOp | StgPrimCallOp PrimCall - | StgFCallOp ForeignCall Type - -- The Type, which is obtained from the foreign import declaration - -- itself, is needed by the stg-to-cmm pass to determine the offset to - -- apply to unlifted boxed arguments in GHC.StgToCmm.Foreign. See Note - -- [Unlifted boxed arguments to foreign calls] + | StgFCallOp ForeignCall [StgFArgType] + -- The foreign argument types, which are obtained from the foreign + -- import declaration itself, areneeded by the stg-to-cmm pass to + -- determine the offset to apply to unlifted boxed arguments in + -- GHC.StgToCmm.Foreign. + -- See Note [Unlifted boxed arguments to foreign calls] | StgTagToEnumOp TyCon @@ -915,6 +972,8 @@ pprStgOp :: StgOp -> SDoc pprStgOp (StgPrimOp op) = ppr op pprStgOp (StgPrimCallOp op)= ppr op pprStgOp (StgFCallOp op _) = ppr op +-- TODO: how do we want to pretty print this? +pprStgOp (StgTagToEnumOp tyc) = text "TagToEnumOp" <+> ppr tyc instance Outputable StgOp where ppr = pprStgOp ===================================== compiler/GHC/Stg/Unarise.hs ===================================== @@ -494,7 +494,7 @@ unariseBinding rho top_level (StgRec xrhss) = StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho top_level rhs) xrhss unariseRhs :: UnariseEnv -> Bool -> StgRhs -> UniqSM StgRhs -unariseRhs rho top_level (StgRhsClosure ext ccs update_flag args expr typ) +unariseRhs rho top_level (StgRhsClosure ext ccs update_flag args expr kind) = do (rho', args1) <- unariseFunArgBinders rho args expr' <- unariseExpr rho' expr -- Unarisation can lead to a StgRhsClosure becoming a StgRhsCon. @@ -515,7 +515,7 @@ unariseRhs rho top_level (StgRhsClosure ext ccs update_flag args expr typ) let mk_rhs = MkStgRhs { rhs_args = args1 , rhs_expr = expr' - , rhs_type = typ + , rhs_kind = kind , rhs_is_join = update_flag == JumpedTo } if | top_level @@ -527,7 +527,7 @@ unariseRhs rho top_level (StgRhsClosure ext ccs update_flag args expr typ) -> pure rhs_con | otherwise - -> pure (StgRhsClosure ext ccs update_flag args1 expr' typ) + -> pure (StgRhsClosure ext ccs update_flag args1 expr' kind) unariseRhs rho _top (StgRhsCon ccs con mu ts args typ) = assert (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con)) ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -47,7 +47,6 @@ import GHC.Utils.Misc import GHC.Utils.Logger import GHC.Types.Var.Set import GHC.Builtin.Types.Prim -import GHC.Core.TyCo.Ppr ( pprType ) import GHC.Utils.Error import GHC.Builtin.Uniques import GHC.Data.FastString @@ -2171,7 +2170,7 @@ mkDummyLiteral platform pr maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (StgArg, [Name]) -- Detect and extract relevant info for the tagToEnum kludge. -maybe_is_tagToEnum_call (StgOpApp (StgTagToEnumOp tyc) args t) +maybe_is_tagToEnum_call (StgOpApp (StgTagToEnumOp tyc) args _) | [v] <- args = Just (v, extract_constr_Names tyc) | otherwise ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -688,6 +688,7 @@ isSimpleOp (StgPrimOp op) stg_args = do -- See Note [Inlining out-of-line primops and heap checks] return $! shouldInlinePrimOp cfg op arg_exprs isSimpleOp (StgPrimCallOp _) _ = return False +isSimpleOp (StgTagToEnumOp _) _ = return True ----------------- chooseReturnBndrs :: Id -> AltType -> [CgStgAlt] -> [NonVoid Id] ===================================== compiler/GHC/StgToCmm/Foreign.hs ===================================== @@ -42,7 +42,6 @@ import GHC.Cmm.Reg ( GlobalArgRegs(..) ) import GHC.Cmm.Utils import GHC.Cmm.Graph import GHC.Cmm.CallConv -import GHC.Core.Type import GHC.Types.RepType import GHC.Cmm.CLabel import GHC.Runtime.Heap.Layout @@ -53,8 +52,6 @@ import GHC.Types.Basic import GHC.Types.Unique.DSM import GHC.Unit.Types -import GHC.Core.TyCo.Rep -import GHC.Builtin.Types.Prim import GHC.Utils.Misc (zipEqual) import Control.Monad @@ -67,13 +64,13 @@ import Control.Monad -- Precondition: the length of the arguments list is the same as the -- arity of the foreign function. cgForeignCall :: ForeignCall -- the op - -> Type -- type of foreign function + -> [StgFArgType] -> [StgArg] -- x,y arguments -> StgKind -- result kind -> FCode ReturnKind -cgForeignCall (CCall (CCallSpec target cconv safety)) typ stg_args res_kind - = do { cmm_args <- getFCallArgs stg_args typ +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) ; let ((call_args, arg_hints), cmm_target) @@ -711,15 +708,15 @@ closureField profile off = off + fixedHdrSize profile getFCallArgs :: [StgArg] - -> Type -- the type of the foreign function + -> [StgFArgType] -> FCode [(CmmExpr, ForeignHint)] -- (a) Drop void args -- (b) Add foreign-call shim code -- It's (b) that makes this differ from getNonVoidArgAmodes -- Precondition: args and typs have the same length -- See Note [Unlifted boxed arguments to foreign calls] -getFCallArgs args typ - = do { mb_cmms <- mapM get (zipEqual args (collectStgFArgTypes typ)) +getFCallArgs args arg_tys + = do { mb_cmms <- mapM get (zipEqual args arg_tys) ; return (catMaybes mb_cmms) } where get (arg,typ) @@ -734,15 +731,6 @@ getFCallArgs args typ arg_reps = typePrimRep arg_ty hint = typeForeignHint arg_ty --- The minimum amount of information needed to determine --- the offset to apply to an argument to a foreign call. --- See Note [Unlifted boxed arguments to foreign calls] -data StgFArgType - = StgPlainType - | StgArrayType - | StgSmallArrayType - | StgByteArrayType - -- See Note [Unlifted boxed arguments to foreign calls] add_shim :: Profile -> StgFArgType -> CmmExpr -> CmmExpr add_shim profile ty expr = case ty of @@ -752,39 +740,3 @@ add_shim profile ty expr = case ty of StgByteArrayType -> cmmOffsetB platform expr (arrWordsHdrSize profile) where platform = profilePlatform profile - --- From a function, extract information needed to determine --- the offset of each argument when used as a C FFI argument. --- See Note [Unlifted boxed arguments to foreign calls] -collectStgFArgTypes :: Type -> [StgFArgType] -collectStgFArgTypes = go [] - where - -- Skip foralls - go bs (ForAllTy _ res) = go bs res - go bs (AppTy{}) = reverse bs - go bs (TyConApp{}) = reverse bs - go bs (LitTy{}) = reverse bs - go bs (TyVarTy{}) = reverse bs - go _ (CastTy{}) = panic "myCollectTypeArgs: CastTy" - go _ (CoercionTy{}) = panic "myCollectTypeArgs: CoercionTy" - go bs (FunTy {ft_arg = arg, ft_res=res}) = - go (typeToStgFArgType arg:bs) res - --- Choose the offset based on the type. For anything other --- than an unlifted boxed type, there is no offset. --- See Note [Unlifted boxed arguments to foreign calls] -typeToStgFArgType :: Type -> StgFArgType -typeToStgFArgType typ - | tycon == arrayPrimTyCon = StgArrayType - | tycon == mutableArrayPrimTyCon = StgArrayType - | tycon == smallArrayPrimTyCon = StgSmallArrayType - | tycon == smallMutableArrayPrimTyCon = StgSmallArrayType - | tycon == byteArrayPrimTyCon = StgByteArrayType - | tycon == mutableByteArrayPrimTyCon = StgByteArrayType - | otherwise = StgPlainType - where - -- Should be a tycon app, since this is a foreign call. We look - -- through newtypes so the offset does not change if a user replaces - -- a type in a foreign function signature with a representationally - -- equivalent newtype. - tycon = tyConAppTyCon (unwrapType typ) ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -36,6 +36,7 @@ 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 ) import GHC.Cmm.Utils @@ -85,6 +86,22 @@ cgOpApp (StgPrimCallOp primcall) args _res_ty ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall)) ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args } +-- tagToEnum# is special: we need to pull the constructor +-- out of the table, and perform an appropriate return. +cgOpApp (StgTagToEnumOp tyc) args _ = do + amodes <- getNonVoidArgAmodes args + case amodes of + [amode] -> do + -- If you're reading this code in the attempt to figure + -- out why the compiler panic'ed here, it is probably because + -- you used tagToEnum# in a non-monomorphic setting, e.g., + -- intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x# + -- That won't work. + massert (isEnumerationTyCon tyc) + platform <- getPlatform + emitReturn [tagToClosure platform tyc amode] + _ -> pprPanic "cgOpApp: tagToEnum# should be applied to exactly one argument" (ppr args) + cmmPrimOpApp :: StgToCmmConfig -> PrimOp -> [CmmExpr] -> Maybe StgKind -> FCode ReturnKind cmmPrimOpApp cfg primop cmm_args mres_ty = case emitPrimOp cfg primop cmm_args of @@ -1670,7 +1687,7 @@ emitPrimOp cfg primop = -- tagToEnum# is removed in CoreToStg and rewritten to a special StgTagToEnumOp -- See Note [?] - TagToEnumOp -> panic "emitPrimOp: TagToEnumOp should have been gone by now" + TagToEnumOp -> panic "emitPrimOp: TagToEnumOp should have been gone by now" -- Out of line primops. -- TODO compiler need not know about these ===================================== compiler/GHC/StgToJS/Expr.hs ===================================== @@ -307,9 +307,9 @@ genBody :: HasDebugCallStack -> StgReg -> [Id] -> CgStgExpr - -> Type + -> StgKind -> G JStgStat -genBody ctx startReg args e typ = do +genBody ctx startReg args e kind = do -- load arguments into local variables la <- do args' <- concatMapM genIdArgI args @@ -320,7 +320,7 @@ genBody ctx startReg args e typ = do -- compute PrimReps and their number of slots required to return the result of -- i applied to args. - let res_vars = resultSize typ + let res_vars = resultSize kind -- compute typed expressions for each slot and assign registers let go_var regs = \case @@ -338,6 +338,12 @@ genBody ctx startReg args e typ = do return $ la <> lav <> e <> returnStack +-- TODO: move to a proper place +stgKindPrimRep :: StgKind -> [PrimRep] +stgKindPrimRep (MkStgKind kind) = case kindPrimRep_maybe kind of + Just rs -> rs + r -> pprPanic "stgKindPrimRep" (ppr r) + -- | Find the result type after applying the function to the arguments -- -- It's trickier than it looks because: @@ -361,12 +367,12 @@ genBody ctx startReg args e typ = do -- In case of failure to determine the type, we default to LiftedRep as it's -- probably what it is. -- -resultSize :: HasDebugCallStack => Type -> [(PrimRep, Int)] -resultSize ty = result +resultSize :: HasDebugCallStack => StgKind -> [(PrimRep, Int)] +resultSize kind = result where result = result_reps `zip` result_slots result_slots = fmap (slotCount . primRepSize) result_reps - result_reps = typePrimRep ty + 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. @@ -1121,6 +1127,8 @@ genPrimOp ctx op args = do genTagToEnumOp :: ExprCtx -> TyCon -> StgArg -> State.StateT GenState IO (JStgStat, ExprResult) genTagToEnumOp ctx tyc arg = do - [tag] <- genArg arg - let [v] = concatMap typex_expr $ ctxTarget ctx - pure (v |= if tyc == boolTyCon then IfExpr tag true_ false_ else app hdTagToEnum [tag], ExprInline) \ No newline at end of file + tags <- genArg arg + case (tags, concatMap typex_expr $ ctxTarget ctx) of + ([tag], [v]) -> + pure (v |= if tyc == boolTyCon then IfExpr tag true_ false_ else app hdTagToEnum [tag], ExprInline) + _ -> pprPanic "genTagToEnumOp: should be applied to exactly one argument and have one result" (ppr ctx <+> ppr tyc <+> ppr arg) \ No newline at end of file View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/21a9e5b729e6026545c3c2f46dfa67e... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/21a9e5b729e6026545c3c2f46dfa67e... You're receiving this email because of your account on gitlab.haskell.org.