Sebastian Graf pushed to branch wip/sg/first-class-strict at Glasgow Haskell Compiler / GHC Commits: 1485c1ae by I-Al-Istannen at 2026-06-18T20:37:14+02:00 Strict: STG representation and code generation Treats Strict a as a single unlifted heap pointer through RepType, unarisation, STG lint, tag inference and StgToCmm: an unlifted box is already evaluated and properly tagged, so it is returned directly unless applied as a function. An STG Lint check flags an evaluated binder lowered to an updatable indirection. Co-authored-by: Sebastian Graf <sgraf1337@gmail.com> - - - - - 1ca509da by Sebastian Graf at 2026-06-18T20:37:14+02:00 Strict: add a should_run test for the strict-field machinery StrictBox exercises a strict value field built from a thunk (forced to an evaluated, properly-tagged value), a strict field of function type that is applied, worker/wrapper unboxing of a strict argument, and a strict field holding another boxed value. Run with -dtag-inference-checks so that a strict field that is not properly tagged aborts at runtime. - - - - - 15 changed files: - compiler/GHC/Builtin/PrimOps/Casts.hs - compiler/GHC/Stg/Lint.hs - compiler/GHC/Stg/Unarise.hs - compiler/GHC/StgToCmm/Closure.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/TagCheck.hs - compiler/GHC/Types/RepType.hs - + testsuite/tests/codeGen/should_run/StrictBox.hs - + testsuite/tests/codeGen/should_run/StrictBox.stdout - testsuite/tests/codeGen/should_run/all.T - testsuite/tests/core-to-stg/T24124.stderr - testsuite/tests/ghci.debugger/scripts/T13825-debugger.stdout - testsuite/tests/ghci.debugger/scripts/print007.stdout - testsuite/tests/ghci.debugger/scripts/print022.stdout - testsuite/tests/simplStg/should_compile/T15226b.stderr Changes: ===================================== compiler/GHC/Builtin/PrimOps/Casts.hs ===================================== @@ -53,6 +53,10 @@ getCasts from_rep to_rep | -- pprTrace "getCasts" (ppr (from_rep,to_rep)) $ to_rep == from_rep = [] + | from_rep == BoxedRep (Just Lifted) && to_rep == BoxedRep (Just Unlifted) + = [] + | to_rep == BoxedRep (Just Lifted) && from_rep == BoxedRep (Just Unlifted) + = [] -- Float <-> Double | to_rep == FloatRep = ===================================== compiler/GHC/Stg/Lint.hs ===================================== @@ -101,7 +101,7 @@ import GHC.Stg.Syntax import GHC.Stg.Utils import GHC.Core.DataCon -import GHC.Core ( AltCon(..) ) +import GHC.Core ( AltCon(..), isEvaldUnfolding ) import GHC.Core.Type import GHC.Core.Lint ( lintMessage ) @@ -126,6 +126,7 @@ import Control.Monad import GHC.Core.Multiplicity (scaledThing) import GHC.Settings (Platform) import GHC.Core.TyCon (primRepCompatible, primRepsCompatible) +import GHC.Builtin.Types (isStrictTy) lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id) => Platform @@ -230,8 +231,23 @@ lint_binds_help top_lvl (binder, rhs) -- Check binder doesn't have unlifted type or it's a join point checkL ( isJoinId binder || not (isUnliftedType (idType binder)) + || isNiceStrict -- Allow Strict bindings for now. They should be in HNF. || isDataConWorkId binder || isDataConWrapId binder) -- until #17521 is fixed (mkUnliftedTyMsg opts binder rhs) + -- See Note [The Strict type] in GHC.Builtin.Types: a binder known to be + -- evaluated (an evald unfolding) must not be lowered to an updatable + -- indirection, which would turn an EPT value into a non-EPT thunk. An + -- evaluated indirection should have been shortened away instead. + when (not (isTopLevel top_lvl)) $ + checkL (not (isEvaldUnfolding (idUnfolding binder)) || not (isUpdatableIndirection rhs)) + (mkEvaldUpdatableMsg opts binder rhs) + where + isNiceStrict = isStrictTy (idType binder) && not (isRhsUpdatable rhs) + isRhsUpdatable (StgRhsClosure _ _ flag _ _ _) = isUpdatable flag + isRhsUpdatable (StgRhsCon {}) = False + -- An updatable thunk whose body is just a reference to another variable. + isUpdatableIndirection (StgRhsClosure _ _ flag [] (StgApp _ []) _) = isUpdatable flag + isUpdatableIndirection _ = False -- | Top-level bindings can't inherit the cost centre stack from their -- (static) allocation site. @@ -566,3 +582,10 @@ mkUnliftedTyMsg opts binder rhs text "has unlifted type" <+> quotes (ppr (idType binder))) $$ (text "RHS:" <+> pprStgRhs opts rhs) + +mkEvaldUpdatableMsg :: OutputablePass a => StgPprOpts -> Id -> GenStgRhs a -> SDoc +mkEvaldUpdatableMsg opts binder rhs + = (text "Let binder" <+> quotes (ppr binder) <+> + text "has an evaluated unfolding but an updatable indirection RHS") + $$ + (text "RHS:" <+> pprStgRhs opts rhs) ===================================== compiler/GHC/Stg/Unarise.hs ===================================== @@ -416,7 +416,6 @@ import GHC.Builtin.PrimOps.Casts import GHC.Platform import Data.List (mapAccumL) --- import GHC.Utils.Trace -------------------------------------------------------------------------------- -- | A mapping from binders to the Ids they were expanded/renamed to. @@ -843,7 +842,7 @@ mapSumIdBinders alt_bndr args rhs rho0 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 + layout1 = layoutUbxSum arg_slots (map (\s -> (s, True)) id_slots) -- See Note [Casting slot arguments] -- Most of the code here is just to make sure our binders are of the @@ -927,7 +926,7 @@ mkUbxSum platform dc ty_args args0 us = let tag_slot :| sum_slots = ubxSumRepType ty_args -- drop tag slot - field_slots = (mapMaybe (repSlotTy . stgArgRep) args0) + field_slots = mapMaybe argToSlotTy args0 tag = dataConTag dc layout' = layoutUbxSum sum_slots field_slots @@ -970,6 +969,10 @@ mkUbxSum platform dc ty_args args0 us , Just lit' <- castLiteralArg platform (slotPrimRep slot_ty) lit = Just (StgLitArg lit', us, id) castArg us slot_ty arg + -- A lifted pointer stored in an unlifted slot needs no conversion; both + -- are heap pointers. + | slot_ty == PtrUnliftedSlot && stgArgRepU arg == BoxedRep (Just Lifted) + = Nothing -- Cast the argument to the type of the slot if required | slotPrimRep slot_ty /= stgArgRepU arg , (ops,types) <- unzip $ getCasts (stgArgRepU arg) $ slotPrimRep slot_ty @@ -985,12 +988,17 @@ mkUbxSum platform dc ty_args args0 us tup_args = tag_arg : slot_args in - -- pprTrace "mkUbxSum" ( - -- text "ty_args (slots)" <+> ppr ty_args $$ - -- text "args0" <+> ppr args0 $$ - -- text "wrapper" <+> - -- (ppr $ wrapper $ StgLit $ LitChar '_')) (tup_args, wrapper) + where + -- The Bool says whether a lifted pointer may occupy an unlifted slot; we + -- conservatively allow it for any pointer. Pointer slots are handled + -- loosely: this is sound only because 'fitsIn' keeps the lifted and unlifted + -- pointer slots separate, so an unlifted argument falls back to a lifted slot + -- (see 'layoutUbxSum') rather than the two being merged. + argToSlotTy :: StgArg -> Maybe (SlotTy, Bool) + argToSlotTy arg = do + ty <- repSlotTy (stgArgRep arg) + return (ty, True) -- | Return a rubbish value for the given slot type. ===================================== compiler/GHC/StgToCmm/Closure.hs ===================================== @@ -95,6 +95,7 @@ import Data.Coerce (coerce) import qualified Data.ByteString.Char8 as BS8 import GHC.StgToCmm.Config import GHC.Stg.EnforceEpt.TagSig (isTaggedSig) +import GHC.Builtin.Types (isStrictTy) ----------------------------------------------------------------------------- -- Data types and synonyms @@ -199,9 +200,9 @@ addArgReps = map (\arg -> let arg' = fromNonVoid arg mkLFArgument :: Id -> LambdaFormInfo mkLFArgument id - | isUnliftedType ty = LFUnlifted - | mightBeFunTy ty = LFUnknown True - | otherwise = LFUnknown False + | isUnliftedType ty = LFUnlifted + | mightBeFunTy ty = LFUnknown True + | otherwise = LFUnknown False where ty = idType id @@ -224,7 +225,10 @@ mkLFReEntrant top fvs args arg_descr ------------- mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo mkLFThunk thunk_ty top fvs upd_flag - = assert (not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty)) $ + | isUpdatable upd_flag && isUnliftedType thunk_ty && not (isStrictTy thunk_ty) + = pprPanic "mkLFThunk" (ppr thunk_ty <+> ppr top <+> ppr fvs <+> ppr upd_flag) +mkLFThunk thunk_ty top fvs upd_flag + = assert (not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty) || (isStrictTy thunk_ty)) $ LFThunk top (null fvs) (isUpdatable upd_flag) NonStandardThunk @@ -542,8 +546,12 @@ getCallMethod cfg name id (LFReEntrant _ arity _ _) n_args _cg_loc _self_loop_in | n_args < arity = SlowCall -- Not enough args | otherwise = DirectEntry (enterIdLabel (stgToCmmPlatform cfg) name (idCafInfo id)) arity -getCallMethod _ _name _ LFUnlifted n_args _cg_loc _self_loop_info - = assert (n_args == 0) ReturnIt +getCallMethod cfg name id LFUnlifted n_args cg_loc self_loop_info + -- A value of unlifted type is already evaluated, so we can just return it, + -- unless it is also a function (e.g. @Strict (a -> b)@) that is being + -- applied, in which case we must call it. + | n_args > 0 = getCallMethod cfg name id (LFUnknown True) n_args cg_loc self_loop_info + | otherwise = ReturnIt getCallMethod _ _name _ (LFCon _) n_args _cg_loc _self_loop_info = assert (n_args == 0) ReturnIt @@ -552,7 +560,6 @@ getCallMethod _ _name _ (LFCon _) n_args _cg_loc _self_loop_info getCallMethod cfg name id (LFThunk _ _ updatable std_form_info is_fun) n_args _cg_loc _self_loop_info - | Just sig <- idTagSig_maybe id , isTaggedSig sig -- Infered to be already evaluated by EPT analysis , n_args == 0 -- See Note [EPT enforcement] ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -41,9 +41,10 @@ import GHC.Core import GHC.Core.DataCon import GHC.Types.ForeignCall import GHC.Types.Id +import GHC.Types.Unique ( hasKey ) import GHC.Builtin.PrimOps import GHC.Core.TyCon -import GHC.Core.Type ( isUnliftedType ) +import GHC.Core.Type ( isUnliftedType, splitTyConApp_maybe ) import GHC.Types.RepType ( isZeroBitTy, countConRepArgs, mightBeFunTy ) import GHC.Types.CostCentre ( CostCentreStack, currentCCS ) import GHC.Types.Tickish @@ -58,6 +59,8 @@ import Control.Arrow ( first ) import Data.List ( partition ) import GHC.Stg.EnforceEpt.TagSig (isTaggedSig) import GHC.Platform.Profile (profileIsProfiling) +import GHC.Builtin.Names (strictTyConKey, strictDataConKey) +import GHC.Plugins (varUnique) ------------------------------------------------------------------------ -- cgExpr: the main function @@ -1037,6 +1040,10 @@ cgConApp con mn stg_args ; emitReturn [idInfoToAmode idinfo] } cgIdApp :: Id -> [StgArg] -> FCode ReturnKind +cgIdApp fun_id _ + -- MkStrict is erased in CorePrep, so it must never reach the code generator. + | varUnique fun_id == strictDataConKey + = pprPanic "cgIdApp: MkStrict survived to StgToCmm" (ppr fun_id) cgIdApp fun_id args = do platform <- getPlatform fun_info <- getCgIdInfo fun_id @@ -1051,15 +1058,32 @@ cgIdApp fun_id args = do case getCallMethod cfg fun_name fun_id lf_info n_args (cg_loc fun_info) self_loop of -- A value in WHNF, so we can just return it. ReturnIt - | isZeroBitTy (idType fun_id) -> emitReturn [] - | otherwise -> emitReturn [fun] + | isZeroBitTy (idType fun_id) -> do + emitReturn [] + | otherwise -> do + if strict then + assertTag >> emitReturn [fun] + else + emitReturn [fun] + where + tcSplitMaybe = splitTyConApp_maybe (idType fun_id) + strict = case tcSplitMaybe of + Nothing -> False + Just (tc, _) -> tc `hasKey` strictTyConKey + assertTag = whenCheckTags $ do + mod <- getModuleName + emitTagAssertionStrict (showPprUnsafe + (text "TagCheck failed on entry in" <+> ppr mod <+> text "- value:" <> ppr fun_id <+> pdoc platform fun)) + fun -- A value infered to be in WHNF, so we can just return it. -- See (EPT-codegen) in Note [EPT enforcement] in GHC.Stg.EnforceEpt InferedReturnIt - | isZeroBitTy (idType fun_id) -> trace >> emitReturn [] - | otherwise -> trace >> assertTag >> - emitReturn [fun] + | isZeroBitTy (idType fun_id) -> do + trace >> emitReturn [] + | otherwise -> do + trace >> assertTag >> + emitReturn [fun] where trace = do tickyTagged @@ -1074,12 +1098,11 @@ cgIdApp fun_id args = do (text "TagCheck failed on entry in" <+> ppr mod <+> text "- value:" <> ppr fun_id <+> pdoc platform fun)) fun - EnterIt -> assertPpr (null args) (ppr fun_id $$ ppr args) $ -- Discarding arguments + EnterIt -> assertPpr (null args) (ppr fun_id $$ ppr args) $ do -- Discarding arguments emitEnter fun SlowCall -> do -- A slow function call via the RTS apply routines { tickySlowCall lf_info args - ; emitComment $ mkFastString "slowCall" ; slowCall fun args } -- A direct function call (possibly with some left-over arguments) ===================================== compiler/GHC/StgToCmm/TagCheck.hs ===================================== @@ -10,7 +10,8 @@ module GHC.StgToCmm.TagCheck ( emitTagAssertion, emitArgTagCheck, checkArg, whenCheckTags, - checkArgStatic, checkFunctionArgTags,checkConArgsStatic,checkConArgsDyn) where + checkArgStatic, checkFunctionArgTags,checkConArgsStatic,checkConArgsDyn + , emitTagAssertionStrict) where #include "ClosureTypes.h" @@ -71,6 +72,51 @@ whenCheckTags act = do check_tags <- stgToCmmDoTagCheck <$> getStgToCmmConfig when check_tags act +emitTagAssertionStrict :: String -> CmmExpr -> FCode () +emitTagAssertionStrict onWhat fun = do + { platform <- getPlatform + ; lret <- newBlockId + ; lno_tag <- newBlockId + ; lbarf <- newBlockId + -- Check for presence of any tag. + ; emit $ mkCbranch (cmmIsTagged platform fun) + lret lno_tag (Just True) + -- If there is no tag check if we are dealing with an untagged object + ; emitLabel lno_tag + ; needsTaggedPointer fun lbarf lret + + ; emitLabel lbarf + ; emitBarf ("Tag eval failed on:" ++ onWhat) + ; emitLabel lret + } + +-- | Jump to the first block if the argument is subject +-- to tagging requirements. Otherwise jump to the 2nd one. +needsTaggedPointer :: CmmExpr -> BlockId -> BlockId -> FCode () +needsTaggedPointer val fail lpass = do + profile <- getProfile + align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig + let clo_ty_e = cmmGetClosureType profile align_check val + -- The ENTER macro doesn't evaluate FUN/PAP/BCO objects. So we + -- have to accept them not being tagged. See #21193 + -- See Note [TagInfo of functions] + let targets = mkSwitchTargets + False + (INVALID_OBJECT, N_CLOSURE_TYPES) + (Just lpass) + (M.fromList [(THUNK, fail), + (THUNK_1_0, fail), + (THUNK_0_1, fail), + (THUNK_2_0, fail), + (THUNK_1_1, fail), + (THUNK_0_2, fail), + (THUNK_STATIC, fail), + (THUNK_SELECTOR, fail)]) + + emit $ mkSwitch clo_ty_e targets + + emit $ mkBranch lpass + -- | Call barf if we failed to predict a tag correctly. -- This is immensely useful when debugging issues in tag inference -- as it will result in a program abort when we encounter an invalid @@ -112,15 +158,15 @@ needsArgTag closure fail lpass = do False (INVALID_OBJECT, N_CLOSURE_TYPES) (Just fail) - (M.fromList [(PAP,lpass) - ,(BCO,lpass) - ,(FUN,lpass) - ,(FUN_1_0,lpass) - ,(FUN_0_1,lpass) - ,(FUN_2_0,lpass) - ,(FUN_1_1,lpass) - ,(FUN_0_2,lpass) - ,(FUN_STATIC,lpass) + (M.fromList [(PAP,lpass) -- 25 + ,(BCO,lpass) -- 23 + ,(FUN,lpass) -- 8 + ,(FUN_1_0,lpass) -- 9 + ,(FUN_0_1,lpass) -- 10 + ,(FUN_2_0,lpass) -- 11 + ,(FUN_1_1,lpass) -- 12 + ,(FUN_0_2,lpass) -- 13 + ,(FUN_STATIC,lpass) -- 14 ]) emit $ mkSwitch clo_ty_e targets ===================================== compiler/GHC/Types/RepType.hs ===================================== @@ -29,6 +29,7 @@ module GHC.Types.RepType import GHC.Prelude import GHC.Types.Basic (Arity, RepArity) +import GHC.Builtin.Names (strictTyConKey) import GHC.Core.DataCon import GHC.Core.Coercion import GHC.Core.TyCon @@ -100,6 +101,10 @@ unwrapType ty go t | Just t' <- coreView t = go t' go (ForAllTy _ t) = go t go (CastTy t _) = go t + -- Look through Strict types + go (TyConApp tc [t]) + | tyConUnique tc == strictTyConKey + = go t go t = t -- cf. GHC.Core.Coercion.unwrapNewTypeStepper @@ -248,29 +253,46 @@ ubxSumRepType constrs0 layoutUbxSum :: HasDebugCallStack => SortedSlotTys -- Layout of sum. Does not include tag. -- We assume that they are in increasing order - -> [SlotTy] -- Slot types of things we want to map to locations in the - -- sum layout + -> [(SlotTy, Bool)] -- Slot types of things we want to map to locations in + -- the sum layout. The Bool says whether a lifted + -- pointer may occupy an unlifted slot, i.e. it is + -- already evaluated. -> [Int] -- Where to map 'things' in the sum layout layoutUbxSum sum_slots0 arg_slots0 = go arg_slots0 IS.empty where - go :: [SlotTy] -> IS.IntSet -> [Int] + go :: [(SlotTy, Bool)] -> IS.IntSet -> [Int] go [] _ = [] go (arg : args) used - = let slot_idx = findSlot arg 0 sum_slots0 used - in slot_idx : go args (IS.insert slot_idx used) - - findSlot :: SlotTy -> Int -> SortedSlotTys -> IS.IntSet -> Int + = let slot_idx + | Just slot_idx <- findSlot (fst arg) 0 sum_slots0 used + = Just slot_idx + -- All pointer slots hold a heap pointer, so an unlifted pointer can + -- occupy a lifted slot. This bridges the gap left by 'unwrapType' + -- looking through Strict: the sum layout may have a lifted slot + -- where the argument is an (unlifted) Strict box. + | PtrUnliftedSlot <- fst arg + = findSlot PtrLiftedSlot 0 sum_slots0 used + -- An already-evaluated lifted pointer can occupy an unlifted slot. + | PtrLiftedSlot <- fst arg, snd arg + = findSlot PtrUnliftedSlot 0 sum_slots0 used + | otherwise + = Nothing + in case slot_idx of + Just slot_idx -> slot_idx : go args (IS.insert slot_idx used) + Nothing -> pprPanic "layoutUbxSum" ( text "Can't find slot for arg" <+> ppr arg + $$ text "sum_slots:" <> ppr sum_slots0 + $$ text "arg_slots:" <> ppr arg_slots0) + + findSlot :: SlotTy -> Int -> SortedSlotTys -> IS.IntSet -> Maybe Int findSlot arg slot_idx (slot : slots) useds | not (IS.member slot_idx useds) , Just slot == arg `fitsIn` slot - = slot_idx + = Just slot_idx | otherwise = findSlot arg (slot_idx + 1) slots useds - findSlot _ _ [] _ - = pprPanic "findSlot" (text "Can't find slot" $$ text "sum_slots:" <> ppr sum_slots0 - $$ text "arg_slots:" <> ppr arg_slots0 ) + findSlot _ _ [] _ = Nothing -------------------------------------------------------------------------------- @@ -730,10 +752,6 @@ mightBeFunTy :: Type -> Bool -- In particular, 'isFunTy' returns @False@ for @IO ()@ as well as for all -- type family applications. mightBeFunTy ty - -- GHC (currently) has no unlifted functions, so an unlifted type is - -- definitely not a function type. - | definitelyUnliftedType ty - = False | Just tc <- tyConAppTyCon_maybe (unwrap_type ty) -- A proper datatype (such as 'Int' or 'Maybe Bool') is definitely not -- a function type. (This does not include newtypes nor type families.) ===================================== testsuite/tests/codeGen/should_run/StrictBox.hs ===================================== @@ -0,0 +1,44 @@ +{-# LANGUAGE BangPatterns #-} + +-- | Exercises the strict-field/Strict# machinery end to end: +-- +-- * a strict value field built from a thunk, which must be forced to a +-- properly-tagged value (EPT) when the constructor is built; +-- * a strict field of /function/ type, whose box is unlifted but is applied +-- as a function (the "might be a function" call path); +-- * worker/wrapper unboxing a strict argument through Strict#; +-- * a strict field holding another boxed value, passed around by value. +-- +-- Run with -dtag-inference-checks so that any strict field that is not +-- evaluated-and-properly-tagged aborts at runtime. +module Main (main) where + +-- Strict value field + strict function field +data Box a = Box !a !(Int -> Int) + +{-# NOINLINE mkBox #-} +mkBox :: Int -> Box Int +mkBox n = Box (sum [1..n]) (\x -> x + n) -- field 1 from a thunk; field 2 a closure + +{-# NOINLINE useBox #-} +useBox :: Box Int -> Int +useBox (Box a f) = a + f 100 -- applies the strict function field + +-- A strict field holding another boxed value +data Wrap = Wrap !(Box Int) + +{-# NOINLINE useWrap #-} +useWrap :: Wrap -> Int +useWrap (Wrap b) = useBox b + +-- Worker/wrapper unboxes the strict argument through Strict# +{-# NOINLINE strictArg #-} +strictArg :: Int -> Int -> Int +strictArg !x y = x * 1000 + y + +main :: IO () +main = do + print (useBox (mkBox 5)) -- 15 + (100+5) = 120 + print (strictArg (3 + 4) 9) -- 7*1000 + 9 = 7009 + print (useWrap (Wrap (mkBox 3))) -- 6 + (100+3) = 109 + print (map (useBox . mkBox) [1, 2, 3]) -- [102, 105, 109] ===================================== testsuite/tests/codeGen/should_run/StrictBox.stdout ===================================== @@ -0,0 +1,4 @@ +120 +7009 +109 +[102,105,109] ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -289,3 +289,7 @@ test('T27072w', [req_c, js_skip, when(opsys('darwin'), skip)], # AArch64-specific runtime tests test('aarch64-ushr-subword-run', [unless(arch('aarch64'), skip)], compile_and_run, ['-O']) test('aarch64-subword-ops', [unless(arch('aarch64'), skip)], compile_and_run, ['-O']) + +# Strict# / strict-field machinery, with runtime tag-inference checks +test('StrictBox', normal, compile_and_run, + ['-O -dtag-inference-checks -fmax-simplifier-iterations=20']) ===================================== testsuite/tests/core-to-stg/T24124.stderr ===================================== @@ -1,17 +1,36 @@ ==================== Final STG: ==================== -T24124.MkStrictPair [InlPrag=CONLIKE] +T24124.$WMkStrictPair [InlPrag=INLINE[final] CONLIKE] :: forall a b. a %1 -> b %1 -> T24124.StrictPair a b -[GblId[DataCon], +[GblId[DataConWrapper], Arity=2, Caf=NoCafRefs, Str=<SL><SL>, Unf=OtherCon []] = - {} \r [eta eta] - case eta of eta { + {} \r [conrep conrep] + case conrep of $WMkStrictPair_sat { + __DEFAULT -> + case $WMkStrictPair_sat<TagProper> of conrep_ubx { + __DEFAULT -> + case conrep of $WMkStrictPair_sat { __DEFAULT -> - case eta of eta { __DEFAULT -> T24124.MkStrictPair [eta eta]; }; + case $WMkStrictPair_sat<TagProper> of conrep_ubx { + __DEFAULT -> T24124.MkStrictPair [conrep_ubx conrep_ubx]; }; + }; + }; + }; + +T24124.MkStrictPair [InlPrag=CONLIKE] + :: forall {a} {b}. + GHC.Internal.Types.Strict# a + %1 -> GHC.Internal.Types.Strict# b %1 -> T24124.StrictPair a b +[GblId[DataCon], + Arity=2, + Caf=NoCafRefs, + Str=<SL><SL>, + Unf=OtherCon []] = + {} \r [eta eta] T24124.MkStrictPair [eta eta]; T24124.testFun1 :: forall a b. @@ -20,13 +39,18 @@ T24124.testFun1 -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, T24124.StrictPair a b #) -[GblId, Arity=3, Str=<L><L><L>, Cpr=1, Unf=OtherCon []] = +[GblId, Arity=3, Str=<L><ML><L>, Cpr=1, Unf=OtherCon []] = {} \r [x y void] case x of testFun1_sat { __DEFAULT -> + case y of wild { + __DEFAULT -> case - case y of y [OS=OneShot] { - __DEFAULT -> T24124.MkStrictPair [testFun1_sat y]; + case wild<TagProper> of testFun1_sat { + __DEFAULT -> + case testFun1_sat<TagProper> of testFun1_sat { + __DEFAULT -> T24124.MkStrictPair [testFun1_sat testFun1_sat]; + }; } of testFun1_sat @@ -34,11 +58,12 @@ T24124.testFun1 __DEFAULT -> GHC.Internal.Types.MkSolo# [testFun1_sat]; }; }; + }; T24124.testFun :: forall a b. a -> b -> GHC.Internal.Types.IO (T24124.StrictPair a b) -[GblId, Arity=3, Str=<L><L><L>, Cpr=1, Unf=OtherCon []] = +[GblId, Arity=3, Str=<L><ML><L>, Cpr=1, Unf=OtherCon []] = {} \r [eta eta void] T24124.testFun1 eta eta GHC.Internal.Prim.void#; ===================================== testsuite/tests/ghci.debugger/scripts/T13825-debugger.stdout ===================================== @@ -1,9 +1,10 @@ Packed1 12.34# 56.78# 42# 99.99# packed1 = Packed1 12.34 56.78 42 99.99 Packed2 12.34 56.78 42 99.99 -packed2 = Packed2 12.34 56.78 42 99.99 +packed2 = Packed2 (F# 12.34) (F# 56.78) (I# 42) (F# 99.99) Packed3 1 2 3 4 5 6 7.8 9.0 packed3 = Packed3 (GHC.Internal.Word.W8# 1) (GHC.Internal.Int.I8# 2) (GHC.Internal.Int.I64# 3) (GHC.Internal.Word.W16# 4) - (GHC.Internal.Word.W64# 5) (GHC.Internal.Word.W32# 6) 7.8 9.0 + (GHC.Internal.Word.W64# 5) (GHC.Internal.Word.W32# 6) (F# 7.8) + (D# 9.0) ===================================== testsuite/tests/ghci.debugger/scripts/print007.stdout ===================================== @@ -1,6 +1,6 @@ () -s = S2 'a' 'b' +s = S2 'a' (GHC.Internal.Types.C# 'b') () -s = S2 'a' 'b' +s = S2 'a' (GHC.Internal.Types.C# 'b') () s = S2 'a' 'b' ===================================== testsuite/tests/ghci.debugger/scripts/print022.stdout ===================================== @@ -4,5 +4,5 @@ Breakpoint 0 activated at print022.hs:11:7 Stopped in Main.f, print022.hs:11:7 _result :: p = _ x :: p = _ -x = C2 1 (W# 32) (TwoFields 'a' 3) +x = C2 (I# 1) (W# 32) (TwoFields 'a' 3) x :: T2 ===================================== testsuite/tests/simplStg/should_compile/T15226b.stderr ===================================== @@ -1,12 +1,28 @@ ==================== Final STG: ==================== -T15226b.Str [InlPrag=CONLIKE] :: forall a. a %1 -> T15226b.Str a +T15226b.$WStr [InlPrag=INLINE[final] CONLIKE] + :: forall a. a %1 -> T15226b.Str a +[GblId[DataConWrapper], + Arity=1, + Caf=NoCafRefs, + Str=<SL>, + Unf=OtherCon []] = + {} \r [conrep] + case conrep of $WStr_sat { + __DEFAULT -> + case $WStr_sat<TagProper> of conrep_ubx { + __DEFAULT -> T15226b.Str [conrep_ubx]; + }; + }; + +T15226b.Str [InlPrag=CONLIKE] + :: forall {a}. GHC.Internal.Types.Strict# a %1 -> T15226b.Str a [GblId[DataCon], Arity=1, Caf=NoCafRefs, Str=<SL>, Unf=OtherCon []] = - {} \r [eta] case eta of eta { __DEFAULT -> T15226b.Str [eta]; }; + {} \r [eta] T15226b.Str [eta]; T15226b.bar1 :: forall a. @@ -20,8 +36,11 @@ T15226b.bar1 __DEFAULT -> let { bar1_sat [Occ=Once1] :: T15226b.Str (GHC.Internal.Maybe.Maybe a) - [LclId, Unf=OtherCon []] = - T15226b.Str! [bar1_sat]; + [LclId] = + {bar1_sat} \u [] + case bar1_sat<TagProper> of bar1_sat { + __DEFAULT -> T15226b.Str [bar1_sat]; + }; } in GHC.Internal.Types.MkSolo# [bar1_sat]; }; View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c40b14f19b8f02a50a1420a525b8432... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c40b14f19b8f02a50a1420a525b8432... You're receiving this email because of your account on gitlab.haskell.org.