[Git][ghc/ghc][master] Use a uniform return convention in bytecode for unary results
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sat May 13 12:45:48 UTC 2023
Marge Bot pushed to branch master 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
- - - - -
15 changed files:
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToCmm/Closure.hs
- 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
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/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
=====================================
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, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d85ed900b271109185251cb0494d51048a4cf213
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d85ed900b271109185251cb0494d51048a4cf213
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/74c7482b/attachment-0001.html>
More information about the ghc-commits
mailing list