[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Use a uniform return convention in bytecode for unary results
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sat May 13 16:48:47 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
d85ed900 by Alexis King at 2023-05-13T08:45:18-04:00
Use a uniform return convention in bytecode for unary results
fixes #22958
- - - - -
8a0d45f7 by Bodigrim at 2023-05-13T08:45:58-04:00
Add more instances for Compose: Enum, Bounded, Num, Real, Integral
See https://github.com/haskell/core-libraries-committee/issues/160 for discussion
- - - - -
bfba6620 by Simon Peyton Jones at 2023-05-13T12:48:24-04:00
Make GHC.Types.Id.Make.shouldUnpackTy a bit more clever
As #23307, GHC.Types.Id.Make.shouldUnpackTy was leaving money on the
table, failing to unpack arguments that are perfectly unpackable.
The fix is pretty easy; see Note [Recursive unboxing]
- - - - -
f77a8c02 by sheaf at 2023-05-13T12:48:29-04:00
Fix bad multiplicity role in tyConAppFunCo_maybe
The function tyConAppFunCo_maybe produces a multiplicity coercion
for the multiplicity argument of the function arrow, except that
it could be at the wrong role if asked to produce a representational
coercion. We fix this by using the 'funRole' function, which computes
the right roles for arguments to the function arrow TyCon.
Fixes #23386
- - - - -
29 changed files:
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/Core/Coercion.hs-boot
- compiler/GHC/Core/TyCo/Rep.hs-boot
- compiler/GHC/Core/Type.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToCmm/Closure.hs
- compiler/GHC/Types/Id/Make.hs
- libraries/base/Data/Functor/Compose.hs
- libraries/base/changelog.md
- rts/Disassembler.c
- rts/Interpreter.c
- rts/Printer.c
- rts/StgMiscClosures.cmm
- rts/include/rts/Bytecodes.h
- rts/include/stg/MiscClosures.h
- + testsuite/tests/ghci/should_run/T22958a.hs
- + testsuite/tests/ghci/should_run/T22958a.stdout
- + testsuite/tests/ghci/should_run/T22958b.hs
- + testsuite/tests/ghci/should_run/T22958b.stdout
- testsuite/tests/ghci/should_run/all.T
- + testsuite/tests/simplCore/should_compile/T23307.hs
- + testsuite/tests/simplCore/should_compile/T23307.stderr
- + testsuite/tests/simplCore/should_compile/T23307a.hs
- + testsuite/tests/simplCore/should_compile/T23307a.stderr
- + testsuite/tests/simplCore/should_compile/T23307b.hs
- + testsuite/tests/simplCore/should_compile/T23307c.hs
- + testsuite/tests/simplCore/should_compile/T23307c.stderr
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -395,10 +395,7 @@ assembleI platform i = case i of
PUSH_BCO proto -> do let ul_bco = assembleBCO platform proto
p <- ioptr (liftM BCOPtrBCO ul_bco)
emit bci_PUSH_G [Op p]
- PUSH_ALTS proto -> do let ul_bco = assembleBCO platform proto
- p <- ioptr (liftM BCOPtrBCO ul_bco)
- emit bci_PUSH_ALTS [Op p]
- PUSH_ALTS_UNLIFTED proto pk
+ PUSH_ALTS proto pk
-> do let ul_bco = assembleBCO platform proto
p <- ioptr (liftM BCOPtrBCO ul_bco)
emit (push_alts pk) [Op p]
@@ -504,8 +501,7 @@ assembleI platform i = case i of
SWIZZLE stkoff n -> emit bci_SWIZZLE [SmallOp stkoff, SmallOp n]
JMP l -> emit bci_JMP [LabelOp l]
ENTER -> emit bci_ENTER []
- RETURN -> emit bci_RETURN []
- RETURN_UNLIFTED rep -> emit (return_unlifted rep) []
+ RETURN rep -> emit (return_non_tuple rep) []
RETURN_TUPLE -> emit bci_RETURN_T []
CCALL off m_addr i -> do np <- addr m_addr
emit bci_CCALL [SmallOp off, Op np, SmallOp i]
@@ -574,16 +570,16 @@ push_alts V16 = error "push_alts: vector"
push_alts V32 = error "push_alts: vector"
push_alts V64 = error "push_alts: vector"
-return_unlifted :: ArgRep -> Word16
-return_unlifted V = bci_RETURN_V
-return_unlifted P = bci_RETURN_P
-return_unlifted N = bci_RETURN_N
-return_unlifted L = bci_RETURN_L
-return_unlifted F = bci_RETURN_F
-return_unlifted D = bci_RETURN_D
-return_unlifted V16 = error "return_unlifted: vector"
-return_unlifted V32 = error "return_unlifted: vector"
-return_unlifted V64 = error "return_unlifted: vector"
+return_non_tuple :: ArgRep -> Word16
+return_non_tuple V = bci_RETURN_V
+return_non_tuple P = bci_RETURN_P
+return_non_tuple N = bci_RETURN_N
+return_non_tuple L = bci_RETURN_L
+return_non_tuple F = bci_RETURN_F
+return_non_tuple D = bci_RETURN_D
+return_non_tuple V16 = error "return_non_tuple: vector"
+return_non_tuple V32 = error "return_non_tuple: vector"
+return_non_tuple V64 = error "return_non_tuple: vector"
{-
we can only handle up to a fixed number of words on the stack,
=====================================
compiler/GHC/ByteCode/Instr.hs
=====================================
@@ -88,8 +88,7 @@ data BCInstr
| PUSH_BCO (ProtoBCO Name)
-- Push an alt continuation
- | PUSH_ALTS (ProtoBCO Name)
- | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep
+ | PUSH_ALTS (ProtoBCO Name) ArgRep
| PUSH_ALTS_TUPLE (ProtoBCO Name) -- continuation
!NativeCallInfo
(ProtoBCO Name) -- tuple return BCO
@@ -197,9 +196,10 @@ data BCInstr
-- To Infinity And Beyond
| ENTER
- | RETURN -- return a lifted value
- | RETURN_UNLIFTED ArgRep -- return an unlifted value, here's its rep
- | RETURN_TUPLE -- return an unboxed tuple (info already on stack)
+ | RETURN ArgRep -- return a non-tuple value, here's its rep; see
+ -- Note [Return convention for non-tuple values] in GHC.StgToByteCode
+ | RETURN_TUPLE -- return an unboxed tuple (info already on stack); see
+ -- Note [unboxed tuple bytecodes and tuple_BCO] in GHC.StgToByteCode
-- Breakpoints
| BRK_FUN Word16 Unique (RemotePtr CostCentre)
@@ -274,8 +274,7 @@ instance Outputable BCInstr where
<> ppr op
ppr (PUSH_BCO bco) = hang (text "PUSH_BCO") 2 (ppr bco)
- ppr (PUSH_ALTS bco) = hang (text "PUSH_ALTS") 2 (ppr bco)
- ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco)
+ ppr (PUSH_ALTS bco pk) = hang (text "PUSH_ALTS" <+> ppr pk) 2 (ppr bco)
ppr (PUSH_ALTS_TUPLE bco call_info tuple_bco) =
hang (text "PUSH_ALTS_TUPLE" <+> ppr call_info)
2
@@ -352,8 +351,7 @@ instance Outputable BCInstr where
ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff
<+> text "by" <+> ppr n
ppr ENTER = text "ENTER"
- ppr RETURN = text "RETURN"
- ppr (RETURN_UNLIFTED pk) = text "RETURN_UNLIFTED " <+> ppr pk
+ ppr (RETURN pk) = text "RETURN " <+> ppr pk
ppr (RETURN_TUPLE) = text "RETURN_TUPLE"
ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> mb_uniq <+> text "<cc>"
where mb_uniq = sdocOption sdocSuppressUniques $ \case
@@ -389,10 +387,8 @@ bciStackUse PUSH32_W{} = 1 -- takes exactly 1 word
bciStackUse PUSH_G{} = 1
bciStackUse PUSH_PRIMOP{} = 1
bciStackUse PUSH_BCO{} = 1
-bciStackUse (PUSH_ALTS bco) = 2 {- profiling only, restore CCCS -} +
+bciStackUse (PUSH_ALTS bco _) = 2 {- profiling only, restore CCCS -} +
3 + protoBCOStackUse bco
-bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 {- profiling only, restore CCCS -} +
- 4 + protoBCOStackUse bco
bciStackUse (PUSH_ALTS_TUPLE bco info _) =
-- (tuple_bco, call_info word, cont_bco, stg_ctoi_t)
-- tuple
@@ -452,8 +448,7 @@ bciStackUse TESTEQ_P{} = 0
bciStackUse CASEFAIL{} = 0
bciStackUse JMP{} = 0
bciStackUse ENTER{} = 0
-bciStackUse RETURN{} = 0
-bciStackUse RETURN_UNLIFTED{} = 1 -- pushes stg_ret_X for some X
+bciStackUse RETURN{} = 1 -- pushes stg_ret_X for some X
bciStackUse RETURN_TUPLE{} = 1 -- pushes stg_ret_t header
bciStackUse CCALL{} = 0
bciStackUse PRIMCALL{} = 1 -- pushes stg_primcall
=====================================
compiler/GHC/Core/Coercion.hs-boot
=====================================
@@ -36,6 +36,8 @@ mkSubCo :: HasDebugCallStack => Coercion -> Coercion
mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion
mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion
+funRole :: Role -> FunSel -> Role
+
isGReflCo :: Coercion -> Bool
isReflCo :: Coercion -> Bool
isReflexiveCo :: Coercion -> Bool
=====================================
compiler/GHC/Core/TyCo/Rep.hs-boot
=====================================
@@ -8,6 +8,7 @@ import {-# SOURCE #-} GHC.Core.TyCon ( TyCon )
data Type
data Coercion
+data FunSel
data CoSel
data UnivCoProvenance
data TyLit
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -274,7 +274,7 @@ import {-# SOURCE #-} GHC.Core.Coercion
, mkTyConAppCo, mkAppCo
, mkForAllCo, mkFunCo2, mkAxiomInstCo, mkUnivCo
, mkSymCo, mkTransCo, mkSelCo, mkLRCo, mkInstCo
- , mkKindCo, mkSubCo, mkFunCo
+ , mkKindCo, mkSubCo, mkFunCo, funRole
, decomposePiCos, coercionKind
, coercionRKind, coercionType
, isReflexiveCo, seqCo
@@ -1331,9 +1331,12 @@ tyConAppFunCo_maybe :: HasDebugCallStack => Role -> TyCon -> [Coercion]
-> Maybe Coercion
-- ^ Return Just if this TyConAppCo should be represented as a FunCo
tyConAppFunCo_maybe r tc cos
- | Just (af, mult, arg, res) <- ty_con_app_fun_maybe (mkReflCo r manyDataConTy) tc cos
- = Just (mkFunCo r af mult arg res)
- | otherwise = Nothing
+ | Just (af, mult, arg, res) <- ty_con_app_fun_maybe mult_refl tc cos
+ = Just (mkFunCo r af mult arg res)
+ | otherwise
+ = Nothing
+ where
+ mult_refl = mkReflCo (funRole r SelMult) manyDataConTy
ty_con_app_fun_maybe :: (HasDebugCallStack, Outputable a) => a -> TyCon -> [a]
-> Maybe (FunTyFlag, a, a, a)
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -319,7 +319,7 @@ schemeTopBind (id, rhs)
-- by just re-using the single top-level definition. So
-- for the worker itself, we must allocate it directly.
-- ioToBc (putStrLn $ "top level BCO")
- emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, RETURN])
+ emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, RETURN P])
(Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
| otherwise
@@ -480,9 +480,9 @@ returnUnliftedReps d s szb reps = do
non_void VoidRep = False
non_void _ = True
ret <- case filter non_void reps of
- -- use RETURN_UBX for unary representations
- [] -> return (unitOL $ RETURN_UNLIFTED V)
- [rep] -> return (unitOL $ RETURN_UNLIFTED (toArgRep platform rep))
+ -- use RETURN for nullary/unary representations
+ [] -> return (unitOL $ RETURN V)
+ [rep] -> return (unitOL $ RETURN (toArgRep platform rep))
-- otherwise use RETURN_TUPLE with a tuple descriptor
nv_reps -> do
let (call_info, args_offsets) = layoutNativeCall profile NativeTupleReturn 0 (primRepCmmType platform) nv_reps
@@ -526,7 +526,7 @@ schemeE
:: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList
schemeE d s p (StgLit lit) = returnUnliftedAtom d s p (StgLitArg lit)
schemeE d s p (StgApp x [])
- | not (usePlainReturn (idType x)) = returnUnliftedAtom d s p (StgVarArg x)
+ | isUnliftedType (idType x) = returnUnliftedAtom d s p (StgVarArg x)
-- Delegate tail-calls to schemeT.
schemeE d s p e@(StgApp {}) = schemeT d s p e
schemeE d s p e@(StgConApp {}) = schemeT d s p e
@@ -681,8 +681,8 @@ schemeT d s p (StgOpApp (StgPrimOp op) args _ty)
schemeT d s p (StgOpApp (StgPrimCallOp (PrimCall label unit)) args result_ty)
= generatePrimCall d s p label (Just unit) result_ty args
- -- Case 2: Unboxed tuple
schemeT d s p (StgConApp con _cn args _tys)
+ -- Case 2: Unboxed tuple
| isUnboxedTupleDataCon con || isUnboxedSumDataCon con
= returnUnboxedTuple d s p args
@@ -691,7 +691,7 @@ schemeT d s p (StgConApp con _cn args _tys)
= do alloc_con <- mkConAppCode d s p con args
platform <- profilePlatform <$> getProfile
return (alloc_con `appOL`
- mkSlideW 1 (bytesToWords platform $ d - s) `snocOL` RETURN)
+ mkSlideW 1 (bytesToWords platform $ d - s) `snocOL` RETURN P)
-- Case 4: Tail call of function
schemeT d s p (StgApp fn args)
@@ -831,14 +831,11 @@ doCase d s p scrut bndr alts
-- have the same runtime rep. We have more efficient specialized
-- return frames for the situations with one non-void element.
+ non_void_arg_reps = non_void (typeArgReps platform bndr_ty)
ubx_tuple_frame =
(isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty) &&
length non_void_arg_reps > 1
- ubx_frame = not ubx_tuple_frame && not (usePlainReturn bndr_ty)
-
- non_void_arg_reps = non_void (typeArgReps platform bndr_ty)
-
profiling
| Just interp <- hsc_interp hsc_env
= interpreterProfiled interp
@@ -847,7 +844,8 @@ doCase d s p scrut bndr alts
-- Top of stack is the return itbl, as usual.
-- underneath it is the pointer to the alt_code BCO.
-- When an alt is entered, it assumes the returned value is
- -- on top of the itbl.
+ -- on top of the itbl; see Note [Return convention for non-tuple values]
+ -- for details.
ret_frame_size_b :: StackDepth
ret_frame_size_b | ubx_tuple_frame =
(if profiling then 5 else 4) * wordSize platform
@@ -861,7 +859,6 @@ doCase d s p scrut bndr alts
-- The size of the return frame info table pointer if one exists
unlifted_itbl_size_b :: StackDepth
unlifted_itbl_size_b | ubx_tuple_frame = wordSize platform
- | ubx_frame = wordSize platform
| otherwise = 0
(bndr_size, call_info, args_offsets)
@@ -1052,17 +1049,11 @@ doCase d s p scrut bndr alts
then do tuple_bco <- emitBc (tupleBCO platform call_info args_offsets)
return (PUSH_ALTS_TUPLE alt_bco' call_info tuple_bco
`consOL` scrut_code)
- else let push_alts
- | not ubx_frame
- = PUSH_ALTS alt_bco'
- | otherwise
- = let unlifted_rep =
- case non_void_arg_reps of
- [] -> V
- [rep] -> rep
- _ -> panic "schemeE(StgCase).push_alts"
- in PUSH_ALTS_UNLIFTED alt_bco' unlifted_rep
- in return (push_alts `consOL` scrut_code)
+ else let scrut_rep = case non_void_arg_reps of
+ [] -> V
+ [rep] -> rep
+ _ -> panic "schemeE(StgCase).push_alts"
+ in return (PUSH_ALTS alt_bco' scrut_rep `consOL` scrut_code)
-- -----------------------------------------------------------------------------
@@ -1130,21 +1121,38 @@ layoutNativeCall profile call_type start_off arg_ty reps =
(orig_stk_params ++ map get_byte_off new_stk_params)
)
-{-
- We use the plain return convention (ENTER/PUSH_ALTS) for
- lifted types and unlifted algebraic types.
-
- Other types use PUSH_ALTS_UNLIFTED/PUSH_ALTS_TUPLE which expect
- additional data on the stack.
- -}
-usePlainReturn :: Type -> Bool
-usePlainReturn t
- | isUnboxedTupleType t || isUnboxedSumType t = False
- | otherwise = typePrimRep t == [LiftedRep] ||
- (typePrimRep t == [UnliftedRep] && isAlgType t)
-
-{- Note [unboxed tuple bytecodes and tuple_BCO]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Return convention for non-tuple values]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The RETURN and ENTER instructions are used to return values. RETURN directly
+returns the value at the top of the stack while ENTER evaluates it first (so
+RETURN is only used when the result is already known to be evaluated), but the
+end result is the same: control returns to the enclosing stack frame with the
+result at the top of the stack.
+
+The PUSH_ALTS instruction pushes a two-word stack frame that receives a single
+lifted value. Its payload is a BCO that is executed when control returns, with
+the stack set up as if a RETURN instruction had just been executed: the returned
+value is at the top of the stack, and beneath it is the two-word frame being
+returned to. It is the continuation BCO’s job to pop its own frame off the
+stack, so the simplest possible continuation consists of two instructions:
+
+ SLIDE 1 2 -- pop the return frame off the stack, keeping the returned value
+ RETURN P -- return the returned value to our caller
+
+RETURN and PUSH_ALTS are not really instructions but are in fact representation-
+polymorphic *families* of instructions indexed by ArgRep. ENTER, however, is a
+single real instruction, since it is only used to return lifted values, which
+are always pointers.
+
+The RETURN, ENTER, and PUSH_ALTS instructions are only used when the returned
+value has nullary or unary representation. Returning/receiving an unboxed
+tuple (or, indirectly, an unboxed sum, since unboxed sums have been desugared to
+unboxed tuples by Unarise) containing two or more results uses the special
+RETURN_TUPLE/PUSH_ALTS_TUPLE instructions, which use a different return
+convention. See Note [unboxed tuple bytecodes and tuple_BCO] for details.
+
+Note [unboxed tuple bytecodes and tuple_BCO]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We have the bytecode instructions RETURN_TUPLE and PUSH_ALTS_TUPLE to
return and receive arbitrary unboxed tuples, respectively. These
instructions use the helper data tuple_BCO and call_info.
@@ -1580,7 +1588,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args
-- slide and return
d_after_r_min_s = bytesToWords platform (d_after_r - s)
wrapup = mkSlideW (trunc16W r_sizeW) (d_after_r_min_s - r_sizeW)
- `snocOL` RETURN_UNLIFTED (toArgRep platform r_rep)
+ `snocOL` RETURN (toArgRep platform r_rep)
--trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $
return (
push_args `appOL`
@@ -1694,7 +1702,6 @@ as a consequence. The [Name] is a list of the constructors of this
The code we generate is this:
push arg
- push bogus-word
TESTEQ_I 0 L1
PUSH_G <lbl for first data con>
@@ -1712,13 +1719,6 @@ The code we generate is this:
L_exit: SLIDE 1 n
ENTER
-
-The 'bogus-word' push is because TESTEQ_I expects the top of the stack
-to have an info-table, and the next word to have the value to be
-tested. This is very weird, but it's the way it is right now. See
-Interpreter.c. We don't actually need an info-table here; we just
-need to have the argument to be one-from-top on the stack, hence pushing
-a 1-word null. See #8383.
-}
@@ -1744,14 +1744,10 @@ implement_tagToId d s p arg names
slide_ws = bytesToWords platform (d - s + arg_bytes)
return (push_arg
- `appOL` unitOL (PUSH_UBX LitNullAddr 1)
- -- Push bogus word (see Note [Implementing tagToEnum#])
`appOL` concatOL steps
`appOL` toOL [ LABEL label_fail, CASEFAIL,
LABEL label_exit ]
- `appOL` mkSlideW 1 (slide_ws + 1)
- -- "+1" to account for bogus word
- -- (see Note [Implementing tagToEnum#])
+ `appOL` mkSlideW 1 slide_ws
`appOL` unitOL ENTER)
where
mkStep l_exit (my_label, next_label, n, name_for_n)
=====================================
compiler/GHC/StgToCmm/Closure.hs
=====================================
@@ -308,8 +308,7 @@ type DynTag = Int -- The tag on a *pointer*
-- Also see Note [Tagging big families] in GHC.StgToCmm.Expr
--
-- The interpreter also needs to be updated if we change the
--- tagging strategy. See Note [Data constructor dynamic tags] in
--- rts/Interpreter.c
+-- tagging strategy; see tagConstr in rts/Interpreter.c.
isSmallFamily :: Platform -> Int -> Bool
isSmallFamily platform fam_size = fam_size <= mAX_PTR_TAG platform
=====================================
compiler/GHC/Types/Id/Make.hs
=====================================
@@ -1053,8 +1053,7 @@ dataConSrcToImplBang bang_opts fam_envs arg_ty
arg_ty' = case mb_co of
{ Just redn -> scaledSet arg_ty (reductionReducedType redn)
; Nothing -> arg_ty }
- , all (not . isNewTyCon . fst) (splitTyConApp_maybe $ scaledThing arg_ty')
- , shouldUnpackTy bang_opts unpk_prag fam_envs arg_ty'
+ , shouldUnpackArgTy bang_opts unpk_prag fam_envs arg_ty'
= if bang_opt_unbox_disable bang_opts
then HsStrict True -- Not unpacking because of -O0
-- See Note [Detecting useless UNPACK pragmas] in GHC.Core.DataCon
@@ -1329,69 +1328,95 @@ mkUbxSumAltTy :: [Type] -> Type
mkUbxSumAltTy [ty] = ty
mkUbxSumAltTy tys = mkTupleTy Unboxed tys
-shouldUnpackTy :: BangOpts -> SrcUnpackedness -> FamInstEnvs -> Scaled Type -> Bool
+shouldUnpackArgTy :: BangOpts -> SrcUnpackedness -> FamInstEnvs -> Scaled Type -> Bool
-- True if we ought to unpack the UNPACK the argument type
-- See Note [Recursive unboxing]
-- We look "deeply" inside rather than relying on the DataCons
-- we encounter on the way, because otherwise we might well
-- end up relying on ourselves!
-shouldUnpackTy bang_opts prag fam_envs ty
- | Just data_cons <- unpackable_type_datacons (scaledThing ty)
- = all (ok_con_args emptyNameSet) data_cons && should_unpack data_cons
+shouldUnpackArgTy bang_opts prag fam_envs arg_ty
+ | Just data_cons <- unpackable_type_datacons (scaledThing arg_ty)
+ , all ok_con data_cons -- Returns True only if we can't get a
+ -- loop involving these data cons
+ , should_unpack prag arg_ty data_cons -- ...hence the call to dataConArgUnpack in
+ -- should_unpack won't loop
+ -- See Wrinkle (W1b) of Note [Recursive unboxing] for this loopy stuff
+ = True
+
| otherwise
= False
where
- ok_con_args :: NameSet -> DataCon -> Bool
- ok_con_args dcs con
- | dc_name `elemNameSet` dcs
- = False
- | otherwise
- = all (ok_arg dcs')
- (dataConOrigArgTys con `zip` dataConSrcBangs con)
- -- NB: dataConSrcBangs gives the *user* request;
- -- We'd get a black hole if we used dataConImplBangs
+ ok_con :: DataCon -> Bool -- True <=> OK to unpack
+ ok_con top_con -- False <=> not safe
+ = ok_args emptyNameSet top_con
where
- dc_name = getName con
- dcs' = dcs `extendNameSet` dc_name
-
- ok_arg :: NameSet -> (Scaled Type, HsSrcBang) -> Bool
- ok_arg dcs (Scaled _ ty, bang)
- = not (attempt_unpack bang) || ok_ty dcs norm_ty
- where
- norm_ty = topNormaliseType fam_envs ty
+ top_con_name = getName top_con
- ok_ty :: NameSet -> Type -> Bool
- ok_ty dcs ty
- | Just data_cons <- unpackable_type_datacons ty
- = all (ok_con_args dcs) data_cons
- | otherwise
- = True -- NB True here, in contrast to False at top level
-
- attempt_unpack :: HsSrcBang -> Bool
- attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict)
- = bang_opt_strict_data bang_opts
- attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict)
- = True
- attempt_unpack (HsSrcBang _ NoSrcUnpack SrcStrict)
- = True -- Be conservative
- attempt_unpack (HsSrcBang _ NoSrcUnpack NoSrcStrict)
- = bang_opt_strict_data bang_opts -- Be conservative
- attempt_unpack _ = False
-
- -- Determine whether we ought to unpack a field based on user annotations if present and heuristics if not.
- should_unpack data_cons =
+ ok_args dcs con
+ = all (ok_arg dcs) $
+ (dataConOrigArgTys con `zip` dataConSrcBangs con)
+ -- NB: dataConSrcBangs gives the *user* request;
+ -- We'd get a black hole if we used dataConImplBangs
+
+ ok_arg :: NameSet -> (Scaled Type, HsSrcBang) -> Bool
+ ok_arg dcs (Scaled _ ty, HsSrcBang _ unpack_prag str_prag)
+ | strict_field str_prag
+ , Just data_cons <- unpackable_type_datacons (topNormaliseType fam_envs ty)
+ , should_unpack_conservative unpack_prag data_cons -- Wrinkle (W3)
+ = all (ok_rec_con dcs) data_cons -- of Note [Recursive unboxing]
+ | otherwise
+ = True -- NB True here, in contrast to False at top level
+
+ -- See Note [Recursive unboxing]
+ -- * Do not look at the HsImplBangs to `con`; see Wrinkle (W1a)
+ -- * For the "at the root" comments see Wrinkle (W2)
+ ok_rec_con dcs con
+ | dc_name == top_con_name = False -- Recursion at the root
+ | dc_name `elemNameSet` dcs = True -- Not at the root
+ | otherwise = ok_args (dcs `extendNameSet` dc_name) con
+ where
+ dc_name = getName con
+
+ strict_field :: SrcStrictness -> Bool
+ -- True <=> strict field
+ strict_field NoSrcStrict = bang_opt_strict_data bang_opts
+ strict_field SrcStrict = True
+ strict_field SrcLazy = False
+
+ -- Determine whether we ought to unpack a field,
+ -- based on user annotations if present.
+ -- A conservative version of should_unpack that doesn't look at how
+ -- many fields the field would unpack to... because that leads to a loop.
+ -- "Conservative" = err on the side of saying "yes".
+ should_unpack_conservative :: SrcUnpackedness -> [DataCon] -> Bool
+ should_unpack_conservative SrcNoUnpack _ = False -- {-# NOUNPACK #-}
+ should_unpack_conservative SrcUnpack _ = True -- {-# NOUNPACK #-}
+ should_unpack_conservative NoSrcUnpack dcs = not (is_sum dcs)
+ -- is_sum: we never unpack sums without a pragma; otherwise be conservative
+
+ -- Determine whether we ought to unpack a field,
+ -- based on user annotations if present, and heuristics if not.
+ should_unpack :: SrcUnpackedness -> Scaled Type -> [DataCon] -> Bool
+ should_unpack prag arg_ty data_cons =
case prag of
SrcNoUnpack -> False -- {-# NOUNPACK #-}
SrcUnpack -> True -- {-# UNPACK #-}
NoSrcUnpack -- No explicit unpack pragma, so use heuristics
- | (_:_:_) <- data_cons
- -> False -- don't unpack sum types automatically, but they can be unpacked with an explicit source UNPACK.
- | otherwise
+ | is_sum data_cons
+ -> False -- Don't unpack sum types automatically, but they can
+ -- be unpacked with an explicit source UNPACK.
+ | otherwise -- Wrinkle (W4) of Note [Recursive unboxing]
-> bang_opt_unbox_strict bang_opts
|| (bang_opt_unbox_small bang_opts
&& rep_tys `lengthAtMost` 1) -- See Note [Unpack one-wide fields]
- where (rep_tys, _) = dataConArgUnpack ty
+ where
+ (rep_tys, _) = dataConArgUnpack arg_ty
+ is_sum :: [DataCon] -> Bool
+ -- We never unpack sum types automatically
+ -- (Product types, we do. Empty types are weeded out by unpackable_type_datacons.)
+ is_sum (_:_:_) = True
+ is_sum _ = False
-- Given a type already assumed to have been normalized by topNormaliseType,
-- unpackable_type_datacons ty = Just datacons
@@ -1403,11 +1428,11 @@ shouldUnpackTy bang_opts prag fam_envs ty
unpackable_type_datacons :: Type -> Maybe [DataCon]
unpackable_type_datacons ty
| Just (tc, _) <- splitTyConApp_maybe ty
- , not (isNewTyCon tc)
- -- Even though `ty` has been normalised, it could still
- -- be a /recursive/ newtype, so we must check for that
+ , not (isNewTyCon tc) -- Even though `ty` has been normalised, it could still
+ -- be a /recursive/ newtype, so we must check for that
, Just cons <- tyConDataCons_maybe tc
- , not (null cons)
+ , not (null cons) -- Don't upack nullary sums; no need.
+ -- They already take zero bits
, all (null . dataConExTyCoVars) cons
= Just cons -- See Note [Unpacking GADTs and existentials]
| otherwise
@@ -1463,21 +1488,75 @@ But be careful not to try to unbox this!
data T = MkT {-# UNPACK #-} !T Int
Because then we'd get an infinite number of arguments.
-Here is a more complicated case:
- data S = MkS {-# UNPACK #-} !T Int
- data T = MkT {-# UNPACK #-} !S Int
-Each of S and T must decide independently whether to unpack
-and they had better not both say yes. So they must both say no.
-
-Also behave conservatively when there is no UNPACK pragma
- data T = MkS !T Int
-with -funbox-strict-fields or -funbox-small-strict-fields
-we need to behave as if there was an UNPACK pragma there.
-
-But it's the *argument* type that matters. This is fine:
+Note that it's the *argument* type that matters. This is fine:
data S = MkS S !Int
because Int is non-recursive.
+Wrinkles:
+
+(W1a) We have to be careful that the compiler doesn't go into a loop!
+ First, we must not look at the HsImplBang decisions of data constructors
+ in the same mutually recursive group. E.g.
+ data S = MkS {-# UNPACK #-} !T Int
+ data T = MkT {-# UNPACK #-} !S Int
+ Each of S and T must decide /independently/ whether to unpack
+ and they had better not both say yes. So they must both say no.
+ (We could detect when we leave the group, and /then/ we can rely on
+ HsImplBangs; but that requires more plumbing.)
+
+(W1b) Here is another way the compiler might go into a loop (test T23307b):
+ data data T = MkT !S Int
+ data S = MkS !T
+ Suppose we call `shouldUnpackArgTy` on the !S arg of `T`. In `should_unpack`
+ we ask if the number of fields that `MkS` unpacks to is small enough
+ (via rep_tys `lengthAtMost` 1). But how many field /does/ `MkS` unpack
+ to? Well it depends on the unpacking decision we make for `MkS`, which
+ in turn depends on `MkT`, which we are busy deciding. Black holes beckon.
+
+ So we /first/ call `ok_con` on `MkS` (and `ok_con` is conservative;
+ see `should_unpack_conservative`), and only /then/ call `should_unpack`.
+ Tricky!
+
+(W2) As #23307 shows, we /do/ want to unpack the second arg of the Yes
+ data constructor in this example, despite the recursion in List:
+ data Stream a = Cons a !(Stream a)
+ data Unconsed a = Unconsed a !(Stream a)
+ data MUnconsed a = No | Yes {-# UNPACK #-} !(Unconsed a)
+ When looking at
+ {-# UNPACK #-} (Unconsed a)
+ we can take Unconsed apart, but then get into a loop with Stream.
+ That's fine: we can still take Unconsed apart. It's only if we
+ have a loop /at the root/ that we must not unpack.
+
+(W3) Moreover (W2) can apply even if there is a recursive loop:
+ data List a = Nil | Cons {-# UNPACK #-} !(Unconsed a)
+ data Unconsed a = Unconsed a !(List a)
+ Here there is mutual recursion between `Unconsed` and `List`; and yet
+ we can unpack the field of `Cons` because we will not unpack the second
+ field of `Unconsed`: we never unpack a sum type without an explicit
+ pragma (see should_unpack).
+
+(W4) Consider
+ data T = MkT !Wombat
+ data Wombat = MkW {-# UNPACK #-} !S Int
+ data S = MkS {-# NOUNPACK #-} !Wombat Int
+ Suppose we are deciding whether to unpack the first field of MkT, by
+ calling (shouldUnpackArgTy Wombat). Then we'll try to unpack the !S field
+ of MkW, and be stopped by the {-# NOUNPACK #-}, and all is fine; we can
+ unpack MkT.
+
+ If that NOUNPACK had been a UNPACK, though, we'd get a loop, and would
+ decide not to unpack the Wombat field of MkT.
+
+ But what if there was no pragma in `data S`? Then we /still/ decide not
+ to unpack the Wombat field of MkT (at least when auto-unpacking is on),
+ because we don't know for sure which decision will be taken for the
+ Wombat field of MkS.
+
+ TL;DR when there is no pragma, behave as if there was a UNPACK, at least
+ when auto-unpacking is on. See `should_unpack` in `shouldUnpackArgTy`.
+
+
************************************************************************
* *
Wrapping and unwrapping newtypes and type families
=====================================
libraries/base/Data/Functor/Compose.hs
=====================================
@@ -156,3 +156,14 @@ instance (TestEquality f) => TestEquality (Compose f g) where
case testEquality x y of -- :: Maybe (g x :~: g y)
Just Refl -> Just Refl -- :: Maybe (x :~: y)
Nothing -> Nothing
+
+-- | @since 4.19.0.0
+deriving instance Enum (f (g a)) => Enum (Compose f g a)
+-- | @since 4.19.0.0
+deriving instance Bounded (f (g a)) => Bounded (Compose f g a)
+-- | @since 4.19.0.0
+deriving instance Num (f (g a)) => Num (Compose f g a)
+-- | @since 4.19.0.0
+deriving instance Real (f (g a)) => Real (Compose f g a)
+-- | @since 4.19.0.0
+deriving instance Integral (f (g a)) => Integral (Compose f g a)
=====================================
libraries/base/changelog.md
=====================================
@@ -25,6 +25,7 @@
adding the class `Unsatisfiable :: ErrorMessage -> TypeError` to `GHC.TypeError`,
which provides a mechanism for custom type errors that reports the errors in
a more predictable behaviour than `TypeError`.
+ * Add more instances for `Compose`: `Enum`, `Bounded`, `Num`, `Real`, `Integral` ([CLC proposal #160](https://github.com/haskell/core-libraries-committee/issues/160))
* Make `(&)` representation polymorphic in the return type ([CLC proposal #158](https://github.com/haskell/core-libraries-committee/issues/158))
* Implement `GHC.IORef.atomicSwapIORef` via a new dedicated primop `atomicSwapMutVar#` ([CLC proposal #139](https://github.com/haskell/core-libraries-committee/issues/139))
=====================================
rts/Disassembler.c
=====================================
@@ -123,10 +123,6 @@ disInstr ( StgBCO *bco, int pc )
debugBelch("PUSH_G " ); printPtr( ptrs[instrs[pc]] );
debugBelch("\n" );
pc += 1; break;
- case bci_PUSH_ALTS:
- debugBelch("PUSH_ALTS " ); printPtr( ptrs[instrs[pc]] );
- debugBelch("\n");
- pc += 1; break;
case bci_PUSH_ALTS_P:
debugBelch("PUSH_ALTS_P " ); printPtr( ptrs[instrs[pc]] );
debugBelch("\n");
@@ -408,9 +404,6 @@ disInstr ( StgBCO *bco, int pc )
debugBelch("ENTER\n");
break;
- case bci_RETURN:
- debugBelch("RETURN\n" );
- break;
case bci_RETURN_P:
debugBelch("RETURN_P\n" );
break;
=====================================
rts/Interpreter.c
=====================================
@@ -283,6 +283,14 @@ StgClosure * copyPAP (Capability *cap, StgPAP *oldpap)
#endif
+// Compute the pointer tag for the constructor and tag the pointer;
+// see Note [Data constructor dynamic tags] in GHC.StgToCmm.Closure.
+//
+// Note: we need to update this if we change the tagging strategy.
+STATIC_INLINE StgClosure *tagConstr(StgClosure *con) {
+ return TAG_CLOSURE(stg_min(TAG_MASK, 1 + GET_TAG(con)), con);
+}
+
static StgWord app_ptrs_itbl[] = {
(W_)&stg_ap_p_info,
(W_)&stg_ap_pp_info,
@@ -363,11 +371,22 @@ interpretBCO (Capability* cap)
// ------------------------------------------------------------------------
// Case 3:
//
- // We have an unlifted value to return. See comment before
- // do_return_lifted, below.
+ // We have a pointer to return. See comment before
+ // do_return_pointer, below.
+ //
+ else if (SpW(0) == (W_)&stg_ret_p_info) {
+ tagged_obj = (StgClosure *)SpW(1);
+ Sp_addW(2);
+ goto do_return_pointer;
+ }
+
+ // ------------------------------------------------------------------------
+ // Case 4:
+ //
+ // We have a nonpointer to return.
//
else {
- goto do_return_unlifted;
+ goto do_return_nonpointer;
}
// Evaluate the object on top of the stack.
@@ -412,6 +431,11 @@ eval_obj:
case CONSTR_1_1:
case CONSTR_0_2:
case CONSTR_NOCAF:
+ // The value is already evaluated, so we can just return it. However,
+ // before we do, we MUST ensure that the pointer is tagged, because we
+ // might return to a native `case` expression, which assumes the returned
+ // pointer is tagged so it can use the tag to select an alternative.
+ tagged_obj = tagConstr(obj);
break;
case FUN:
@@ -533,16 +557,16 @@ eval_obj:
}
// ------------------------------------------------------------------------
- // We now have an evaluated object (tagged_obj). The next thing to
+ // We now have a pointer to return (tagged_obj). The next thing to
// do is return it to the stack frame on top of the stack.
-do_return:
+do_return_pointer:
obj = UNTAG_CLOSURE(tagged_obj);
- ASSERT(closure_HNF(obj));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(obj));
IF_DEBUG(interpreter,
debugBelch(
"\n---------------------------------------------------------------\n");
- debugBelch("Returning: "); printObj(obj);
+ debugBelch("Returning closure: "); printObj(obj);
debugBelch("Sp = %p\n", Sp);
#if defined(PROFILING)
fprintCCS(stderr, cap->r.rCCCS);
@@ -567,7 +591,7 @@ do_return:
info == (StgInfoTable *)&stg_restore_cccs_eval_info) {
cap->r.rCCCS = (CostCentreStack*)SpW(1);
Sp_addW(2);
- goto do_return;
+ goto do_return_pointer;
}
if (info == (StgInfoTable *)&stg_ap_v_info) {
@@ -621,7 +645,7 @@ do_return:
updateThunk(cap, cap->r.rCurrentTSO,
((StgUpdateFrame *)Sp)->updatee, tagged_obj);
Sp_addW(sizeofW(StgUpdateFrame));
- goto do_return;
+ goto do_return_pointer;
case RET_BCO:
// Returning to an interpreted continuation: put the object on
@@ -631,7 +655,7 @@ do_return:
SpW(0) = (W_)tagged_obj;
obj = (StgClosure*)SpW(2);
ASSERT(get_itbl(obj)->type == BCO);
- goto run_BCO_return;
+ goto run_BCO_return_pointer;
default:
do_return_unrecognised:
@@ -644,7 +668,7 @@ do_return:
);
Sp_subW(2);
SpW(1) = (W_)tagged_obj;
- SpW(0) = (W_)&stg_enter_info;
+ SpW(0) = (W_)&stg_ret_p_info;
RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
}
}
@@ -672,12 +696,11 @@ do_return:
// We're only interested in the case when the real return address
// is a BCO; otherwise we'll return to the scheduler.
-do_return_unlifted:
+do_return_nonpointer:
{
int offset;
ASSERT( SpW(0) == (W_)&stg_ret_v_info
- || SpW(0) == (W_)&stg_ret_p_info
|| SpW(0) == (W_)&stg_ret_n_info
|| SpW(0) == (W_)&stg_ret_f_info
|| SpW(0) == (W_)&stg_ret_d_info
@@ -688,7 +711,7 @@ do_return_unlifted:
IF_DEBUG(interpreter,
debugBelch(
"\n---------------------------------------------------------------\n");
- debugBelch("Returning unlifted\n");
+ debugBelch("Returning nonpointer\n");
debugBelch("Sp = %p\n", Sp);
#if defined(PROFILING)
fprintCCS(stderr, cap->r.rCCCS);
@@ -705,12 +728,13 @@ do_return_unlifted:
switch (get_itbl((StgClosure*)(Sp_plusW(offset)))->type) {
case RET_BCO:
- // Returning to an interpreted continuation: put the object on
- // the stack, and start executing the BCO.
+ // Returning to an interpreted continuation: pop the return frame
+ // so the returned value is at the top of the stack, and start
+ // executing the BCO.
INTERP_TICK(it_retto_BCO);
obj = (StgClosure*)SpW(offset+1);
ASSERT(get_itbl(obj)->type == BCO);
- goto run_BCO_return_unlifted;
+ goto run_BCO_return_nonpointer;
default:
{
@@ -815,7 +839,7 @@ do_apply:
SET_HDR(new_pap,&stg_PAP_info,cap->r.rCCCS);
tagged_obj = (StgClosure *)new_pap;
Sp_addW(m);
- goto do_return;
+ goto do_return_pointer;
}
}
@@ -858,7 +882,7 @@ do_apply:
SET_HDR(pap, &stg_PAP_info,cap->r.rCCCS);
tagged_obj = (StgClosure *)pap;
Sp_addW(m);
- goto do_return;
+ goto do_return_pointer;
}
}
@@ -917,10 +941,10 @@ do_apply:
// to do:
-run_BCO_return:
+run_BCO_return_pointer:
// Heap check
if (doYouWantToGC(cap)) {
- Sp_subW(1); SpW(0) = (W_)&stg_enter_info;
+ Sp_subW(1); SpW(0) = (W_)&stg_ret_p_info;
RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
}
// Stack checks aren't necessary at return points, the stack use
@@ -928,7 +952,7 @@ run_BCO_return:
goto run_BCO;
-run_BCO_return_unlifted:
+run_BCO_return_nonpointer:
// Heap check
if (doYouWantToGC(cap)) {
RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
@@ -973,6 +997,9 @@ run_BCO_return_unlifted:
}
#endif
+ if (SpW(0) != (W_)&stg_ret_t_info) {
+ Sp_addW(1);
+ }
goto run_BCO;
run_BCO_fun:
@@ -1274,7 +1301,7 @@ run_BCO:
goto nextInsn;
}
- case bci_PUSH_ALTS: {
+ case bci_PUSH_ALTS_P: {
int o_bco = BCO_GET_LARGE_ARG;
Sp_subW(2);
SpW(1) = BCO_PTR(o_bco);
@@ -1287,19 +1314,6 @@ run_BCO:
goto nextInsn;
}
- case bci_PUSH_ALTS_P: {
- int o_bco = BCO_GET_LARGE_ARG;
- SpW(-2) = (W_)&stg_ctoi_R1unpt_info;
- SpW(-1) = BCO_PTR(o_bco);
- Sp_subW(2);
-#if defined(PROFILING)
- Sp_subW(2);
- SpW(1) = (W_)cap->r.rCCCS;
- SpW(0) = (W_)&stg_restore_cccs_info;
-#endif
- goto nextInsn;
- }
-
case bci_PUSH_ALTS_N: {
int o_bco = BCO_GET_LARGE_ARG;
SpW(-2) = (W_)&stg_ctoi_R1n_info;
@@ -1678,19 +1692,7 @@ run_BCO:
StgInfoTable *con_itbl = (StgInfoTable*) BCO_LIT(o_itbl);
SET_HDR(con, con_itbl, cap->r.rCCCS);
- // Note [Data constructor dynamic tags]
- // ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- // compute the pointer tag for the constructor and tag the pointer
- //
- // - 1..(TAG_MASK-1): for first TAG_MASK-1 constructors
- // - TAG_MASK: look in info table
- //
- // Note: we need to update this if we change the tagging strategy
- //
- // For full details of the invariants on tagging, see
- // https://gitlab.haskell.org/ghc/ghc/wikis/commentary/rts/haskell-execution/pointer-tagging
-
- StgClosure* tagged_con = TAG_CLOSURE(stg_min(TAG_MASK, 1 + GET_TAG(con)), con);
+ StgClosure* tagged_con = tagConstr(con);
SpW(0) = (W_)tagged_con;
IF_DEBUG(interpreter,
@@ -1721,60 +1723,54 @@ run_BCO:
}
case bci_TESTLT_I: {
- // There should be an Int at SpW(1), and an info table at SpW(0).
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- I_ stackInt = (I_)SpW(1);
+ I_ stackInt = (I_)SpW(0);
if (stackInt >= (I_)BCO_LIT(discr))
bciPtr = failto;
goto nextInsn;
}
case bci_TESTLT_I64: {
- // There should be an Int64 at SpW(1), and an info table at SpW(0).
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- StgInt64 stackInt = (*(StgInt64*)Sp_plusW(1));
+ StgInt64 stackInt = (*(StgInt64*)Sp);
if (stackInt >= BCO_LITI64(discr))
bciPtr = failto;
goto nextInsn;
}
case bci_TESTLT_I32: {
- // There should be an Int32 at SpW(1), and an info table at SpW(0).
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- StgInt32 stackInt = (*(StgInt32*)Sp_plusW(1));
+ StgInt32 stackInt = (*(StgInt32*)Sp);
if (stackInt >= (StgInt32)BCO_LIT(discr))
bciPtr = failto;
goto nextInsn;
}
case bci_TESTLT_I16: {
- // There should be an Int16 at SpW(1), and an info table at SpW(0).
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- StgInt16 stackInt = (*(StgInt16*)Sp_plusW(1));
+ StgInt16 stackInt = (*(StgInt16*)Sp);
if (stackInt >= (StgInt16)BCO_LIT(discr))
bciPtr = failto;
goto nextInsn;
}
case bci_TESTLT_I8: {
- // There should be an Int8 at SpW(1), and an info table at SpW(0).
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- StgInt8 stackInt = (*(StgInt8*)Sp_plusW(1));
+ StgInt8 stackInt = (*(StgInt8*)Sp);
if (stackInt >= (StgInt8)BCO_LIT(discr))
bciPtr = failto;
goto nextInsn;
}
case bci_TESTEQ_I: {
- // There should be an Int at SpW(1), and an info table at SpW(0).
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- I_ stackInt = (I_)SpW(1);
+ I_ stackInt = (I_)SpW(0);
if (stackInt != (I_)BCO_LIT(discr)) {
bciPtr = failto;
}
@@ -1782,10 +1778,9 @@ run_BCO:
}
case bci_TESTEQ_I64: {
- // There should be an Int64 at SpW(1), and an info table at SpW(0).
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- StgInt64 stackInt = (*(StgInt64*)Sp_plusW(1));
+ StgInt64 stackInt = (*(StgInt64*)Sp);
if (stackInt != BCO_LITI64(discr)) {
bciPtr = failto;
}
@@ -1793,10 +1788,9 @@ run_BCO:
}
case bci_TESTEQ_I32: {
- // There should be an Int32 at SpW(1), and an info table at SpW(0).
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- StgInt32 stackInt = (*(StgInt32*)Sp_plusW(1));
+ StgInt32 stackInt = (*(StgInt32*)Sp);
if (stackInt != (StgInt32)BCO_LIT(discr)) {
bciPtr = failto;
}
@@ -1804,10 +1798,9 @@ run_BCO:
}
case bci_TESTEQ_I16: {
- // There should be an Int16 at SpW(1), and an info table at SpW(0).
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- StgInt16 stackInt = (*(StgInt16*)Sp_plusW(1));
+ StgInt16 stackInt = (*(StgInt16*)Sp);
if (stackInt != (StgInt16)BCO_LIT(discr)) {
bciPtr = failto;
}
@@ -1815,10 +1808,9 @@ run_BCO:
}
case bci_TESTEQ_I8: {
- // There should be an Int8 at SpW(1), and an info table at SpW(0).
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- StgInt8 stackInt = (*(StgInt8*)Sp_plusW(1));
+ StgInt8 stackInt = (*(StgInt8*)Sp);
if (stackInt != (StgInt8)BCO_LIT(discr)) {
bciPtr = failto;
}
@@ -1826,60 +1818,54 @@ run_BCO:
}
case bci_TESTLT_W: {
- // There should be a Word at SpW(1), and an info table at SpW(0).
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- W_ stackWord = (W_)SpW(1);
+ W_ stackWord = (W_)SpW(0);
if (stackWord >= (W_)BCO_LIT(discr))
bciPtr = failto;
goto nextInsn;
}
case bci_TESTLT_W64: {
- // There should be a Word64 at SpW(1), and an info table at SpW(0).
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- StgWord64 stackWord = (*(StgWord64*)Sp_plusW(1));
+ StgWord64 stackWord = (*(StgWord64*)Sp);
if (stackWord >= BCO_LITW64(discr))
bciPtr = failto;
goto nextInsn;
}
case bci_TESTLT_W32: {
- // There should be a Word32 at SpW(1), and an info table at SpW(0).
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- StgWord32 stackWord = (*(StgWord32*)Sp_plusW(1));
+ StgWord32 stackWord = (*(StgWord32*)Sp);
if (stackWord >= (StgWord32)BCO_LIT(discr))
bciPtr = failto;
goto nextInsn;
}
case bci_TESTLT_W16: {
- // There should be a Word16 at SpW(1), and an info table at SpW(0).
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- StgWord16 stackWord = (*(StgWord16*)Sp_plusW(1));
+ StgWord16 stackWord = (*(StgWord16*)Sp);
if (stackWord >= (StgWord16)BCO_LIT(discr))
bciPtr = failto;
goto nextInsn;
}
case bci_TESTLT_W8: {
- // There should be a Word8 at SpW(1), and an info table at SpW(0).
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- StgWord8 stackWord = (*(StgWord8*)Sp_plusW(1));
+ StgWord8 stackWord = (*(StgWord8*)Sp);
if (stackWord >= (StgWord8)BCO_LIT(discr))
bciPtr = failto;
goto nextInsn;
}
case bci_TESTEQ_W: {
- // There should be a Word at SpW(1), and an info table at SpW(0).
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- W_ stackWord = (W_)SpW(1);
+ W_ stackWord = (W_)SpW(0);
if (stackWord != (W_)BCO_LIT(discr)) {
bciPtr = failto;
}
@@ -1887,10 +1873,9 @@ run_BCO:
}
case bci_TESTEQ_W64: {
- // There should be a Word64 at SpW(1), and an info table at SpW(0).
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- StgWord64 stackWord = (*(StgWord64*)Sp_plusW(1));
+ StgWord64 stackWord = (*(StgWord64*)Sp);
if (stackWord != BCO_LITW64(discr)) {
bciPtr = failto;
}
@@ -1898,10 +1883,9 @@ run_BCO:
}
case bci_TESTEQ_W32: {
- // There should be a Word32 at SpW(1), and an info table at SpW(0).
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- StgWord32 stackWord = (*(StgWord32*)Sp_plusW(1));
+ StgWord32 stackWord = (*(StgWord32*)Sp);
if (stackWord != (StgWord32)BCO_LIT(discr)) {
bciPtr = failto;
}
@@ -1909,10 +1893,9 @@ run_BCO:
}
case bci_TESTEQ_W16: {
- // There should be a Word16 at SpW(1), and an info table at SpW(0).
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- StgWord16 stackWord = (*(StgWord16*)Sp_plusW(1));
+ StgWord16 stackWord = (*(StgWord16*)Sp);
if (stackWord != (StgWord16)BCO_LIT(discr)) {
bciPtr = failto;
}
@@ -1920,10 +1903,9 @@ run_BCO:
}
case bci_TESTEQ_W8: {
- // There should be a Word8 at SpW(1), and an info table at SpW(0).
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- StgWord8 stackWord = (*(StgWord8*)Sp_plusW(1));
+ StgWord8 stackWord = (*(StgWord8*)Sp);
if (stackWord != (StgWord8)BCO_LIT(discr)) {
bciPtr = failto;
}
@@ -1931,11 +1913,10 @@ run_BCO:
}
case bci_TESTLT_D: {
- // There should be a Double at SpW(1), and an info table at SpW(0).
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgDouble stackDbl, discrDbl;
- stackDbl = PK_DBL( & SpW(1) );
+ stackDbl = PK_DBL( & SpW(0) );
discrDbl = PK_DBL( & BCO_LIT(discr) );
if (stackDbl >= discrDbl) {
bciPtr = failto;
@@ -1944,11 +1925,10 @@ run_BCO:
}
case bci_TESTEQ_D: {
- // There should be a Double at SpW(1), and an info table at SpW(0).
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgDouble stackDbl, discrDbl;
- stackDbl = PK_DBL( & SpW(1) );
+ stackDbl = PK_DBL( & SpW(0) );
discrDbl = PK_DBL( & BCO_LIT(discr) );
if (stackDbl != discrDbl) {
bciPtr = failto;
@@ -1957,11 +1937,10 @@ run_BCO:
}
case bci_TESTLT_F: {
- // There should be a Float at SpW(1), and an info table at SpW(0).
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgFloat stackFlt, discrFlt;
- stackFlt = PK_FLT( & SpW(1) );
+ stackFlt = PK_FLT( & SpW(0) );
discrFlt = PK_FLT( & BCO_LIT(discr) );
if (stackFlt >= discrFlt) {
bciPtr = failto;
@@ -1970,11 +1949,10 @@ run_BCO:
}
case bci_TESTEQ_F: {
- // There should be a Float at SpW(1), and an info table at SpW(0).
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgFloat stackFlt, discrFlt;
- stackFlt = PK_FLT( & SpW(1) );
+ stackFlt = PK_FLT( & SpW(0) );
discrFlt = PK_FLT( & BCO_LIT(discr) );
if (stackFlt != discrFlt) {
bciPtr = failto;
@@ -1995,40 +1973,36 @@ run_BCO:
}
goto eval;
- case bci_RETURN:
+ case bci_RETURN_P:
tagged_obj = (StgClosure *)SpW(0);
Sp_addW(1);
- goto do_return;
+ goto do_return_pointer;
- case bci_RETURN_P:
- Sp_subW(1);
- SpW(0) = (W_)&stg_ret_p_info;
- goto do_return_unlifted;
case bci_RETURN_N:
Sp_subW(1);
SpW(0) = (W_)&stg_ret_n_info;
- goto do_return_unlifted;
+ goto do_return_nonpointer;
case bci_RETURN_F:
Sp_subW(1);
SpW(0) = (W_)&stg_ret_f_info;
- goto do_return_unlifted;
+ goto do_return_nonpointer;
case bci_RETURN_D:
Sp_subW(1);
SpW(0) = (W_)&stg_ret_d_info;
- goto do_return_unlifted;
+ goto do_return_nonpointer;
case bci_RETURN_L:
Sp_subW(1);
SpW(0) = (W_)&stg_ret_l_info;
- goto do_return_unlifted;
+ goto do_return_nonpointer;
case bci_RETURN_V:
Sp_subW(1);
SpW(0) = (W_)&stg_ret_v_info;
- goto do_return_unlifted;
+ goto do_return_nonpointer;
case bci_RETURN_T: {
/* tuple_info and tuple_bco must already be on the stack */
Sp_subW(1);
SpW(0) = (W_)&stg_ret_t_info;
- goto do_return_unlifted;
+ goto do_return_nonpointer;
}
case bci_SWIZZLE: {
=====================================
rts/Printer.c
=====================================
@@ -652,8 +652,6 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
if (c == (StgWord)&stg_ctoi_R1p_info) {
debugBelch("stg_ctoi_R1p_info" );
- } else if (c == (StgWord)&stg_ctoi_R1unpt_info) {
- debugBelch("stg_ctoi_R1unpt_info" );
} else if (c == (StgWord)&stg_ctoi_R1n_info) {
debugBelch("stg_ctoi_R1n_info" );
} else if (c == (StgWord)&stg_ctoi_F1_info) {
=====================================
rts/StgMiscClosures.cmm
=====================================
@@ -147,18 +147,6 @@ stg_interp_constr7_entry (P_ ret) { return (ret + 7); }
INFO_TABLE_RET( stg_ctoi_R1p, RET_BCO)
/* explicit stack */
-{
- Sp_adj(-2);
- Sp(1) = R1;
- Sp(0) = stg_enter_info;
- jump stg_yield_to_interpreter [];
-}
-
-/*
- * When the returned value is a pointer, but unlifted, in R1 ...
- */
-INFO_TABLE_RET( stg_ctoi_R1unpt, RET_BCO )
- /* explicit stack */
{
Sp_adj(-2);
Sp(1) = R1;
=====================================
rts/include/rts/Bytecodes.h
=====================================
@@ -34,7 +34,6 @@
#define bci_PUSH16_W 9
#define bci_PUSH32_W 10
#define bci_PUSH_G 11
-#define bci_PUSH_ALTS 12
#define bci_PUSH_ALTS_P 13
#define bci_PUSH_ALTS_N 14
#define bci_PUSH_ALTS_F 15
@@ -81,7 +80,6 @@
#define bci_CCALL 56
#define bci_SWIZZLE 57
#define bci_ENTER 58
-#define bci_RETURN 59
#define bci_RETURN_P 60
#define bci_RETURN_N 61
#define bci_RETURN_F 62
=====================================
rts/include/stg/MiscClosures.h
=====================================
@@ -82,7 +82,6 @@ RTS_RET(stg_prompt_frame);
/* Magic glue code for when compiled code returns a value in R1/F1/D1
or a VoidRep to the interpreter. */
RTS_RET(stg_ctoi_R1p);
-RTS_RET(stg_ctoi_R1unpt);
RTS_RET(stg_ctoi_R1n);
RTS_RET(stg_ctoi_F1);
RTS_RET(stg_ctoi_D1);
=====================================
testsuite/tests/ghci/should_run/T22958a.hs
=====================================
@@ -0,0 +1,15 @@
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+import GHC.Exts
+import GHC.IO
+
+unit :: ()
+unit = ()
+
+i :: State# RealWorld -> (# State# RealWorld, () #)
+i s = case seq# unit s of (# s', a #) -> (# s', a #)
+
+bad :: IO ()
+bad = IO i
+
+main :: IO ()
+main = bad >>= print
=====================================
testsuite/tests/ghci/should_run/T22958a.stdout
=====================================
@@ -0,0 +1 @@
+()
=====================================
testsuite/tests/ghci/should_run/T22958b.hs
=====================================
@@ -0,0 +1,25 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnliftedDatatypes #-}
+import GHC.Exts
+
+type D1 :: TYPE (BoxedRep Unlifted)
+data D1 = MkD1 !Int
+
+showD1 :: D1 -> String
+showD1 (MkD1 i) = "MkD1 " ++ show i
+
+type D2 :: TYPE (BoxedRep Lifted)
+data D2 = MkD2 !Int deriving stock Show
+
+risky :: forall {r} (a :: TYPE (BoxedRep Unlifted)) (b :: TYPE r). a -> b
+risky = unsafeCoerce#
+{-# NOINLINE risky #-}
+
+main :: IO ()
+main = do
+ putStrLn (showD1 (unsafeCoerce# (MkD1 11))) -- foo11
+ print (unsafeCoerce# (MkD1 12) :: D2) -- foo12
+ putStrLn (showD1 (risky (MkD1 11))) -- bar11
+ print (risky (MkD1 12) :: D2) -- bar12
=====================================
testsuite/tests/ghci/should_run/T22958b.stdout
=====================================
@@ -0,0 +1,4 @@
+MkD1 11
+MkD2 12
+MkD1 11
+MkD2 12
=====================================
testsuite/tests/ghci/should_run/all.T
=====================================
@@ -88,3 +88,5 @@ test('UnliftedDataType2', just_ghci, compile_and_run, [''])
test('T22829', just_ghci + [extra_hc_opts("-Wmissing-import-lists -Werror")], compile_and_run, [''])
test('T23229', just_ghci + [extra_hc_opts("-this-unit-id my-package -Wno-missing-methods T23229")], ghci_script, ['T23229.script'])
+test('T22958a', just_ghci, compile_and_run, [''])
+test('T22958b', just_ghci, compile_and_run, [''])
=====================================
testsuite/tests/simplCore/should_compile/T23307.hs
=====================================
@@ -0,0 +1,5 @@
+module T23307 where
+
+data Stream a = Nil | Cons a !(Stream a)
+data Unconsed a = Unconsed a !(Stream a)
+data MUnconsed a = No | Yes {-# UNPACK #-} !(Unconsed a)
=====================================
testsuite/tests/simplCore/should_compile/T23307.stderr
=====================================
@@ -0,0 +1,72 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+ = {terms: 29, types: 40, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 8, types: 9, coercions: 0, joins: 0/0}
+T23307.$WYes [InlPrag=INLINE[final] CONLIKE]
+ :: forall a. Unconsed a %1 -> MUnconsed a
+[GblId[DataConWrapper],
+ Arity=1,
+ Str=<SL>,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
+ Tmpl= \ (@a) (conrep [Occ=Once1!] :: Unconsed a) ->
+ case conrep of { Unconsed unbx [Occ=Once1] unbx1 [Occ=Once1] ->
+ T23307.Yes @a unbx unbx1
+ }}]
+T23307.$WYes
+ = \ (@a) (conrep [Occ=Once1!] :: Unconsed a) ->
+ case conrep of { Unconsed unbx [Occ=Once1] unbx1 [Occ=Once1] ->
+ T23307.Yes @a unbx unbx1
+ }
+
+-- RHS size: {terms: 9, types: 7, coercions: 0, joins: 0/0}
+T23307.$WUnconsed [InlPrag=INLINE[final] CONLIKE]
+ :: forall a. a %1 -> Stream a %1 -> Unconsed a
+[GblId[DataConWrapper],
+ Arity=2,
+ Str=<L><SL>,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
+ Tmpl= \ (@a)
+ (conrep [Occ=Once1] :: a)
+ (conrep1 [Occ=Once1] :: Stream a) ->
+ case conrep1 of conrep2 [Occ=Once1] { __DEFAULT ->
+ T23307.Unconsed @a conrep conrep2
+ }}]
+T23307.$WUnconsed
+ = \ (@a)
+ (conrep [Occ=Once1] :: a)
+ (conrep1 [Occ=Once1] :: Stream a) ->
+ case conrep1 of conrep2 [Occ=Once1] { __DEFAULT ->
+ T23307.Unconsed @a conrep conrep2
+ }
+
+-- RHS size: {terms: 9, types: 7, coercions: 0, joins: 0/0}
+T23307.$WCons [InlPrag=INLINE[final] CONLIKE]
+ :: forall a. a %1 -> Stream a %1 -> Stream a
+[GblId[DataConWrapper],
+ Arity=2,
+ Str=<L><SL>,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
+ Tmpl= \ (@a)
+ (conrep [Occ=Once1] :: a)
+ (conrep1 [Occ=Once1] :: Stream a) ->
+ case conrep1 of conrep2 [Occ=Once1] { __DEFAULT ->
+ T23307.Cons @a conrep conrep2
+ }}]
+T23307.$WCons
+ = \ (@a)
+ (conrep [Occ=Once1] :: a)
+ (conrep1 [Occ=Once1] :: Stream a) ->
+ case conrep1 of conrep2 [Occ=Once1] { __DEFAULT ->
+ T23307.Cons @a conrep conrep2
+ }
+
+
+
=====================================
testsuite/tests/simplCore/should_compile/T23307a.hs
=====================================
@@ -0,0 +1,7 @@
+module T23307a where
+
+data List a = Nil | Cons {-# UNPACK #-} !(Unconsed a)
+ -- This UNPACK should work
+
+data Unconsed a = Unconsed a !(List a)
+data MUnconsed a = No | Yes {-# UNPACK #-} !(Unconsed a)
\ No newline at end of file
=====================================
testsuite/tests/simplCore/should_compile/T23307a.stderr
=====================================
@@ -0,0 +1,68 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+ = {terms: 28, types: 41, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 8, types: 9, coercions: 0, joins: 0/0}
+T23307a.$WYes [InlPrag=INLINE[final] CONLIKE]
+ :: forall a. Unconsed a %1 -> MUnconsed a
+[GblId[DataConWrapper],
+ Arity=1,
+ Str=<SL>,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
+ Tmpl= \ (@a) (conrep [Occ=Once1!] :: Unconsed a) ->
+ case conrep of { Unconsed unbx [Occ=Once1] unbx1 [Occ=Once1] ->
+ T23307a.Yes @a unbx unbx1
+ }}]
+T23307a.$WYes
+ = \ (@a) (conrep [Occ=Once1!] :: Unconsed a) ->
+ case conrep of { Unconsed unbx [Occ=Once1] unbx1 [Occ=Once1] ->
+ T23307a.Yes @a unbx unbx1
+ }
+
+-- RHS size: {terms: 9, types: 7, coercions: 0, joins: 0/0}
+T23307a.$WUnconsed [InlPrag=INLINE[final] CONLIKE]
+ :: forall a. a %1 -> List a %1 -> Unconsed a
+[GblId[DataConWrapper],
+ Arity=2,
+ Str=<L><SL>,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
+ Tmpl= \ (@a)
+ (conrep [Occ=Once1] :: a)
+ (conrep1 [Occ=Once1] :: List a) ->
+ case conrep1 of conrep2 [Occ=Once1] { __DEFAULT ->
+ T23307a.Unconsed @a conrep conrep2
+ }}]
+T23307a.$WUnconsed
+ = \ (@a)
+ (conrep [Occ=Once1] :: a)
+ (conrep1 [Occ=Once1] :: List a) ->
+ case conrep1 of conrep2 [Occ=Once1] { __DEFAULT ->
+ T23307a.Unconsed @a conrep conrep2
+ }
+
+-- RHS size: {terms: 8, types: 9, coercions: 0, joins: 0/0}
+T23307a.$WCons [InlPrag=INLINE[final] CONLIKE]
+ :: forall a. Unconsed a %1 -> List a
+[GblId[DataConWrapper],
+ Arity=1,
+ Str=<SL>,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
+ Tmpl= \ (@a) (conrep [Occ=Once1!] :: Unconsed a) ->
+ case conrep of { Unconsed unbx [Occ=Once1] unbx1 [Occ=Once1] ->
+ T23307a.Cons @a unbx unbx1
+ }}]
+T23307a.$WCons
+ = \ (@a) (conrep [Occ=Once1!] :: Unconsed a) ->
+ case conrep of { Unconsed unbx [Occ=Once1] unbx1 [Occ=Once1] ->
+ T23307a.Cons @a unbx unbx1
+ }
+
+
+
=====================================
testsuite/tests/simplCore/should_compile/T23307b.hs
=====================================
@@ -0,0 +1,7 @@
+module Foo where
+
+-- It's easy to get an infinite loop
+-- when deciding what to unbox here.
+
+data T = MkT !S Int
+data S = MkS !T
\ No newline at end of file
=====================================
testsuite/tests/simplCore/should_compile/T23307c.hs
=====================================
@@ -0,0 +1,7 @@
+module Foo where
+
+newtype Identity x = MkId x
+newtype Fix f = MkFix (f (Fix f))
+
+-- This test just checks that the compiler itself doesn't loop
+data Loop = LCon {-# UNPACK #-} !(Fix Identity)
=====================================
testsuite/tests/simplCore/should_compile/T23307c.stderr
=====================================
@@ -0,0 +1,5 @@
+
+T23307c.hs:7:13: warning: [GHC-40091]
+ • Ignoring unusable UNPACK pragma on the first argument of ‘LCon’
+ • In the definition of data constructor ‘LCon’
+ In the data type declaration for ‘Loop’
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -479,3 +479,8 @@ test('T23024', normal, multimod_compile, ['T23024', '-O -v0'])
test('T23026', normal, compile, ['-O'])
test('T23267', [expect_broken(23267), only_ways(['ghci']), extra_hc_opts('-fno-unoptimized-core-for-interpreter -fspec-constr')], ghci_script, ['T23267.script'])
test('T23362', normal, compile, ['-O'])
+test('T23307', normal, compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques'])
+test('T23307a', normal, compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques'])
+test('T23307b', normal, compile, ['-O'])
+test('T23307c', normal, compile, ['-O'])
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/639c12e0e9c565d99d210c4653a27ced2f92760a...f77a8c0295986c0e7d636741a5eeb61bb5e668df
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/639c12e0e9c565d99d210c4653a27ced2f92760a...f77a8c0295986c0e7d636741a5eeb61bb5e668df
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230513/e435ce7e/attachment-0001.html>
More information about the ghc-commits
mailing list