From d85ed900b271109185251cb0494d51048a4cf213 Mon Sep 17 00:00:00 2001 From: Alexis King Date: Fri, 12 May 2023 15:08:18 -0500 Subject: Use a uniform return convention in bytecode for unary results fixes #22958 --- compiler/GHC/ByteCode/Asm.hs | 28 ++-- compiler/GHC/ByteCode/Instr.hs | 23 ++- compiler/GHC/StgToByteCode.hs | 102 +++++++------ compiler/GHC/StgToCmm/Closure.hs | 3 +- rts/Disassembler.c | 7 - rts/Interpreter.c | 192 +++++++++++-------------- rts/Printer.c | 2 - rts/StgMiscClosures.cmm | 12 -- rts/include/rts/Bytecodes.h | 2 - rts/include/stg/MiscClosures.h | 1 - testsuite/tests/ghci/should_run/T22958a.hs | 15 ++ testsuite/tests/ghci/should_run/T22958a.stdout | 1 + testsuite/tests/ghci/should_run/T22958b.hs | 25 ++++ testsuite/tests/ghci/should_run/T22958b.stdout | 4 + testsuite/tests/ghci/should_run/all.T | 2 + 15 files changed, 201 insertions(+), 218 deletions(-) create mode 100644 testsuite/tests/ghci/should_run/T22958a.hs create mode 100644 testsuite/tests/ghci/should_run/T22958a.stdout create mode 100644 testsuite/tests/ghci/should_run/T22958b.hs create mode 100644 testsuite/tests/ghci/should_run/T22958b.stdout diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs index f020f0af0a..c0359cacb9 100644 --- a/compiler/GHC/ByteCode/Asm.hs +++ b/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, diff --git a/compiler/GHC/ByteCode/Instr.hs b/compiler/GHC/ByteCode/Instr.hs index a35c4d1fd9..e8d377ed69 100644 --- a/compiler/GHC/ByteCode/Instr.hs +++ b/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 "" 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 diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs index a6eebe9bc9..33a16903c3 100644 --- a/compiler/GHC/StgToByteCode.hs +++ b/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 @@ -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) diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs index fc76664d94..c9e4967be0 100644 --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/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 diff --git a/rts/Disassembler.c b/rts/Disassembler.c index f8b270fa28..56be0fb775 100644 --- a/rts/Disassembler.c +++ b/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; diff --git a/rts/Interpreter.c b/rts/Interpreter.c index f8885cdbce..3b250002dc 100644 --- a/rts/Interpreter.c +++ b/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: { diff --git a/rts/Printer.c b/rts/Printer.c index e2dee0984e..85e3069967 100644 --- a/rts/Printer.c +++ b/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) { diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm index 222a12e9c6..6b54f3601f 100644 --- a/rts/StgMiscClosures.cmm +++ b/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; diff --git a/rts/include/rts/Bytecodes.h b/rts/include/rts/Bytecodes.h index e05ab26d99..93db2e98dd 100644 --- a/rts/include/rts/Bytecodes.h +++ b/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 diff --git a/rts/include/stg/MiscClosures.h b/rts/include/stg/MiscClosures.h index 8e50336e4a..9d52d4b704 100644 --- a/rts/include/stg/MiscClosures.h +++ b/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); diff --git a/testsuite/tests/ghci/should_run/T22958a.hs b/testsuite/tests/ghci/should_run/T22958a.hs new file mode 100644 index 0000000000..7ec94bc4c7 --- /dev/null +++ b/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 diff --git a/testsuite/tests/ghci/should_run/T22958a.stdout b/testsuite/tests/ghci/should_run/T22958a.stdout new file mode 100644 index 0000000000..6a452c185a --- /dev/null +++ b/testsuite/tests/ghci/should_run/T22958a.stdout @@ -0,0 +1 @@ +() diff --git a/testsuite/tests/ghci/should_run/T22958b.hs b/testsuite/tests/ghci/should_run/T22958b.hs new file mode 100644 index 0000000000..da849286aa --- /dev/null +++ b/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 diff --git a/testsuite/tests/ghci/should_run/T22958b.stdout b/testsuite/tests/ghci/should_run/T22958b.stdout new file mode 100644 index 0000000000..63f2383a2f --- /dev/null +++ b/testsuite/tests/ghci/should_run/T22958b.stdout @@ -0,0 +1,4 @@ +MkD1 11 +MkD2 12 +MkD1 11 +MkD2 12 diff --git a/testsuite/tests/ghci/should_run/all.T b/testsuite/tests/ghci/should_run/all.T index aaa8dfe856..a748cc9fa6 100644 --- a/testsuite/tests/ghci/should_run/all.T +++ b/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, ['']) -- cgit v1.2.1