- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/mangoiv/ghc-9.12-bp] 4 commits: Configure: Fix check for --target support in stage0 CC
by Magnus (＠MangoIV) 14 May '26

14 May '26

Magnus pushed to branch wip/mangoiv/ghc-9.12-bp at Glasgow Haskell Compiler / GHC Commits: 46d50d5f by Andreas Klebinger at 2026-05-14T16:26:57+02:00 Configure: Fix check for --target support in stage0 CC The check FP_PROG_CC_LINKER_TARGET used $CC unconditionally to check for --target support. However this fails for the stage0 config where the C compiler used is not $CC but $CC_STAGE0. Since we already pass the compiler under test into the macro I simply changed it to use that instead. Fixes #26999 (cherry picked from commit 43638643adbe999de8d2288a40bdd15c602f6481) - - - - - 25b0b83a by Ian Duncan at 2026-05-14T16:27:32+02:00 AArch64: fix MOVK regUsageOfInstr to mark dst as both read and written MOVK (move with keep) modifies only a 16-bit slice of the destination register, so the destination is both read and written. The register allocator must know this to avoid clobbering live values. Update regUsageOfInstr to list the destination in both src and dst sets. No regression test: triggering the misallocation requires specific register pressure around a MOVK sequence, which is difficult to reliably provoke from Haskell source. (cherry picked from commit 2823b03966e495581f4695f07649c5885306b656) - - - - - 402e6861 by Zubin Duggal at 2026-05-14T16:33:28+02:00 compiler/ffi: Collapse void pointer chains in capi wrappers New gcc/clang treat -Wincompatible-pointer-types as an error by default. Since C only allows implicit conversion from void*, not void**, capi wrappers for functions taking e.g. abstract** would fail to compile when the Haskell type Ptr (Ptr Abstract) was naively translated to void**. Collapse nested void pointers to a single void* when the pointee type has no known C representation. Fixes #26852 (cherry picked from commit 80e2dd4f084eff9cc857b31daf9ea2e9e460c727) - - - - - ba9d5b97 by Zubin Duggal at 2026-05-14T16:34:02+02:00 hadrian: Don't include the package hash in the haddock directory Since GHC 9.8 and hash_unit_ids, haddock urls have looked like`ghc-9.10.3/doc/html/libraries/base-4.20.2.0-39f9/**/*.html` The inclusion of the hash makes it hard for downstream non-boot packages to properly link to these files, as the hash is not part of a standard cabal substitution. Since we only build one version of each package, we don't need the hash to disambiguate anything, we can just remove it. Fixes #26635 (cherry picked from commit 07267f79d91169f474cacc8bcd38d76a6e97887d) - - - - - 11 changed files: - compiler/GHC/CmmToAsm/AArch64/Instr.hs - compiler/GHC/HsToCore/Foreign/C.hs - hadrian/bindist/Makefile - hadrian/src/CommandLine.hs - hadrian/src/Context.hs - hadrian/src/Settings/Builders/Cabal.hs - m4/fp_prog_cc_linker_target.m4 - + testsuite/tests/ffi/should_compile/T26852.h - + testsuite/tests/ffi/should_compile/T26852.hs - + testsuite/tests/ffi/should_compile/T26852.stderr - testsuite/tests/ffi/should_compile/all.T Changes: ===================================== compiler/GHC/CmmToAsm/AArch64/Instr.hs ===================================== @@ -114,7 +114,7 @@ regUsageOfInstr platform instr = case instr of LSL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) LSR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) MOV dst src -> usage (regOp src, regOp dst) - MOVK dst src -> usage (regOp src, regOp dst) + MOVK dst src -> usage (regOp src ++ regOp dst, regOp dst) MOVZ dst src -> usage (regOp src, regOp dst) MVN dst src -> usage (regOp src, regOp dst) ORR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) ===================================== compiler/GHC/HsToCore/Foreign/C.hs ===================================== @@ -328,37 +328,68 @@ dsFCall fn_id co fcall mDeclHeader = do toCName :: Id -> String toCName i = showSDocOneLine defaultSDocContext (pprCode (ppr (idName i))) +{- Note [Collapsing void pointer chains] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When translating Haskell types like (Ptr (Ptr Abstract)) to C types for capi +wrappers, where Abstract has no CType annotation, naively we would produce +"void**". This is problematic because in C, only void* has implicit conversion +to any pointer type. +Modern compilers (gcc, clang) treat -Wincompatible-pointer-types as an error +by default (#26852), causing compilation failures for capi wrappers. + +The fix is to collapse void pointer chains: whenever the inner type of a +Ptr/FunPtr resolves to void (i.e. the Haskell type has no known C +representation), we return void* instead of void**, void***, etc. +This works because void* implicitly converts to any pointer type in C. + +Examples: + Ptr Abstract => void* + Ptr (Ptr Abstract) => void* (used to be void**) + Ptr (Ptr (Ptr Abstract)) => void* + Ptr (Ptr CInt) => int** (CInt has CType "int", don't collapse) +-} + +-- | See Note [Collapsing void pointer chains] toCType :: Type -> (Maybe Header, SDoc) -toCType = f False - where f voidOK t - -- First, if we have (Ptr t) of (FunPtr t), then we need to +toCType t = case f False t of + (mh, _, cType) -> (mh, cType) + where + -- The Bool in the return type indicates whether the C type is + -- "void" due to an unknown Haskell type (True = void-based). + f :: Bool -> Type -> (Maybe Header, Bool, SDoc) + f voidOK t + -- First, if we have (Ptr t) or (FunPtr t), then we need to -- convert t to a C type and put a * after it. If we don't -- know a type for t, then "void" is fine, though. + -- If the inner type is void-based, we collapse the pointer + -- chain to just "void*". See Note [Collapsing void pointer chains]. | Just (ptr, [t']) <- splitTyConApp_maybe t , tyConName ptr `elem` [ptrTyConName, funPtrTyConName] = case f True t' of - (mh, cType') -> - (mh, cType' <> char '*') + (mh, True, _) -> + (mh, True, text "void*") + (mh, False, cType') -> + (mh, False, cType' <> char '*') -- Otherwise, if we have a type constructor application, then -- see if there is a C type associated with that constructor. -- Note that we aren't looking through type synonyms or -- anything, as it may be the synonym that is annotated. | Just tycon <- tyConAppTyConPicky_maybe t - , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon - = (mHeader, ftext cType) + , Just (CType _ mHeader (_, cType)) <- tyConCType_maybe tycon + = (mHeader, False, ftext cType) -- If we don't know a C type for this type, then try looking -- through one layer of type synonym etc. | Just t' <- coreView t = f voidOK t' - -- Handle 'UnliftedFFITypes' argument + -- Handle 'UnliftedFFITypes' argument | Just tyCon <- tyConAppTyConPicky_maybe t , isPrimTyCon tyCon , Just cType <- ppPrimTyConStgType tyCon - = (Nothing, text cType) + = (Nothing, False, text cType) -- Otherwise we don't know the C type. If we are allowing -- void then return that; otherwise something has gone wrong. - | voidOK = (Nothing, text "void") + | voidOK = (Nothing, True, text "void") | otherwise = pprPanic "toCType" (ppr t) ===================================== hadrian/bindist/Makefile ===================================== @@ -252,7 +252,7 @@ update_package_db: install_bin install_lib $(INSTALL_DATA) mk/system-cxx-std-lib-1.0.conf "$(DESTDIR)$(ActualLibsDir)/package.conf.d" @echo "Updating the package DB" $(foreach p, $(PKG_CONFS),\ - $(call patchpackageconf,$(shell echo $(notdir $p) | sed 's/-[0-9.]*-[0-9a-zA-Z]*\.conf//g'),$(shell echo "$p" | sed 's:\0xxx\0: :g'),$(docdir),$(shell mk/relpath.sh "$(ActualLibsDir)" "$(docdir)"),$(shell echo $(notdir $p) | sed 's/.conf//g'))) + $(call patchpackageconf,$(shell echo $(notdir $p) | sed 's/-[0-9.]*-[0-9a-zA-Z]*\.conf//g'),$(shell echo "$p" | sed 's:\0xxx\0: :g'),$(docdir),$(shell mk/relpath.sh "$(ActualLibsDir)" "$(docdir)"),$(shell echo $(notdir $p) | sed 's/-[0-9a-zA-Z]*\.conf$$//'))) '$(DESTDIR)$(ActualBinsDir)/$(CrossCompilePrefix)ghc-pkg' --global-package-db "$(DESTDIR)$(ActualLibsDir)/package.conf.d" recache .PHONY: install_mingw ===================================== hadrian/src/CommandLine.hs ===================================== @@ -113,7 +113,7 @@ data DocArgs = DocArgs } deriving (Eq, Show) defaultDocArgs :: DocArgs -defaultDocArgs = DocArgs { docsBaseUrl = "../%pkgid%" } +defaultDocArgs = DocArgs { docsBaseUrl = "../%pkg%" } readConfigure :: Either String (CommandLineArgs -> CommandLineArgs) readConfigure = Left "hadrian --configure has been deprecated (see #20167). Please run ./boot; ./configure manually" ===================================== hadrian/src/Context.hs ===================================== @@ -128,7 +128,9 @@ pkgSetupConfigFile context = pkgSetupConfigDir context <&> (-/- "setup-config") pkgHaddockFile :: Context -> Action FilePath pkgHaddockFile Context {..} = do root <- buildRoot - version <- pkgUnitId stage package + -- We don't want to use the hash in the html documentation because it + -- makes it harder for non-boot packages to link to boot packages, see #26635 + version <- pkgSimpleIdentifier package return $ root -/- "doc/html/libraries" -/- version -/- pkgName package <.> "haddock" -- | Path to the registered ghc-pkg library file of a given 'Context', e.g.: ===================================== hadrian/src/Settings/Builders/Cabal.hs ===================================== @@ -85,6 +85,9 @@ commonCabalArgs :: Stage -> Args commonCabalArgs stage = do pkg <- getPackage package_id <- expr $ pkgUnitId stage pkg + -- We don't want to use the hash in the html documentation because it + -- makes it harder for non-boot packages to link to boot packages, see #26635 + package_simple_id <- expr $ pkgSimpleIdentifier pkg let prefix = "${pkgroot}" ++ (if windowsHost then "" else "/..") mconcat [ -- Don't strip libraries when cross compiling. -- TODO: We need to set @--with-strip=(stripCmdPath :: Action FilePath)@, @@ -112,7 +115,7 @@ commonCabalArgs stage = do -- -- This doesn't hold if we move the @doc@ folder anywhere else. , arg "--htmldir" - , arg $ "${pkgroot}/../../doc/html/libraries/" ++ package_id + , arg $ "${pkgroot}/../../doc/html/libraries/" ++ package_simple_id -- These trigger a need on each dependency, so every important to need -- them in parallel or it linearises the build of Ghc and GhcPkg ===================================== m4/fp_prog_cc_linker_target.m4 ===================================== @@ -8,7 +8,7 @@ # a linker AC_DEFUN([FP_PROG_CC_LINKER_TARGET], [ - AC_MSG_CHECKING([whether $CC used as a linker understands --target]) + AC_MSG_CHECKING([whether $1 used as a linker understands --target]) echo 'int foo() { return 0; }' > conftest1.c echo 'int main() { return 0; }' > conftest2.c @@ -20,7 +20,7 @@ AC_DEFUN([FP_PROG_CC_LINKER_TARGET], # See Note [Don't pass --target to emscripten toolchain] in GHC.Toolchain.Program CONF_CC_SUPPORTS_TARGET=NO AC_MSG_RESULT([no]) - elif "$CC" $$3 --target=$LlvmTarget -o conftest conftest1.o conftest2.o; + elif "$1" $$3 --target=$LlvmTarget -o conftest conftest1.o conftest2.o; then $3="--target=$LlvmTarget $$3" AC_MSG_RESULT([yes]) ===================================== testsuite/tests/ffi/should_compile/T26852.h ===================================== @@ -0,0 +1,7 @@ +typedef struct abstract abstract; + +void blah(abstract** x); +abstract** get_abstract(void); +abstract*** get_abstract3(void); +abstract* get_simple(void); +int** get_int_pp(void); ===================================== testsuite/tests/ffi/should_compile/T26852.hs ===================================== @@ -0,0 +1,22 @@ +{-# LANGUAGE CApiFFI #-} +module T26852 where + +import Foreign.Ptr +import Foreign.C.Types + +data Abstract + +foreign import capi "T26852.h blah" + c_blah :: Ptr (Ptr Abstract) -> IO () + +foreign import capi "T26852.h get_abstract" + c_get_abstract :: IO (Ptr (Ptr Abstract)) + +foreign import capi "T26852.h get_abstract3" + c_get_abstract3 :: IO (Ptr (Ptr (Ptr Abstract))) + +foreign import capi "T26852.h get_simple" + c_get_simple :: IO (Ptr Abstract) + +foreign import capi "T26852.h get_int_pp" + c_get_int_pp :: IO (Ptr (Ptr CInt)) ===================================== testsuite/tests/ffi/should_compile/T26852.stderr ===================================== @@ -0,0 +1,18 @@ + +==================== Foreign export header file ==================== + + + +==================== Foreign export stubs ==================== +#include "T26852.h" +int** ghczuwrapperZC0ZCmainZCT26852ZCgetzuintzupp(void) {return get_int_pp();} +#include "T26852.h" +void* ghczuwrapperZC1ZCmainZCT26852ZCgetzusimple(void) {return get_simple();} +#include "T26852.h" +void* ghczuwrapperZC2ZCmainZCT26852ZCgetzuabstract3(void) {return get_abstract3();} +#include "T26852.h" +void* ghczuwrapperZC3ZCmainZCT26852ZCgetzuabstract(void) {return get_abstract();} +#include "T26852.h" +void ghczuwrapperZC4ZCmainZCT26852ZCblah(void* a1) {blah(a1);} + + ===================================== testsuite/tests/ffi/should_compile/all.T ===================================== @@ -43,3 +43,4 @@ test('T22774', unless(js_arch() or arch('wasm32'), expect_fail), compile, ['']) test('T24034', normal, compile, ['']) test('T25255', normal, compile, ['-dppr-debug']) +test('T26852', [when(js_arch(), skip), filter_stdout_lines(r'.*ghczuwrapper.*')], compile, ['-ddump-foreign']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/52c2ba8f55b6a862df6ff9fc5db5c8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/52c2ba8f55b6a862df6ff9fc5db5c8… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/mangoiv/ghc-9.12-bp] 4 commits: Fix -dsuppress-uniques for free variables in demand signatures
by Magnus (＠MangoIV) 14 May '26

14 May '26

Magnus pushed to branch wip/mangoiv/ghc-9.12-bp at Glasgow Haskell Compiler / GHC Commits: 5b5aac16 by Simon Jakobi at 2026-05-14T16:19:04+02:00 Fix -dsuppress-uniques for free variables in demand signatures Before: Str=b{sXyZ->S} With this patch: Str=b{S} T13143.stderr is updated accordingly. Fixes #27106. (cherry picked from commit 5b82080a3f3dd476e198130218d4da729fb5334a) - - - - - 98f24314 by Matthew Pickering at 2026-05-14T16:19:58+02:00 rts: forward clone-stack messages after TSO migration MSG_CLONE_STACK assumed that the target TSO was still owned by the capability that received the message. This is not always true: the TSO can migrate before the inbox entry is handled. When that happened, handleCloneStackMessage could clone a live stack from the wrong capability and use the wrong capability for allocation and performTryPutMVar, leading to stack sanity failures such as checkStackFrame: weird activation record found on stack. Fix this by passing the current capability into handleCloneStackMessage, rechecking msg->tso->cap at handling time, and forwarding the message if the TSO has migrated. Once ownership matches, use the executing capability consistently for cloneStack, rts_apply, and performTryPutMVar. Fixes #27008 (cherry picked from commit 5b550754ca0153a705ec607407074fe5716c1f7e) - - - - - d903097d by Andreas Klebinger at 2026-05-14T16:20:44+02:00 Fix missing profiling header for origin_thunk frame. Fixes #27007 (cherry picked from commit 63ae8eb38c54eaba77949b048a3621a5f4ca76e3) - - - - - 52c2ba8f by Luite Stegeman at 2026-05-14T16:24:20+02:00 bytecode: Carefully SLIDE off the end of a stack chunk The SLIDE bytecode instruction was not checking for stack chunk boundaries and could corrupt the stack underflow frame, leading to crashes. We add a check to use safe writes if we cross the chunk boundary and also handle stack underflow if Sp is advanced past the underflow frame. fix #27001 (cherry picked from commit 72b20fc0ad4b6ad12c67f686af5cb42700656886) - - - - - 15 changed files: - compiler/GHC/Types/Demand.hs - rts/CloneStack.c - rts/CloneStack.h - rts/Interpreter.c - rts/Messages.c - rts/StgMiscClosures.cmm - + testsuite/tests/bytecode/T27001.hs - + testsuite/tests/bytecode/T27001.stdout - testsuite/tests/bytecode/all.T - testsuite/tests/dmdanal/should_compile/T13143.stderr - + testsuite/tests/dmdanal/should_compile/T27106.hs - + testsuite/tests/dmdanal/should_compile/T27106.stderr - testsuite/tests/dmdanal/should_compile/all.T - testsuite/tests/rts/all.T - + testsuite/tests/rts/cloneThreadStackMigrating.hs Changes: ===================================== compiler/GHC/Types/Demand.hs ===================================== @@ -1,5 +1,6 @@ {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE PatternSynonyms #-} @@ -2844,7 +2845,10 @@ instance Outputable DmdEnv where = ppr div <> if null fv_elts then empty else braces (fsep (map pp_elt fv_elts)) where - pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd + pp_elt (uniq, dmd) = + sdocOption sdocSuppressUniques $ \case + True -> ppr dmd + False -> ppr uniq <> text "->" <> ppr dmd fv_elts = nonDetUFMToList fvs -- It's OK to use nonDetUFMToList here because we only do it for -- pretty printing ===================================== rts/CloneStack.c ===================================== @@ -89,15 +89,31 @@ void sendCloneStackMessage(StgTSO *tso, HsStablePtr mvar) { sendMessage(srcCapability, tso->cap, (Message *)msg); } -void handleCloneStackMessage(MessageCloneStack *msg){ - StgStack* newStackClosure = cloneStack(msg->tso->cap, msg->tso->stackobj); +// The cap argument is the capability which is handling the CloneStack message +void handleCloneStackMessage(Capability *cap, MessageCloneStack *msg){ + // We must check that the current owner of the thread we want to clone the stack for + // is still this capability. + Capability *owner = RELAXED_LOAD(&msg->tso->cap); + if (owner != cap) { + // The target TSO may have migrated after the message was queued on the old + // capability. In that case we must forward the request to the current + // owner; otherwise we would race with another capability mutating the + // stack while we clone it. + sendMessage(cap, owner, (Message *)msg); + return; + } + + // At this point the executing capability owns the TSO, so it is the only + // capability that may safely inspect the live stack and the one whose + // allocator we must use for the cloned StgStack closure. + StgStack* newStackClosure = cloneStack(cap, msg->tso->stackobj); // Lift StackSnapshot# to StackSnapshot by applying it's constructor. // This is necessary because performTryPutMVar() puts the closure onto the // stack for evaluation and stacks can not be evaluated (entered). - HaskellObj result = rts_apply(msg->tso->cap, StackSnapshot_constructor_closure, (HaskellObj) newStackClosure); + HaskellObj result = rts_apply(cap, StackSnapshot_constructor_closure, (HaskellObj) newStackClosure); - bool putMVarWasSuccessful = performTryPutMVar(msg->tso->cap, msg->result, result); + bool putMVarWasSuccessful = performTryPutMVar(cap, msg->result, result); if(!putMVarWasSuccessful) { barf("Can't put stack cloning result into MVar."); ===================================== rts/CloneStack.h ===================================== @@ -19,7 +19,7 @@ StgArrBytes* decodeClonedStack(Capability *cap, StgStack* stack); #include "BeginPrivate.h" #if defined(THREADED_RTS) -void handleCloneStackMessage(MessageCloneStack *msg); +void handleCloneStackMessage(Capability *cap, MessageCloneStack *msg); #endif #include "EndPrivate.h" ===================================== rts/Interpreter.c ===================================== @@ -179,6 +179,24 @@ tag functions as tag inference currently doesn't rely on those being properly ta #define WITHIN_CHUNK_BOUNDS_W(n, s) \ (RTS_LIKELY(((StgWord*) Sp_plusW(n)) < ((s)->stack + (s)->stack_size - sizeofW(StgUnderflowFrame)))) +/* Note [Checking for underflow frames] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + We look at the stack slot at offset sizeof(StgUnderflowFrame) from + the start of the chunk to check if we're in the first check chunk. + Every non-first stack chunk has an underflow frame header at that offset. + + We really should change this check, since this stack slot in the first + chunk may not be the start of a stack frame and could in theory contain + an arbitrary value. + + In practice we're unlikely to have interpreted frames that low on the stack. + */ +#define IS_UNDERFLOW_FRAME(info) \ + ((info) == &stg_stack_underflow_frame_d_info || \ + (info) == &stg_stack_underflow_frame_v16_info || \ + (info) == &stg_stack_underflow_frame_v32_info || \ + (info) == &stg_stack_underflow_frame_v64_info) #define W64_TO_WDS(n) ((n * sizeof(StgWord64) / sizeof(StgWord))) @@ -431,11 +449,9 @@ slow_spw(void *Sp, StgStack *cur_stack, StgWord offset_words){ frame = (StgUnderflowFrame*)(cur_stack->stack + cur_stack->stack_size - sizeofW(StgUnderflowFrame)); - // 2a. Check it is an underflow frame (the top stack chunk won't have one). - if( frame->info == &stg_stack_underflow_frame_d_info - || frame->info == &stg_stack_underflow_frame_v16_info - || frame->info == &stg_stack_underflow_frame_v32_info - || frame->info == &stg_stack_underflow_frame_v64_info ) + // 2a. Check it is an underflow frame (the first stack chunk won't have one). + // See Note [Checking for underflow frames] + if( IS_UNDERFLOW_FRAME(frame->info) ) { INTERP_TICK(it_underflow_lookups); @@ -452,9 +468,11 @@ slow_spw(void *Sp, StgStack *cur_stack, StgWord offset_words){ } // 2b. Access the element if there is no underflow frame, it must be right // at the top of the stack. - else { - // Not actually in the underflow case + else if(Sp_plusW(offset_words) < (StgPtr)(cur_stack->stack + cur_stack->stack_size)) { + // Still inside the stack chunk return Sp_plusW(offset_words); + } else { + barf("slow_spw: offset_words %d is out of bounds", (int)offset_words); } } } @@ -1788,8 +1806,39 @@ run_BCO: * => * a_1 ... a_n, k */ - while(n-- > 0) { - SpW(n+by) = ReadSpW(n); + if (n == 0 || WITHIN_CAP_CHUNK_BOUNDS_W(n - 1 + by)) { + while(n-- > 0) { + SpW(n+by) = ReadSpW(n); + } + } else { + // We write across a chunk boundary: Use safe access + while(n-- > 0) { + *((StgWord*)SafeSpWP(n+by)) = ReadSpW(n); + } + } + + // If we SLIDE Sp past the chunk bounds we need to handle the underflow + // (possibly multiple times) + while (!WITHIN_CAP_CHUNK_BOUNDS_W(by)) { + StgStack *stk = cap->r.rCurrentTSO->stackobj; + StgUnderflowFrame *uf = (StgUnderflowFrame*) + (stk->stack + stk->stack_size + - sizeofW(StgUnderflowFrame)); + // See Note [Checking for underflow frames] + if (IS_UNDERFLOW_FRAME(uf->info)) { + W_ sp_to_uf = (StgWord*)uf - (StgWord*)Sp; + Sp = (StgPtr)uf; + SAVE_STACK_POINTERS; + threadStackUnderflow(cap, cap->r.rCurrentTSO); + LOAD_STACK_POINTERS; + by -= sp_to_uf; + } else if (Sp_plusW(by) < (StgPtr)(stk->stack + stk->stack_size)) { + // we're within the first stack chunk, this chunk has + // no underflow frame + break; + } else { + barf("bci_SLIDE: Sp+by outside stack bounds"); + } } Sp_addW(by); INTERP_TICK(it_slides); ===================================== rts/Messages.c ===================================== @@ -135,7 +135,7 @@ loop: } else if(i == &stg_MSG_CLONE_STACK_info){ MessageCloneStack *cloneStackMessage = (MessageCloneStack*) m; - handleCloneStackMessage(cloneStackMessage); + handleCloneStackMessage(cap, cloneStackMessage); } else { ===================================== rts/StgMiscClosures.cmm ===================================== @@ -47,6 +47,7 @@ import CLOSURE stg_ret_v_info; /* See Note [Original thunk info table frames] in GHC.StgToCmm.Bind. */ INFO_TABLE_RET (stg_orig_thunk_info_frame, RET_SMALL, W_ info_ptr, + PROF_HDR_FIELDS(W_, p1, p2) W_ thunk_info_ptr) /* no args => explicit stack */ { ===================================== testsuite/tests/bytecode/T27001.hs ===================================== @@ -0,0 +1,14 @@ +{-# LANGUAGE BangPatterns #-} +-- Test that SLIDE works correctly when it crosses a stack chunk boundary. +-- See #27001. +module Main where + +go :: Int -> Double -> Double +go 0 !acc = acc +go n !acc = go (n - 1) (acc + 1.0) + +result :: Double +result = go 100000 0.0 + +main :: IO () +main = print result ===================================== testsuite/tests/bytecode/T27001.stdout ===================================== @@ -0,0 +1,4 @@ +(0.15 secs,) +it :: () +100000.0 +(0.09 secs, 51,566,104 bytes) ===================================== testsuite/tests/bytecode/all.T ===================================== @@ -9,3 +9,8 @@ test('T25975', extra_ways(ghci_ways), compile_and_run, # Nullary data constructors test('T26216', extra_files(["T26216_aux.hs"]), ghci_script, ['T26216.script']) + +# SLIDE across stack chunk boundary (#27001) +test('T27001', [extra_files(['T27001.hs']), req_interp], + run_command, + ['{compiler} -e main -O -fno-unoptimized-core-for-interpreter T27001.hs']) ===================================== testsuite/tests/dmdanal/should_compile/T13143.stderr ===================================== @@ -6,8 +6,8 @@ Result size of Tidy Core Rec { -- RHS size: {terms: 4, types: 3, coercions: 0, joins: 0/0} T13143.$wf [InlPrag=NOINLINE, Occ=LoopBreaker] - :: forall {a}. (# #) -> a -[GblId, Arity=1, Str=b{sBo->S}, Cpr=b, Unf=OtherCon []] + :: forall a. (# #) -> a +[GblId, Arity=1, Str=b{S}, Cpr=b, Unf=OtherCon []] T13143.$wf = \ (@a) _ [Occ=Dead] -> T13143.$wf @a GHC.Types.(##) end Rec } @@ -15,7 +15,7 @@ end Rec } f [InlPrag=NOINLINE[final]] :: forall a. Int -> a [GblId, Arity=1, - Str=b{sBo->S}, + Str=b{S}, Cpr=b, Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, @@ -66,7 +66,7 @@ T13143.$trModule -- RHS size: {terms: 2, types: 1, coercions: 0, joins: 0/0} lvl :: Int -[GblId, Str=b{sBo->S}, Cpr=b] +[GblId, Str=b{S}, Cpr=b] lvl = T13143.$wf @Int GHC.Types.(##) Rec { ===================================== testsuite/tests/dmdanal/should_compile/T27106.hs ===================================== @@ -0,0 +1,5 @@ +module T27106 where + +{-# NOINLINE weird #-} +weird :: Int -> a +weird x = weird x ===================================== testsuite/tests/dmdanal/should_compile/T27106.stderr ===================================== @@ -0,0 +1,4 @@ +weird [InlPrag=NOINLINE[final]] :: forall a. Int -> a +[GblId, + Arity=1, + Str=b{S}, ===================================== testsuite/tests/dmdanal/should_compile/all.T ===================================== @@ -45,6 +45,13 @@ test('T13077a', normal, compile, ['']) # T13143: WW for NOINLINE function f test('T13143', [ grep_errmsg(r'^T13143\.\$wf') ], compile, ['-ddump-simpl -dsuppress-uniques']) +# Uniques in the free variable part of a demand signature should be +# suppressed by -dsuppress-uniques. +test('T27106', normal, multimod_compile_filter, + ['T27106', + '-v0 -O -ddump-simpl -dsuppress-uniques', + r"sed -n '/^weird /,/.* Str=/p'"]) + # T15627 # Absent bindings of unlifted types should be WW'ed away. # The idea is to check that both $wmutVar and $warray ===================================== testsuite/tests/rts/all.T ===================================== @@ -583,6 +583,15 @@ test('cloneMyStack_retBigStackFrame', [req_c, extra_files(['cloneStackLib.c']), test('cloneThreadStack', [req_c, only_ways(['threaded1']), extra_ways(['threaded1']), extra_files(['cloneStackLib.c']), req_ghc_with_threaded_rts], compile_and_run, ['cloneStackLib.c -threaded']) +test('cloneThreadStackMigrating', + [ ignore_stdout + , only_ways(['threaded1']) + , extra_ways(['threaded1']) + , extra_run_opts('+RTS -N -DS -RTS') + , req_ghc_with_threaded_rts + , req_target_smp + ], compile_and_run, ['-threaded -debug -rtsopts']) + test('decodeMyStack', [ omit_ghci, js_broken(22261) # cloneMyStack# not yet implemented ], compile_and_run, ['-finfo-table-map']) ===================================== testsuite/tests/rts/cloneThreadStackMigrating.hs ===================================== @@ -0,0 +1,37 @@ +module Main where + +import Control.Concurrent +import Control.Monad +import GHC.Exts.Stack +import GHC.Stack.CloneStack + +numWorkers :: Int +numWorkers = 100 + +startN :: Int +startN = 10 + +runForMicros :: Int +runForMicros = 1000000 + +fib :: Int -> Int +fib 0 = 1 +fib 1 = 1 +fib n = fib (n - 1) + fib (n - 2) + +workerThread :: Int -> IO () +workerThread n = do + fib n `seq` pure () + workerThread (n + 1) + +cloneThread :: ThreadId -> IO () +cloneThread tid = forever $ do + snapshot <- cloneThreadStack tid + stack <- decodeStack snapshot + stack `seq` pure () + +main :: IO () +main = do + tids <- replicateM numWorkers (forkIO $ workerThread startN) + mapM_ (forkIO . cloneThread) tids + threadDelay runForMicros View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c0b9c16240dd96548f319c8b2376e3… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c0b9c16240dd96548f319c8b2376e3… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/wenkokke/trace-ipe] rts: Add IPE event class for -l
by Wen Kokke (＠wenkokke) 14 May '26

14 May '26

Wen Kokke pushed to branch wip/wenkokke/trace-ipe at Glasgow Haskell Compiler / GHC Commits: f9e73196 by Wen Kokke at 2026-05-14T15:18:49+01:00 rts: Add IPE event class for -l - - - - - 8 changed files: - + changelog.d/ipe-event-class - docs/users_guide/runtime_control.rst - rts/IPE.c - rts/RtsFlags.c - rts/Trace.c - rts/Trace.h - rts/include/rts/EventLogWriter.h - rts/include/rts/Flags.h Changes: ===================================== changelog.d/ipe-event-class ===================================== @@ -0,0 +1,9 @@ +section: compiler +synopsis: Add eventlog flag -lI to enable/disable IPE tracing +issues: #27239 +mrs: !16004 + +description: { + The RTS `-l` flag now accepts the new event class `I`, + which controls whether or not IPE events are emitted. +} ===================================== docs/users_guide/runtime_control.rst ===================================== @@ -1304,6 +1304,9 @@ When the program is linked with the :ghc-flag:`-eventlog` option - ``u`` — user events. These are events emitted from Haskell code using functions such as ``Debug.Trace.traceEvent``. Enabled by default. + - ``I`` — IPE events. These events describe source position information + for info tables. See :ghc-flag:`-finfo-table-map`. + You can disable specific classes, or enable/disable all classes at once: ===================================== rts/IPE.c ===================================== @@ -165,26 +165,46 @@ static void traceIPEFromHashTable(void *data STG_UNUSED, StgWord key STG_UNUSED, } void dumpIPEToEventLog(void) { - // Dump pending entries - IpeBufferListNode *node = RELAXED_LOAD(&ipeBufferList); - while (node != NULL) { - if (ipe_node_valid(node)){ - decompressIPEBufferListNodeIfCompressed(node); - - for (uint32_t i = 0; i < node->count; i++) { - const InfoProvEnt ent = ipeBufferEntryToIpe(node, i); - traceIPE(&ent); - } + /* + Usually, traceX functions are defined as a pair of a traceX_ function that + traces unconditionally and a traceX functional macro that performs the test + for the relevant TRACE_x flag. + + This function is the only function that calls traceIPE, but it takes a lot + of work just to prepare the IPE information. If traceIPE does not trace that + IPE information, all that work is wasted. Hence, the test of TRACE_ipe is + performed in this function instead. + + This function is called via traceInitEvent in RtsStartup.c, which registers + it as an init event handler. It is important that this happens regardless + of whether or not IPE tracing is enabled at startup, since IPE tracing can + be started/stopped at runtime using the dynamic trace flags API. + + IPE tracing is enabled whenever IPE debug printing is enabled via -DI, so + this test does not prevent IPE debug printing. + */ + if (RTS_UNLIKELY(TRACE_ipe)) { + // Dump pending entries + IpeBufferListNode *node = RELAXED_LOAD(&ipeBufferList); + while (node != NULL) { + if (ipe_node_valid(node)){ + decompressIPEBufferListNodeIfCompressed(node); + + for (uint32_t i = 0; i < node->count; i++) { + const InfoProvEnt ent = ipeBufferEntryToIpe(node, i); + traceIPE(&ent); + } + } + node = node->next; } - node = node->next; - } - // Dump entries already in hashmap - ACQUIRE_LOCK(&ipeMapLock); - if (ipeMap != NULL) { - mapHashTable(ipeMap, NULL, &traceIPEFromHashTable); + // Dump entries already in hashmap + ACQUIRE_LOCK(&ipeMapLock); + if (ipeMap != NULL) { + mapHashTable(ipeMap, NULL, &traceIPEFromHashTable); + } + RELEASE_LOCK(&ipeMapLock); } - RELEASE_LOCK(&ipeMapLock); } ===================================== rts/RtsFlags.c ===================================== @@ -249,6 +249,7 @@ void initRtsFlagsDefaults(void) RtsFlags.TraceFlags.sparks_sampled= false; RtsFlags.TraceFlags.sparks_full = false; RtsFlags.TraceFlags.user = false; + RtsFlags.TraceFlags.ipe = false; RtsFlags.TraceFlags.ticky = false; RtsFlags.TraceFlags.trace_output = NULL; # if defined(THREADED_RTS) @@ -449,6 +450,7 @@ usage_text[] = { " p par spark events (sampled)", " f par spark events (full detail)", " u user events (emitted from Haskell code)", +" I IPE events", #if defined(TICKY_TICKY) " T ticky-ticky counter samples", #endif @@ -457,7 +459,7 @@ usage_text[] = { " t add time stamps (only useful with -v)", # endif " -x disable an event class, for any flag above", -" the initial enabled event classes are 'sgpu'", +" the initial enabled event classes are 'sgIpu'", # if defined(THREADED_RTS) " --eventlog-flush-interval=<secs>", " Periodically flush the eventlog at the specified interval.", @@ -2528,6 +2530,7 @@ static void read_trace_flags(const char *arg) RtsFlags.TraceFlags.gc = true; RtsFlags.TraceFlags.sparks_sampled = true; RtsFlags.TraceFlags.user = true; + RtsFlags.TraceFlags.ipe = true; for (c = arg; *c != '\0'; c++) { switch(*c) { @@ -2541,8 +2544,9 @@ static void read_trace_flags(const char *arg) RtsFlags.TraceFlags.gc = enabled; RtsFlags.TraceFlags.sparks_sampled = enabled; RtsFlags.TraceFlags.sparks_full = enabled; - RtsFlags.TraceFlags.user = enabled; RtsFlags.TraceFlags.nonmoving_gc = enabled; + RtsFlags.TraceFlags.user = enabled; + RtsFlags.TraceFlags.ipe = enabled; #if defined(TICKY_TICKY) RtsFlags.TraceFlags.ticky = enabled; #endif @@ -2577,6 +2581,10 @@ static void read_trace_flags(const char *arg) RtsFlags.TraceFlags.user = enabled; enabled = true; break; + case 'I': + RtsFlags.TraceFlags.ipe = enabled; + enabled = true; + break; case 'T': #if defined(TICKY_TICKY) RtsFlags.TraceFlags.ticky = enabled; ===================================== rts/Trace.c ===================================== @@ -47,6 +47,8 @@ bool getTraceFlag(RUNTIME_TRACE_FLAG flag) { return RuntimeTraceFlagCache.user; case TRACE_CAP: return RuntimeTraceFlagCache.cap; + case TRACE_IPE: + return RuntimeTraceFlagCache.ipe; default: return false; } @@ -75,6 +77,9 @@ void setTraceFlag(RUNTIME_TRACE_FLAG flag, bool value) { case TRACE_CAP: RuntimeTraceFlagCache.cap = value; break; + case TRACE_IPE: + RuntimeTraceFlagCache.ipe = value; + break; } } @@ -119,13 +124,19 @@ static void updateTraceFlagCache(void) { RuntimeTraceFlagCache.user = RtsFlags.TraceFlags.user; + // -DI turns on IPE tracing too + RuntimeTraceFlagCache.ipe = + RtsFlags.TraceFlags.ipe || + RtsFlags.DebugFlags.ipe; + // We trace cap events if we're tracing anything else RuntimeTraceFlagCache.cap = TRACE_sched || TRACE_gc || TRACE_spark_sampled || TRACE_spark_full || - TRACE_user; + TRACE_user || + TRACE_ipe; } void initTracing (void) @@ -720,6 +731,7 @@ void traceHeapProfSampleString(const char *label, StgWord residency) } } +// The TRACE_ipe test happens in dumpIPEToEventLog. void traceIPE(const InfoProvEnt *ipe) { #if defined(DEBUG) ===================================== rts/Trace.h ===================================== @@ -79,6 +79,7 @@ enum CapsetType { CapsetTypeCustom = CAPSET_TYPE_CUSTOM, #define TRACE_spark_full ((const bool)RuntimeTraceFlagCache.spark_full) #define TRACE_user ((const bool)RuntimeTraceFlagCache.user) #define TRACE_cap ((const bool)RuntimeTraceFlagCache.cap) +#define TRACE_ipe ((const bool)RuntimeTraceFlagCache.ipe) /* * Runtime trace flags. @@ -91,6 +92,7 @@ typedef struct { bool spark_full; bool user; bool cap; + bool ipe; } RUNTIME_TRACE_FLAG_CACHE; /* ===================================== rts/include/rts/EventLogWriter.h ===================================== @@ -90,6 +90,7 @@ typedef enum { TRACE_SPARK_FULL, TRACE_USER, TRACE_CAP, + TRACE_IPE, } RUNTIME_TRACE_FLAG; /* ===================================== rts/include/rts/Flags.h ===================================== @@ -191,6 +191,7 @@ typedef struct _TRACE_FLAGS { bool sparks_full; /* trace spark events 100% accurately */ bool ticky; /* trace ticky-ticky samples */ bool user; /* trace user events (emitted from Haskell code) */ + bool ipe; /* trace IPE events */ #if defined(THREADED_RTS) /* Time between force eventlog flushes (or 0 if disabled) */ Time eventlogFlushTime; View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f9e731963688e28f6eb129ce852bd3b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f9e731963688e28f6eb129ce852bd3b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: testsuite: mark T22159 as fragile
by Marge Bot (＠marge-bot) 14 May '26

14 May '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 38b76b2f by Cheng Shao at 2026-05-13T17:48:48-04:00 testsuite: mark T22159 as fragile This patch marks T22159 as fragile on Windows for issue described in #27248. Before we get to the bottom of those failures, this unblocks newer Windows runners. - - - - - 4bdc5b5c by Simon Peyton Jones at 2026-05-14T09:27:15-04:00 Do not use mkCast during typechecking This commit fixes #27219. The problem was that the typechecker was using `mkCast`, whose assertion checks legitimately fail when applied to types that contain unification variables. - - - - - 307b5116 by Simon Peyton Jones at 2026-05-14T09:27:15-04:00 Major refactor of the Simplifier The main payload of this patch is to refactor the Simplifer to avoid repeated simplification when using Plan (AFTER) for rule rewrites. The need for this was shown up by #26989. See Note [Avoid repeated simplification] in GHC.Core.Opt.Simplify.Iteration. Related refactoring: * Refactor the two fields `sc_dup` and `sc_env` in `ApplyToVal` into one, `sc_env`. Reason: the envt is irrelevant in the "simplified" case, so the data type describes the possiblitiies much more accurately now. * Some refactoring in `knownCon` to split off `wrapDataConFloats`. * Refactor `lookupRule` and its auxiliary functions to return `RuleMatch`, a new data type. See Note [data RuleMatch] in GHC.Core. Ditto for BuiltinRule. This RuleMatch returns fragments of the target in rm_args and rm_floats, leaving `rm_rhs` to be the stuff from the RULE itself. Doing this has routine consequences in GHC.Core.Opt.ConstantFold. Many changes there but all routine. * When doing occurrence analysis on RULEs, make the occ-info on the rule binders relate just to the RHS, not the LHS. See (OUR1) in Note Note [OccInfo in unfoldings and rules] This means that Lint must not complain about the fact that the patterns in the RULE mentions binders that are marked dead. See Note [Dead occurrences] in GHC.Core.Lint. I changed the Core pretty-printer so that it didn't suppress dead binders, else I can't see those binders in RULEs. That led to quite a lot of testsuite wibbles. * Refactor FloatBinds, so that it is used both by `exprIsConApp_mabye` and by `lookupRule` * Move the definition of FloatBinds out of GHc.Core.Make, into GHC.Core. * Add FloatTick as an extra constructor. * Refactor `lookupRule` to use `FloatBinds` instead of `BindWrapper`. This refactor just shares more code. (Rename GHC.Core.Opt.FloatOut.FloatBinds to FloatLets, to avoid gratuitious name clash with GHC.Core.FloatBinds.) Corecion optimisation * In simpleOpt, when composing coercions, call new function `optTransCo`. This is much lighter weight than full blown coercion optimisation. * Make `GHC.Core.Opt.Arity.pushCoValArg` and `pushCoTyArg` return the coercionLKind of the coercion. This saves recomputing that coercionLKind at the key call sites in GHC.Core.Opt.Simplify.Iteration.pushCast. * Rename `addCoerce` in GHC.Core.Simplify.Iteration to become `pushCast`. * In the `ApplyToVal` case of `pushCast` we had a very unsavoury call to `simplArg`. I eliminated it by adding a field `sc_cast` to `ApplyToVal` that records any pending casts. Much nicer now. See Note [The sc_cast field of ApplyToVal]. * Don't optimise coercions if the type-substitution is empty. See Note [Optimising coercions] in GHC.Core.Opt.Simplify.Iteration. The fix for #26838 is dramatic. For the test in perf/compiler/T26839 we have Compiler allocs: Before: 7,363M After: 688M Compile time goes down generally. Here are compiler-alloc changes over 0.5%: CoOpt_Read(normal) 729,184,920 -0.7% CoOpt_Singletons(normal) 666,916,960 -4.6% GOOD LargeRecord(normal) 1,227,056,876 +1.1% T12227(normal) 256,827,604 -4.6% GOOD T12425(optasm) 76,879,410 -0.8% T12545(normal) 787,826,918 -10.8% GOOD T12707(normal) 775,186,464 -0.9% T13253(normal) 318,599,596 -0.8% T14766(normal) 685,857,320 -1.0% T15304(normal) 1,123,333,422 -2.2% T15630(normal) 123,142,330 -2.6% T15630a(normal) 123,092,100 -2.6% T15703(normal) 299,751,682 -2.9% GOOD T17516(normal) 964,072,280 +1.0% T18223(normal) 367,016,820 -6.2% GOOD T18730(optasm) 130,643,770 -3.3% GOOD T20261(normal) 535,608,584 -0.7% T21839c(normal) 340,340,436 -0.9% T24984(normal) 85,568,392 -1.9% T3064(normal) 174,631,992 -1.2% T3294(normal) 1,215,886,432 -0.7% T5030(normal) 141,449,704 -17.2% GOOD T5321Fun(normal) 258,484,744 -1.9% T8095(normal) 770,532,232 -2.7% T9630(normal) 858,423,408 -14.5% GOOD T9872c(normal) 1,591,709,448 +0.7% info_table_map_perf(normal) 19,700,614,458 -1.3% geo. mean -0.7% minimum -17.2% maximum +1.1% Metric Decrease: CoOpt_Singletons T12227 T12545 T12707 T15703 T18223 T18730 T21839c T5030 T9630 - - - - - 08271914 by Duncan Coutts at 2026-05-14T09:27:15-04:00 Document removal of the signal-based interval timer Update mentions within the RTS section of the users guide. Add a changelog entry. - - - - - d8f25974 by Duncan Coutts at 2026-05-14T09:27:16-04:00 Fix section for an recent changelog entry - - - - - 61 changed files: - changelog.d/dynamic-trace-flags - + changelog.d/no-more-timer-signal - compiler/GHC/Core.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/Coercion/Opt.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Make.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Opt/FloatIn.hs - compiler/GHC/Core/Opt/FloatOut.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Data/List/SetOps.hs - compiler/GHC/Driver/Config/Core/Lint.hs - compiler/GHC/HsToCore/Pmc/Solver.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Types/Id/Make.hs - docs/users_guide/profiling.rst - docs/users_guide/runtime_control.rst - testsuite/tests/codeGen/should_compile/T25177.stderr - testsuite/tests/deSugar/should_compile/T13208.stdout - testsuite/tests/ffi/should_run/all.T - testsuite/tests/linters/notes.stdout - testsuite/tests/numeric/should_compile/T15547.stderr - testsuite/tests/numeric/should_compile/T20347.stderr - testsuite/tests/numeric/should_compile/T20374.stderr - testsuite/tests/numeric/should_compile/T20376.stderr - + testsuite/tests/perf/compiler/T26989.hs - + testsuite/tests/perf/compiler/T26989a.hs - testsuite/tests/perf/compiler/all.T - testsuite/tests/printer/T18052a.stderr - testsuite/tests/simplCore/should_compile/DsSpecPragmas.stderr - testsuite/tests/simplCore/should_compile/RewriteHigherOrderPatterns.stderr - testsuite/tests/simplCore/should_compile/T15205.stderr - testsuite/tests/simplCore/should_compile/T18668.stderr - testsuite/tests/simplCore/should_compile/T19246.stderr - testsuite/tests/simplCore/should_compile/T19599.stderr - testsuite/tests/simplCore/should_compile/T19599a.stderr - testsuite/tests/simplCore/should_compile/T21917.stderr - testsuite/tests/simplCore/should_compile/T23074.stderr - testsuite/tests/simplCore/should_compile/T24359a.stderr - testsuite/tests/simplCore/should_compile/T25160.stderr - testsuite/tests/simplCore/should_compile/T25718c.stderr-ws-32 - testsuite/tests/simplCore/should_compile/T25718c.stderr-ws-64 - testsuite/tests/simplCore/should_compile/T26051.stderr - testsuite/tests/simplCore/should_compile/T26116.stderr - testsuite/tests/simplCore/should_compile/T8331.stderr - testsuite/tests/simplCore/should_compile/T8848a.stderr - testsuite/tests/simplCore/should_compile/spec004.stderr - testsuite/tests/typecheck/should_compile/T13032.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/79d9c37fd8986dc0630e5337d1a448… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/79d9c37fd8986dc0630e5337d1a448… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-reinstallable-base2] 3 commits: finish going through them
by Rodrigo Mesquita (＠alt-romes) 14 May '26

14 May '26

Rodrigo Mesquita pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC Commits: 64903c23 by Rodrigo Mesquita at 2026-05-14T00:33:45+01:00 finish going through them - - - - - d2787047 by Rodrigo Mesquita at 2026-05-14T11:45:54+01:00 kill more things - - - - - d1742062 by Rodrigo Mesquita at 2026-05-14T13:42:42+01:00 fixes [skip ci] - - - - - 6 changed files: - compiler/GHC/Builtin.hs - compiler/GHC/Builtin/KnownKeys.hs - compiler/GHC/Core/Make.hs - compiler/GHC/Iface/Binary.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Module.hs Changes: ===================================== compiler/GHC/Builtin.hs ===================================== @@ -26,15 +26,11 @@ module GHC.Builtin ( knownKeyTable, knownKeyOccMap, knownKeyUniqMap, knownKeyOccName, knownKeyOccName_maybe, - -- * Known-occ names - oldIsKnownKeyName, - oldLookupKnownKeyName, - oldLookupKnownNameInfo, - -- * Random other things maybeCharLikeCon, maybeIntLikeCon, allNameStrings, allNameStringList, itName, mkUnboundName, isUnboundName, + lookupKnownNameInfo, -- * Class categories isNumericClass, isStandardClass, @@ -46,7 +42,6 @@ module GHC.Builtin ( import GHC.Prelude -import GHC.Builtin.Uniques import GHC.Builtin.PrimOps import GHC.Builtin.PrimOps.Ids import GHC.Builtin.WiredIn.Types @@ -77,10 +72,6 @@ import GHC.Data.List.SetOps import GHC.Data.FastString import qualified GHC.Data.List.Infinite as Inf -import Control.Applicative ((<|>)) -import Data.Maybe - - {- ********************************************************************* * * @@ -579,17 +570,11 @@ wiredInNames Nothing -> [] -- | Check the known-key names list of consistency. --- (a) Unique is in-range (ToDo: get rid of this) --- (b) Distinct uniques +-- (a) Distinct uniques knownKeyNamesOkay :: [Name] -> Maybe SDoc knownKeyNamesOkay all_names - | ns@(_:_) <- filter (not . isValidKnownKeyUnique . getUnique) all_names - = Just $ text " Out-of-range known-key uniques: " <> - brackets (pprWithCommas (ppr . nameOccName) ns) - | null badNamesPairs - = Nothing - | otherwise - = Just badNamesDoc + | null badNamesPairs = Nothing + | otherwise = Just badNamesDoc where namesEnv = foldl' (\m n -> extendNameEnv_Acc (:) Utils.singleton m n n) emptyUFM all_names @@ -606,42 +591,18 @@ knownKeyNamesOkay all_names text ": " <> brackets (pprWithCommas (ppr . nameOccName) ns) ---------------- ToDo: get rid of these old-mechanism functions ---------------- when we complete the known-key tranitition --------------- See #27013 - --- | Given a 'Unique' lookup its associated 'Name' if it corresponds to a --- known-key thing. -oldLookupKnownKeyName :: Unique -> Maybe Name -oldLookupKnownKeyName u = - knownUniqueName u <|> lookupUFM_Directly oldKnownKeysMap u - --- TODO: remove this once all knownkey names come from providers --- | Is a 'Name' known-key? -oldIsKnownKeyName :: Name -> Bool -oldIsKnownKeyName n = - isJust (knownUniqueName $ nameUnique n) || elemUFM n oldKnownKeysMap - --- | Maps 'Unique's to known-key names. --- --- The type is @UniqFM Name Name@ to denote that the 'Unique's used --- in the domain are 'Unique's associated with 'Name's (as opposed --- to some other namespace of 'Unique's). -oldKnownKeysMap :: UniqFM Name Name -oldKnownKeysMap = listToIdentityUFM wiredInNames - -- | Given a 'Unique' lookup any associated arbitrary SDoc's to be displayed by -- GHCi's ':info' command. -oldLookupKnownNameInfo :: Name -> SDoc -oldLookupKnownNameInfo name = case lookupNameEnv knownNamesInfo name of +lookupKnownNameInfo :: Name -> SDoc +lookupKnownNameInfo name = case lookupUFM knownNamesInfo (getUnique name) of -- If we do find a doc, we add comment delimiters to make the output -- of ':info' valid Haskell. Nothing -> empty Just doc -> vcat [text "{-", doc, text "-}"] -- A map from Uniques to SDocs, used in GHCi's ':info' command. (#12390) -knownNamesInfo :: NameEnv SDoc -knownNamesInfo = unitNameEnv coercibleTyConName $ +knownNamesInfo :: UniqFM KnownKey SDoc +knownNamesInfo = unitUFM coercibleTyConKey $ vcat [ text "Coercible is a special constraint with custom solving rules." , text "It is not a class." , text "Please see section `The Coercible constraint`" ===================================== compiler/GHC/Builtin/KnownKeys.hs ===================================== @@ -63,8 +63,6 @@ import GHC.Prelude import GHC.Builtin.Uniques -import GHC.Unit.Types - import GHC.Types.Name.Occurrence import GHC.Types.Name.Reader import GHC.Types.Unique @@ -73,8 +71,6 @@ import GHC.Types.Name import GHC.Utils.Misc( HasDebugCallStack ) import GHC.Utils.Panic - -import GHC.Data.FastString import GHC.Data.Maybe @@ -150,6 +146,7 @@ knownKeyTable , (mkTcOcc "Num", numClassKey) , (mkTcOcc "Integral", integralClassKey) , (mkTcOcc "Real", realClassKey) + , (mkTcOcc "Floating", floatingClassKey) , (mkTcOcc "Fractional", fractionalClassKey) , (mkTcOcc "RealFloat", realFloatClassKey) , (mkTcOcc "RealFrac", realFracClassKey) @@ -356,50 +353,18 @@ knownKeyTable * * ************************************************************************ -Many of these Names are not really "built in", but some parts of the -compiler (notably the deriving mechanism) need to mention their names, -and it's convenient to write them all down in one place. +See Note [Overview of known entities] -} -wildCardName :: Name -wildCardName = mkSystemVarName wildCardKey (fsLit "wild") - -- AMP additions pureAClassOpKey, thenAClassOpKey, alternativeClassKey :: KnownKey pureAClassOpKey = mkPreludeMiscIdUnique 752 thenAClassOpKey = mkPreludeMiscIdUnique 753 alternativeClassKey = mkPreludeMiscIdUnique 754 ---------------------------------- --- End of ghc-bignum ---------------------------------- - --- WithDict - genericClassKeys :: [KnownKey] genericClassKeys = [genClassKey, gen1ClassKey] -{- -************************************************************************ -* * -\subsection{Local helpers} -* * -************************************************************************ - -All these are original names; hence mkOrig --} - -{-# INLINE varQual #-} -{-# INLINE tcQual #-} -{-# INLINE clsQual #-} -{-# INLINE dcQual #-} -varQual, tcQual, clsQual, dcQual :: Module -> FastString -> Unique -> Name -varQual modu str unique = mk_known_key_name varName modu str unique -tcQual modu str unique = mk_known_key_name tcName modu str unique -clsQual modu str unique = mk_known_key_name clsName modu str unique -dcQual modu str unique = mk_known_key_name dataName modu str unique - - {- ********************************************************************* * * Statically-known occurrence names @@ -413,6 +378,8 @@ pureAClassOpOcc = mkVarOcc "pure" returnMClassOpOcc = mkVarOcc "return" thenMClassOpOcc = mkVarOcc ">>" bindMClassOpOcc = mkVarOcc ">>=" + -- ROMES:TODO: bindMClassOpOcc does not have a Known Names Table Entry. What + -- happens to all these occs needed for Quote? Should we make them just KnownOcc? thenAClassOpOcc = mkVarOcc "*>" mappendClassOpOcc = mkVarOcc "mappend" getFieldClassOpOcc = mkVarOcc "getField" ===================================== compiler/GHC/Core/Make.hs ===================================== @@ -190,6 +190,9 @@ mkWildValBinder w ty = mkLocalIdOrCoVar wildCardName w ty -- "OrCoVar" since a coercion can be a scrutinee with -fdefer-type-errors -- (e.g. see test T15695). Ticket #17291 covers fixing this problem. +wildCardName :: Name +wildCardName = mkSystemVarName wildCardKey (fsLit "wild") + -- | Make a case expression whose case binder is unused -- The alts and res_ty should not have any occurrences of WildId mkWildCase :: CoreExpr -- ^ scrutinee ===================================== compiler/GHC/Iface/Binary.hs ===================================== @@ -32,14 +32,13 @@ module GHC.Iface.Binary ( import GHC.Prelude -import GHC.Builtin ( knownKeyOccMap, oldIsKnownKeyName, oldLookupKnownKeyName ) +import GHC.Builtin ( knownKeyOccMap ) import GHC.Utils.Panic import GHC.Utils.Binary as Binary import GHC.Utils.Outputable import GHC.Types.Name import GHC.Types.Unique.FM -import GHC.Types.Unique import GHC.Types.SrcLoc import GHC.Types.Name.Cache @@ -58,7 +57,6 @@ import Control.Monad import Data.Array import Data.Array.IO import Data.Array.Unsafe -import Data.Char import Data.IORef import Data.Map.Strict (Map) import Data.Word @@ -703,42 +701,11 @@ getSymbolTable bh name_cache ; writeArray mut_arr (fromIntegral i) name ; return new_cache } --- ROMES:TODO: KILL THIS from here to the end. --- We no longer put uniques for known-occ names anymore, they'll be looked up --- in the table. --- No uniques in interface files! - - --- Note [Symbol table representation of names] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- An occurrence of a name in an interface file is serialized as a single 32-bit --- word. The format of this word is: --- 00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx --- A normal name. x is an index into the symbol table --- 10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy --- A known-key name. x is the Unique's Char, y is the int part. We assume that --- all known-key uniques fit in this space. This is asserted by --- GHC.Builtin.knownKeyNamesOkay. --- --- During serialization we check for known-key things using oldIsKnownKeyName. --- During deserialization we use lookupKnownKeyName to get from the unique back --- to its corresponding Name. - - --- See Note [Symbol table representation of names] putName :: BinSymbolTable -> WriteBinHandle -> Name -> IO () putName BinSymbolTable{ bin_symtab_map = symtab_map_ref, bin_symtab_next = symtab_next } bh name - | oldIsKnownKeyName name - , let (c, u) = unpkUniqueGrimly (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits - = -- assert (u < 2^(22 :: Int)) - put_ bh (0x80000000 - .|. (fromIntegral (ord c) `shiftL` 22) - .|. (fromIntegral u :: Word32)) - - | otherwise = do symtab_map <- readIORef symtab_map_ref case lookupUFM symtab_map name of Just (off,_) -> put_ bh (fromIntegral off :: Word32) @@ -750,23 +717,8 @@ putName BinSymbolTable{ $! addToUFM symtab_map name (off,name) put_ bh (fromIntegral off :: Word32) --- See Note [Symbol table representation of names] getSymtabName :: SymbolTable Name -> ReadBinHandle -> IO Name getSymtabName symtab bh = do i :: Word32 <- get bh - case i .&. 0xC0000000 of - 0x00000000 -> return $! symtab ! fromIntegral i - - 0x80000000 -> - let - tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22)) - ix = fromIntegral i .&. 0x003FFFFF - u = mkUniqueGrimilyWithTag tag ix - in - return $! case oldLookupKnownKeyName u of - Nothing -> pprPanic "getSymtabName:unknown known-key unique" - (ppr i $$ ppr u $$ char tag $$ ppr ix) - Just n -> n - - _ -> pprPanic "getSymtabName:unknown name tag" (ppr i) + return $! symtab ! fromIntegral i ===================================== compiler/GHC/Tc/Gen/HsType.hs ===================================== @@ -105,7 +105,7 @@ import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr import GHC.Builtin( allNameStrings ) -import GHC.Builtin.KnownKeys hiding ( wildCardName ) +import GHC.Builtin.KnownKeys import GHC.Builtin.WiredIn.Types import GHC.Builtin.WiredIn.Prim ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -2989,7 +2989,7 @@ tcRnGetInfo hsc_env name ; thing <- tcRnLookupName' name ; fixity <- lookupFixityRn name ; (cls_insts, fam_insts) <- lookupInsts thing - ; let info = oldLookupKnownNameInfo name + ; let info = lookupKnownNameInfo name ; return (thing, fixity, cls_insts, fam_insts, info) } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8a4236f2eef310de910c4684457df1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8a4236f2eef310de910c4684457df1… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/module-graph-reuse-in-downsweep] Adapt the tests that use the changed operations directly
by Wolfgang Jeltsch (＠jeltsch) 14 May '26

14 May '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/module-graph-reuse-in-downsweep at Glasgow Haskell Compiler / GHC Commits: af65c890 by Wolfgang Jeltsch at 2026-05-14T15:35:37+03:00 Adapt the tests that use the changed operations directly - - - - - 3 changed files: - testsuite/tests/ghc-api/downsweep/OldModLocation.hs - testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs - testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs Changes: ===================================== testsuite/tests/ghc-api/downsweep/OldModLocation.hs ===================================== @@ -48,13 +48,13 @@ main = do liftIO $ do - _emss <- downsweep hsc_env mkUnknownDiagnostic Nothing [] [] False + _emss <- downsweep hsc_env mkUnknownDiagnostic Nothing [] Nothing [] False flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env) createDirectoryIfMissing False "mydir" renameFile "B.hs" "mydir/B.hs" - (_, nodes) <- downsweep hsc_env mkUnknownDiagnostic Nothing [] [] False + (_, nodes) <- downsweep hsc_env mkUnknownDiagnostic Nothing [] Nothing [] False -- If 'checkSummaryTimestamp' were to call 'addHomeModuleToFinder' with -- (ms_location old_summary) like summariseFile used to instead of ===================================== testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs ===================================== @@ -169,7 +169,7 @@ go label mods cnd = setTargets [tgt] hsc_env <- getSession - (_, nodes) <- liftIO $ downsweep hsc_env mkUnknownDiagnostic Nothing [] [] False + (_, nodes) <- liftIO $ downsweep hsc_env mkUnknownDiagnostic Nothing [] Nothing [] False it label $ cnd (mgModSummaries nodes) ===================================== testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs ===================================== @@ -67,7 +67,7 @@ main = do keyC = msKey msC let mkGraph s = do - ([], nodes) <- downsweepFromRootNodes hsc_env mempty [] True DownsweepUseFixed s [] + ([], nodes) <- downsweepFromRootNodes hsc_env mempty Nothing [] True DownsweepUseFixed s [] return $ mkModuleGraph nodes graph <- liftIO $ mkGraph [ModuleNodeCompile msC] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/af65c890d26e679b96baff9aaef271f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/af65c890d26e679b96baff9aaef271f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Deleted branch wip/jeltsch/more-efficient-home-unit-imports-finding
by Wolfgang Jeltsch (＠jeltsch) 14 May '26

14 May '26

Wolfgang Jeltsch deleted branch wip/jeltsch/more-efficient-home-unit-imports-finding at Glasgow Haskell Compiler / GHC -- You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/mangoiv/ghc-9.12-bp] Deleted 1 commit: Clean up join points, casts & ticks
by Magnus (＠MangoIV) 14 May '26

14 May '26

Magnus pushed to branch wip/mangoiv/ghc-9.12-bp at Glasgow Haskell Compiler / GHC WARNING: The push did not contain any new commits, but force pushed to delete the commits and changes below. Deleted commits: ed54720f by sheaf at 2026-05-13T20:03:59+02:00 Clean up join points, casts & ticks This commit shores up the logic dealing with casts and ticks occurring in between a join point binding and a jump. Fixes #26642 #26929 #26693 Makes progress on #14610 #26157 #26422 Changes: - Remove 'GHC.Types.Tickish.TickishScoping' in favour of simpler predicates 'tickishHasNoScope'/'tickishHasSoftScope', as things were before commit 993975d3. This makes the code easier to read and document (fewer indirections). - Introduce 'canCollectArgsThroughTick' for consistent handling of ticks around PrimOps and other 'Id's that cannot be eta-reduced. See overhauled Note [Ticks and mandatory eta expansion]. - New Note [JoinId vs TailCallInfo] in GHC.Core.SimpleOpt that explains robustness of JoinId vs fragility of TailCallInfo. - Allow casts/non-soft-scoped ticks to occur in between a join point binder and a jump, but only in Core Prep. See Note [Join points, casts, and ticks] and Note [Join points, casts, and ticks... in Core Prep] in GHC.Core.Opt.Simplify.Iteration. Also update Core Lint to account for this. See Note [Linting join points with casts or ticks] in GHC.Core.Lint. - Update 'GHC.Core.Utils.mergeCaseAlts' to avoid pushing a cast in between a join point binding and its jumps. This fixes #26642. See the new (MC5) and (MC6) in Note [Merge Nested Cases]. - Update float out to properly handle source note ticks. They are now properly floated out instead of being discarded. This increases the number of ticks in certain tests with -g. Test cases: T26642 and TrickyJoins. Metric increase due to more source note ticks with -g: ------------------------- Metric Increase: libdir size_hello_artifact size_hello_unicode ------------------------- (cherry picked from commit 08bc245be70d95801bc1138804ed1de9474fbdc0) - - - - - 22 changed files: - compiler/GHC/Cmm/Node.hs - compiler/GHC/Core.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/FloatIn.hs - compiler/GHC/Core/Opt/FloatOut.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Config/Core/Lint.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/Id/Info.hs - compiler/GHC/Types/Tickish.hs - testsuite/tests/codeGen/should_compile/debug.stdout - + testsuite/tests/simplCore/should_compile/T26642.hs - + testsuite/tests/simplCore/should_compile/TrickyJoins.hs - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== compiler/GHC/Cmm/Node.hs ===================================== @@ -821,8 +821,8 @@ data CmmTickScope | SubScope !U.Unique CmmTickScope -- ^ Constructs a new sub-scope to an existing scope. This allows - -- us to translate Core-style scoping rules (see @tickishScoped@) - -- into the Cmm world. Suppose the following code: + -- us to translate Core-style scoping rules (see Note [Scoping ticks and counting ticks] + -- in GHC.Types.Tickish) into the Cmm world. Suppose the following code: -- -- tick<1> case ... of -- A -> tick<2> ... ===================================== compiler/GHC/Core.hs ===================================== @@ -1029,6 +1029,210 @@ tail position: A cast changes the type, but the type must be the same. But operationally, casts are vacuous, so this is a bit unfortunate! See #14610 for ideas how to fix this. +Note [Join points, casts, and ticks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Point (1) of Note [Invariants on join points] says that a join point +must always be tail called. But what precisely does "tail called" mean +in the presence of (a) casts and (b) ticks? + +Example (CAST) + let j x = rhs in + case y of { True -> j 1 |> co; False -> j 2 } + +Example (TICK) + let j x = rhs in + case y of { True -> <tick t> (j 1); False -> j 2 } + +Answer: in Core: + + (JCT1) A tail call cannot be under a cast. + + Thus, in (CAST), `j` is not a join point. + + (JCT2) A tail call cannot be under a cost-centre-scoped tick. + + Thus, in (TICK), `j` is a join point only if tick `t` has soft scope + (as per Note [Scoping ticks and counting ticks] in GHC.Tickish). + +The Big Reason for these choices is that the Simplifier moves the continuation +into the RHS of a join point, as explained in Note [Join points and case-of-case] +in GHC.Core.Opt.Simplify.Iteration: + + K[ join j x = rhs in body ] --> join j x = K[rhs] in K[body] + +and K then evaporates when it encounters the tail call: + + K[jump j v] --> jump j v + +These transformations: + * Are ill-typed if the tail is under a cast, hence (JCT1) + * Change cost semantics if the tick has cost-centre scope, hence (JCT2) + +The occurrence analyser is careful not to treat an occurrence as a tail call if +it falls under (JCT1) or (JCT2), by using 'markAllNonTail'. + +However, during /code generation/ the key thing about a join point is that + * The binding does no allocation + * A tail call can be implemented by "adjust stack pointer and jump". + +This code-gen strategy works fine even if the "tail call" occurs under +/arbitrary/ ticks and casts. Hence: + +(JCT3) In CorePrep, the occurrence analyser is called with a special flag that + /does/ treat `j` as tail-called in Example (CAST) and Example (TICK). + Core Prep then uses 'joinPointBinding_maybe', which turns always-tail-called + let bindings into join points, thus recovering join-point-hood. + +See also Note [Linting join points with casts or ticks] in GHC.Core.Lint. + +Examples +======== + + Join point jumps under ticks (#14242, #26157, #26642, #26693) + ============================ + In #26693 we had: + + join { j :: Bool -> Int -> IO (); j _ = guts } + in case b of + False -> scc<foo> jump j True + True -> jump j False + + If we try to push the application to an argument 'arg :: Int' into this + expression, we first get: + + join { j :: Bool -> IO (); j _ = guts arg ] } + in case b of + False -> (scc<foo> jump j True) arg + True -> jump j False arg + + We then rely on 'trimJoinCont' to remove the argument. In this case, this fails + for the first branch, because 'trimJoinCont' doesn't look through profiling + ticks. Were we to address this, it's still not clear what code we would want to + end up with, as we don't want to misattribute profiling costs. + We could plausibly transform to the following: + + join { j :: Bool -> IO (); j scc_or_null _ = (setSCC# scc_or_null guts) arg ] } + in case b of + False -> jump j <foo> True + True -> jump j null False + + where `setSCC#` is a new primop that would set the current cost centre pointer + (or no-op if the given pointer is null). However: + - this primop doesn't exist today, + - it requires adding an argument to the join point (hence changing its arity) + + Note that soft scope ticks are floated out by the simplifier (see the + 'tickishHasSoftScope' guard in 'GHC.Core.Opt.Simplify.Iteration.simplTick'), + so don't suffer from the same problem. + + Join point jumps under casts (#14610, #21716, #26422) + ============================ + Consider: + + newtype Age = MkAge Int -- axAge :: Age ~ Int + f :: Int -> ... + + f (join j :: Bool -> Age + j x = (rhs1 :: Age) + in case v of + Just x -> ((j x) |> axAge) :: Int + Nothing -> rhs2) + + If we try to use the case of case transformation to push 'f' inwards, we would + get: + + join j' x = f (rhs1 :: Age) + in case v of + Just x -> (j' x |> axAge) + Nothing -> f rhs2 + + which is utterly bogus, as we are now passing an argument of type 'Age' to + 'f', which expects an 'Int'. + + The alternative would be to implement a transformation of the form + + join { j x = blah } + in case e of + False -> j True |> co1 + True -> j False |> co2 + + ====> + + join { j x co = blah |> co } + in case e of + False -> j True co1 + True -> j False co2 + + by adding a coercion argument to the join point. We don't do this currently. + + +Note [Strict fields in Core] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Core, evaluating a data constructor worker evaluates its strict fields. + +In other words, let's say we have the following data type + + data T a b = MkT !a b + +Now if `xs` reduces to `error "boom"`, then `MkT xs b` will throw that error. +Consequently, it is sound to seq the field before the call to the constructor, +e.g., with `case xs of xs' { __DEFAULT -> MkT xs' b }`. +Let's call this transformation "field eval insertion". + +Note in particular that the data constructor application `MkT xs b` above is +*not* a value, unless `xs` is! + +This has pervasive effect on the Core pipeline: + +(SFC1) `exprIsHNF`/`exprIsConLike`/`exprOkForSpeculation` need to assert that the + strict arguments of a DataCon worker are values/ok-for-spec themselves. + +(SFC2) `exprIsConApp_maybe` inserts field evals in the `FloatBind`s it returns, so + that the Simplifier, Constant-folding, the pattern-match checker, etc. all + see the inserted field evals when they match on strict workers. + + For example, + exprIsConApp_maybe (MkT e1 e2) + = Just ([FloatCase e1 x], MkT, [x,e2]) + Meaning that (MkT e1 e2) is indeed a data constructor application, but if + you want to decompose it (which is the purpose of exprIsConApp_maybe) you + must evaluate e1 first. + In case of case-of-known constructor, we get the rewrite + case MkT e1 e2 of MkT xs' b' -> b' + ==> + case e1 of xs' { __DEFAULT -> e2 } + which crucially retains the eval on e1. + +(SFC3) The demand signature of a data constructor is strict in strict field + position and lazy in non-strict fields. Likewise the demand *transformer* + of a DataCon worker can stricten up demands on strict field args. + See Note [Demand transformer for data constructors]. + +(SFC4) In the absence of `-fpedantic-bottoms`, it is still possible that some seqs + are ultimately dropped or delayed due to eta-expansion. + See Note [Dealing with bottom]. + +Strict field semantics is exploited and lowered in STG during EPT enforcement; +see Note [EPT enforcement lowers strict constructor worker semantics] for the +connection. + +It might be tempting to think that strict fields could be implemented in terms +of unlifted fields. However, unlifted fields behave differently when the data +constructor is partially applied; see Note [exprIsHNF for function applications] +for an example. + +Historical Note: +The delightfully simple description of strict field semantics is the result of +a long saga (#20749, the bits about strict data constructors in #21497, #22475), +where we tried a more lenient (but actually not) semantics first that would +allow both strict and lazy implementations of DataCon workers. This was favoured +because the "pervasive effect" throughout the compiler was deemed too large +(when it really turned out to be quite modest). +Alas, this semantics would require us to implement `exprIsHNF` in *exactly* the +same way as above, otherwise the analysis would not be conservative wrt. the +lenient semantics (which includes the strict one). It is also much harder to +explain and maintain, as it turned out. + ************************************************************************ * * In/Out type synonyms ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -2,6 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE DerivingStrategies #-} {- (c) The University of Glasgow 2006 @@ -106,6 +107,7 @@ import qualified Data.IntMap.Strict as IntMap ( lookup, keys, empty, fromList ) import GHC.Data.Pair import GHC.Base (oneShot) import GHC.Data.Unboxed +import GHC.Types.Unique.Map {- Note [Core Lint guarantee] @@ -905,25 +907,19 @@ lintCoreExpr (Lit lit) = return (literalType lit, zeroUE) lintCoreExpr (Cast expr co) - = do (expr_ty, ue) <- markAllJoinsBad (lintCoreExpr expr) - -- markAllJoinsBad: see Note [Join points and casts] - to_ty <- lintCastExpr expr expr_ty co - return (to_ty, ue) + = do { (expr_ty, ue) <- markAllJoinsUnderCast (lintCoreExpr expr) + -- markAllJoinsUnderCast: see Note [Linting join points with casts or ticks] + ; to_ty <- lintCastExpr expr expr_ty co + ; return (to_ty, ue) } lintCoreExpr (Tick tickish expr) - = do case tickish of - Breakpoint _ _ ids _ -> forM_ ids $ \id -> do - checkDeadIdOcc id - lookupIdInScope id - _ -> return () - markAllJoinsBadIf block_joins $ lintCoreExpr expr - where - block_joins = not (tickish `tickishScopesLike` SoftScope) - -- TODO Consider whether this is the correct rule. It is consistent with - -- the simplifier's behaviour - cost-centre-scoped ticks become part of - -- the continuation, and thus they behave like part of an evaluation - -- context, but soft-scoped and non-scoped ticks simply wrap the result - -- (see Simplify.simplTick). + = do { case tickish of + Breakpoint { breakpointFVs = ids } -> forM_ ids $ \id -> do + checkDeadIdOcc id + () <$ lookupIdInScope id + lintIdOcc id 0 + _ -> return () + ; markAllJoinsUnderTick tickish $ lintCoreExpr expr } lintCoreExpr (Let (NonRec tv (Type ty)) body) | isTyVar tv @@ -999,22 +995,16 @@ lintCoreExpr e@(App _ _) ; return app_pair} where - skipTick t = case collectFunSimple e of - (Var v) -> etaExpansionTick v t - _ -> tickishFloatable t - (fun, args, _source_ticks) = collectArgsTicks skipTick e - -- We must look through source ticks to avoid #21152, for example: - -- - -- reallyUnsafePtrEquality - -- = \ @a -> - -- (src<loc> reallyUnsafePtrEquality#) - -- @Lifted @a @Lifted @a + skipTick t = + case collectFunSimple e of + Var v -> canCollectArgsThroughTick v t + _ -> tickishFloatable t + (fun, args, _ticks) = collectArgsTicks skipTick e + -- We must look through ticks, otherwise we may fail to spot a + -- saturated application. We use 'canCollectArgsThroughTicks', which is + -- the same predicate that Core Prep uses. -- - -- To do this, we use `collectArgsTicks tickishFloatable` to match - -- the eta expansion behaviour, as per Note [Eta expansion and source notes] - -- in GHC.Core.Opt.Arity. - -- Sadly this was not quite enough. So we now also accept things that CorePrep will allow. - -- See Note [Ticks and mandatory eta expansion] + -- See Note [Ticks and mandatory eta expansion] in GHC.CoreToStg.Prep. lintCoreExpr (Lam var expr) = markAllJoinsBad $ @@ -1114,9 +1104,9 @@ checkDeadIdOcc id = return () ------------------ -lintJoinBndrType :: LintedType -- Type of the body - -> LintedId -- Possibly a join Id - -> LintM () +lintJoinBndrType :: OutType -- Type of the body + -> OutId -- Possibly a join Id + -> LintM () -- Checks that the return type of a join Id matches the body -- E.g. join j x = rhs in body -- The type of 'rhs' must be the same as the type of 'body' @@ -1124,12 +1114,29 @@ lintJoinBndrType body_ty bndr | JoinPoint arity <- idJoinPointHood bndr , let bndr_ty = idType bndr , (bndrs, res) <- splitPiTys bndr_ty - = checkL (length bndrs >= arity - && body_ty `eqType` mkPiTys (drop arity bndrs) res) $ - hang (text "Join point returns different type than body") - 2 (vcat [ text "Join bndr:" <+> ppr bndr <+> dcolon <+> ppr (idType bndr) - , text "Join arity:" <+> ppr arity - , text "Body type:" <+> ppr body_ty ]) + = do let + ty_msg = + hang (text "Join point returns different type than body") + 2 (vcat [ text "Join bndr:" <+> ppr bndr <+> dcolon <+> ppr (idType bndr) + , text "Join arity:" <+> ppr arity + , text "Body type:" <+> ppr body_ty ]) + arity_msg = + hang (text "Join point is not saturated") + 2 (vcat [ text "Join bndr:" <+> ppr bndr <+> dcolon <+> ppr (idType bndr) + , text "Join arity:" <+> ppr arity + , text "Arguments:" <+> ppr bndrs ]) + + mb_join_info <- lookupJoinId bndr + case mb_join_info of + Nothing -> + pprPanic "lintJoinBndrType: valid join marked bad" (ppr bndr) + Just (_, occ_info) -> do + checkL (length bndrs >= arity) arity_msg + + -- See Note [Linting join points with casts or ticks] for why + -- we skip this check if there is an intervening cast. + unless (occ_info == JoinOccUnderCast) $ + ensureEqTys body_ty (mkPiTys (drop arity bndrs) res) ty_msg | otherwise = return () @@ -1140,11 +1147,11 @@ checkJoinOcc var n_args | JoinPoint join_arity_occ <- idJoinPointHood var = do { mb_join_arity_bndr <- lookupJoinId var ; case mb_join_arity_bndr of { - NotJoinPoint -> do { join_set <- getValidJoins - ; addErrL (text "join set " <+> ppr join_set $$ - invalidJoinOcc var) } ; + Nothing -> do { valid_joins <- getValidJoins + ; addErrL (text "valid joins:" <+> ppr valid_joins $$ + invalidJoinOcc var) } ; - JoinPoint join_arity_bndr -> + Just (join_arity_bndr, _join_occ) -> do { checkL (join_arity_bndr == join_arity_occ) $ -- Arity differs at binding site and occurrence @@ -1351,39 +1358,34 @@ checkLinearity body_ue lam_var = return body_ue' Nothing -> return body_ue -- A type variable -{- Note [Join points and casts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -You might think that this should be OK: - join j x = rhs - in (case e of - A -> alt1 - B x -> (jump j x) |> co) +{- Note [Linting join points with casts or ticks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As per Note [Join points, casts, and ticks] in GHC.Core, we have to be careful +when a cast or tick occurs in between a join point binding and a corresponding +join point occurrence. -You might think that, since the cast is ultimately erased, the jump to -`j` should still be OK as a join point. But no! See #21716. Suppose +Generally speaking: - newtype Age = MkAge Int -- axAge :: Age ~ Int - f :: Int -> ... -- f strict in it's first argument + - The simplifier cannot handle intervening casts or non-soft-scope ticks, so + we must check for that to avoid producing invalid Core. + - However, as per (JCT3), Core Prep **can** produce join points with + intervening casts or non-soft-scope ticks, which means we must expect them. -and consider the expression +Casts present an additional challenge. Consider for example: - f (join j :: Bool -> Age - j x = (rhs1 :: Age) - in case v of - Just x -> (j x |> axAge :: Int) - Nothing -> rhs2) + join { j :: Bool -> Age; j x = (blah :: Age) } + in case e of + False -> j True |> (co1 :: Age ~ Int) + True -> other :: Int -Then, if the Simplifier pushes the strict call into the join points -and alternatives we'll get +It is **not** the case that the type of 'blah' is the same as the type of +the body of the join point binding! Indeed: - join j' x = f (rhs1 :: Age) - in case v of - Just x -> j' x |> axAge - Nothing -> f rhs2 + - RHS of the join-point binding: blah :: Age + - The body of the join point has type Int. -Utterly bogus. `f` expects an `Int` and we are giving it an `Age`. -No no no. Casts destroy the tail-call property. Henc markAllJoinsBad -in the (Cast expr co) case of lintCoreExpr. +So we skip the 'exprType(join_rhs) == exprType(join_body)' check when casts +occur in between. Note [No alternatives lint check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2944,14 +2946,15 @@ data LintEnv = LE { le_flags :: LintFlags -- Linting the result of this pass , le_loc :: [LintLocInfo] -- Locations - , le_subst :: Subst -- Current TyCo substitution - -- See Note [Linting type lets] - -- /Only/ substitutes for type variables; - -- but might clone CoVars - -- We also use le_subst to keep track of - -- in-scope TyVars and CoVars (but not Ids) - -- Range of the Subst is LintedType/LintedCo + , le_subst :: Subst + -- Current substitution, for TyCoVars only. + -- Non-CoVar Ids don't appear in here, not even in the InScopeSet + -- Used for (a) cloning to avoid shadowing of TyCoVars, + -- so that eqType works ok + -- (b) substituting for let-bound tyvars, when we have + -- (let @a = Int -> Int in ...) + , le_ids :: VarEnv (Id, LintedType) -- In-scope Ids -- Used to check that occurrences have an enclosing binder. -- The Id is /pre-substitution/, used to check that @@ -2959,9 +2962,10 @@ data LintEnv -- The LintedType is used to return the type of the occurrence, -- without having to lint it again. - , le_joins :: IdSet -- Join points in scope that are valid - -- A subset of the InScopeSet in le_subst - -- See Note [Join points] + , le_joins :: UniqMap Id JoinOcc + -- ^ Join points in scope that are valid + -- A subset of the InScopeSet in le_subst + -- See Note [Join points] , le_ue_aliases :: NameEnv UsageEnv -- Assigns usage environments to the -- alias-like binders, as found in @@ -2978,6 +2982,7 @@ data LintFlags , lf_report_unsat_syns :: Bool -- ^ See Note [Linting type synonym applications] , lf_check_linearity :: Bool -- ^ See Note [Linting linearity] , lf_check_fixed_rep :: Bool -- See Note [Checking for representation polymorphism] + , lf_allow_weak_joins :: Bool -- ^ See Note [Linting join points with casts or ticks] } -- See Note [Checking StaticPtrs] @@ -3292,6 +3297,20 @@ data LintLocInfo | InCo Coercion -- Inside a coercion | InAxiom (CoAxiom Branched) -- Inside a CoAxiom +-- | Does this join point 'Id' occur inside a cast? +-- +-- See Note [Linting join points with casts or ticks]. +data JoinOcc + -- | A normal occurrence of a 'JoinId'. + = NormalJoinOcc + -- | An occurrence of a 'JoinId' with an intervening cast between the + -- join point binder definition and the jump. + | JoinOccUnderCast + deriving stock Eq +instance Outputable JoinOcc where + ppr NormalJoinOcc = text "Normal" + ppr JoinOccUnderCast = text "UnderCast" + data LintConfig = LintConfig { l_diagOpts :: !DiagOpts -- ^ Diagnostics opts , l_platform :: !Platform -- ^ Target platform @@ -3313,7 +3332,7 @@ initL cfg m env = LE { le_flags = l_flags cfg , le_subst = mkEmptySubst (mkInScopeSetList tcvs) , le_ids = mkVarEnv [(id, (id,idType id)) | id <- ids] - , le_joins = emptyVarSet + , le_joins = emptyUniqMap , le_loc = [] , le_ue_aliases = emptyNameEnv , le_platform = l_platform cfg @@ -3399,7 +3418,7 @@ inCasePat = LintM $ \ env errs -> fromBoxedLResult (Just (is_case_pat env), errs addInScopeId :: Id -> LintedType -> LintM a -> LintM a addInScopeId id linted_ty m = LintM $ \ env@(LE { le_ids = id_set, le_joins = join_set, le_ue_aliases = aliases }) errs -> - unLintM m (env { le_ids = extendVarEnv id_set id (id, linted_ty) + unLintM m (env { le_ids = extendVarEnv id_set id (id, linted_ty) , le_joins = add_joins join_set , le_ue_aliases = delFromNameEnv aliases (idName id) }) errs -- When shadowing an alias, we need to make sure the Id is no longer @@ -3408,8 +3427,8 @@ addInScopeId id linted_ty m -- Occurrences of 'x' in e2 shouldn't count as occurrences of e1. where add_joins join_set - | isJoinId id = extendVarSet join_set id -- Overwrite with new arity - | otherwise = delVarSet join_set id -- Remove any existing binding + | isJoinId id = addToUniqMap join_set id NormalJoinOcc -- Overwrite with new arity + | otherwise = delFromUniqMap join_set id -- Remove any existing binding getInScopeIds :: LintM (VarEnv (Id,LintedType)) getInScopeIds = LintM (\env errs -> fromBoxedLResult (Just (le_ids env), errs)) @@ -3425,13 +3444,35 @@ updateSubst subst' m markAllJoinsBad :: LintM a -> LintM a markAllJoinsBad m - = LintM $ \ env errs -> unLintM m (env { le_joins = emptyVarSet }) errs + = LintM $ \ env errs -> unLintM m (env { le_joins = emptyUniqMap }) errs + +-- | Mark all join points as occurring under a tick. +-- +-- See Note [Linting join points with casts or ticks]. +markAllJoinsUnderTick :: CoreTickish -> LintM a -> LintM a +markAllJoinsUnderTick tick m + = LintM $ \ env errs -> + let env' = if tickishHasSoftScope tick || lf_allow_weak_joins (le_flags env) + then env + else env { le_joins = emptyUniqMap } + in unLintM m env' errs + +-- | Mark all join points as occurring under a cast. +-- +-- See Note [Linting join points with casts or ticks]. +markAllJoinsUnderCast :: LintM a -> LintM a +markAllJoinsUnderCast m + = LintM $ \ env errs -> + let !env' = if lf_allow_weak_joins (le_flags env) + then env { le_joins = fmap (const JoinOccUnderCast) (le_joins env) } + else env { le_joins = emptyUniqMap } + in unLintM m env' errs markAllJoinsBadIf :: Bool -> LintM a -> LintM a markAllJoinsBadIf True m = markAllJoinsBad m markAllJoinsBadIf False m = m -getValidJoins :: LintM IdSet +getValidJoins :: LintM (UniqMap Id JoinOcc) getValidJoins = LintM (\ env errs -> fromBoxedLResult (Just (le_joins env), errs)) getSubst :: LintM Subst @@ -3474,14 +3515,14 @@ lookupIdInScope id_occ -- wired-in Ids after worker/wrapper -- So we simply disable the test in this case -lookupJoinId :: Id -> LintM JoinPointHood +lookupJoinId :: Id -> LintM (Maybe (JoinArity, JoinOcc)) -- Look up an Id which should be a join point, valid here -- If so, return its arity, if not return Nothing lookupJoinId id - = do { join_set <- getValidJoins - ; case lookupVarSet join_set id of - Just id' -> return (idJoinPointHood id') - Nothing -> return NotJoinPoint } + = do { valid_joins <- getValidJoins + ; case lookupUniqMap valid_joins id of + Just join_occ -> return $ Just (idJoinArity id, join_occ) + Nothing -> return Nothing } addAliasUE :: Id -> UsageEnv -> LintM a -> LintM a addAliasUE id ue thing_inside = LintM $ \ env errs -> ===================================== compiler/GHC/Core/Opt/Arity.hs ===================================== @@ -87,7 +87,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc -import Data.Maybe( isJust ) {- ************************************************************************ @@ -2835,21 +2834,6 @@ tryEtaReduce rec_ids bndrs body eval_sd ok_arg _ _ _ _ = Nothing --- | Can we eta-reduce the given function --- See Note [Eta reduction soundness], criteria (B), (J), and (W). -cantEtaReduceFun :: Id -> Bool -cantEtaReduceFun fun - = hasNoBinding fun -- (B) - -- Don't undersaturate functions with no binding. - - || isJoinId fun -- (J) - -- Don't undersaturate join points. - -- See Note [Invariants on join points] in GHC.Core, and #20599 - - || (isJust (idCbvMarks_maybe fun)) -- (W) - -- Don't undersaturate StrictWorkerIds. - -- See Note [CBV Function Ids] in GHC.Types.Id.Info. - {- ********************************************************************* * * ===================================== compiler/GHC/Core/Opt/FloatIn.hs ===================================== @@ -375,7 +375,7 @@ We don't float lets inwards past an SCC. -} fiExpr platform to_drop (_, AnnTick tickish expr) - | tickish `tickishScopesLike` SoftScope + | tickishHasSoftScope tickish = Tick tickish (fiExpr platform to_drop expr) | otherwise -- Wimp out for now - we could push values in ===================================== compiler/GHC/Core/Opt/FloatOut.hs ===================================== @@ -365,25 +365,28 @@ floatExpr lam@(Lam (TB _ lam_spec) _) (add_to_stats fs floats, floats, mkLams bndrs body') } floatExpr (Tick tickish expr) - | tickish `tickishScopesLike` SoftScope -- not scoped, can just float + -- If possible, float out past the tick + | let float_out_of_tick + -- See Note [Floating past breakpoints] + | Breakpoint{} <- tickish + = True + | otherwise + -- We can float code out of non-scoped ticks + = tickishHasNoScope tickish + , float_out_of_tick = case (floatExpr expr) of { (fs, floating_defns, expr') -> (fs, floating_defns, Tick tickish expr') } - | not (tickishCounts tickish) || tickishCanSplit tickish - = case (floatExpr expr) of { (fs, floating_defns, expr') -> - let -- Annotate bindings floated outwards past an scc expression - -- with the cc. We mark that cc as "duplicated", though. - annotated_defns = wrapTick (mkNoCount tickish) floating_defns + -- We can't move code out of the tick + | otherwise + = assert (not (tickishCounts tickish) || tickishCanSplit tickish) $ + case (floatExpr expr) of { (fs, floating_defns, expr') -> + -- Wrap floated code with the correct tick scope, but using 'mkNoCount' + -- to ensure we don't duplicate counters. + let annotated_defns = wrapTick (mkNoCount tickish) floating_defns in (fs, annotated_defns, Tick tickish expr') } - -- See Note [Floating past breakpoints] - | Breakpoint{} <- tickish - = case (floatExpr expr) of { (fs, floating_defns, expr') -> - (fs, floating_defns, Tick tickish expr') } - - | otherwise - = pprPanic "floatExpr tick" (ppr tickish) floatExpr (Cast expr co) = case (floatExpr expr) of { (fs, floating_defns, expr') -> @@ -661,7 +664,8 @@ partitionByLevel (Level major minor) (FB tops defns) wrapTick :: CoreTickish -> FloatBinds -> FloatBinds wrapTick t (FB tops defns) - = FB (mapBag wrap_bind tops) + = assert (not $ tickishCounts t) $ + FB (mapBag wrap_bind tops) (M.map (M.map wrap_defns) defns) where wrap_defns = mapBag wrap_one @@ -672,10 +676,13 @@ wrapTick t (FB tops defns) wrap_one (FloatLet bind) = FloatLet (wrap_bind bind) wrap_one (FloatCase e b c bs) = FloatCase (maybe_tick e) b c bs - maybe_tick e | exprIsHNF e = tickHNFArgs t e - | otherwise = mkTick t e - -- we don't need to wrap a tick around an HNF when we float it - -- outside a tick: that is an invariant of the tick semantics + maybe_tick + -- We don't need to wrap an SCC tick around HNFs that we floated out of + -- the SCC, as that is an invariant of the semantics for SCCs. -- Conversely, inlining of HNFs inside an SCC is allowed, and -- indeed the HNF we're floating here might well be inlined back -- again, and we don't want to end up with duplicate ticks. + | tickishPlace t == PlaceCostCentre + = mkTickNoHNF t + | otherwise + = mkTick t ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -27,7 +27,7 @@ core expression with (hopefully) improved usage information. module GHC.Core.Opt.OccurAnal ( occurAnalysePgm, - occurAnalyseExpr, + occurAnalyseExpr, occurAnalyseExpr_Prep, zapLambdaBndrs, BinderSwapDecision(..), scrutOkForBinderSwap ) where @@ -84,6 +84,15 @@ occurAnalyseExpr expr = expr' where WUD _ expr' = occAnal initOccEnv expr +-- | A version of 'occurAnalyseExpr' suitable for CorePrep. +-- +-- Different from 'occurAnalyseExpr' due to (JCT3) +-- in Note [Join points, casts, and ticks] in GHC.Core. +occurAnalyseExpr_Prep :: CoreExpr -> CoreExpr +occurAnalyseExpr_Prep expr = expr' + where + WUD _ expr' = occAnal (initOccEnv { occ_allow_weak_joins = True }) expr + occurAnalysePgm :: Module -- Used only in debug output -> (Id -> Bool) -- Active unfoldings -> (Activation -> Bool) -- Active rules @@ -2227,12 +2236,8 @@ occ_anal_lam_tail env (Cast expr co) Var {} | isRhsEnv env -> markAllMany usage1 _ -> usage1 - -- usage3: you might think this was not necessary, because of - -- the markAllNonTail in adjustTailUsage; but not so! For a - -- join point, adjustTailUsage doesn't do this; yet if there is - -- a cast, we must! Also: why markAllNonTail? See - -- GHC.Core.Lint: Note Note [Join points and casts] - usage3 = markAllNonTail usage2 + -- usage3: see (JCT1) in Note [Join points, casts, and ticks] in GHC.Core. + usage3 = markAllNonTail_CastOrTick env usage2 in WUD usage3 (Cast expr' co) @@ -2511,42 +2516,39 @@ But it is not necessary to gather CoVars from the types of other binders. -} occAnal env (Tick tickish body) - = WUD usage' (Tick tickish body') + = WUD usage2 (Tick tickish body') where WUD usage body' = occAnal env body - usage' - | tickish `tickishScopesLike` SoftScope - = usage -- For soft-scoped ticks (including SourceNotes) we don't want - -- to lose join-point-hood, so we don't mess with `usage` (#24078) + usage1 + -- We don't want to lose join-point-hood. We can move soft-scoped ticks + -- out of the way, so don't mess with `usage` (#24078). + | tickishHasSoftScope tickish + = usage - -- For a non-soft tick scope, we can inline lambdas only, so we - -- abandon tail calls, and do markAllInsideLam too: usage_lam + -- Otherwise, we can inline lambdas only, so use 'markAllInsideLam'. + | otherwise + = markAllNonTail_CastOrTick env $ markAllInsideLam usage + -- markAllNonTail_CastOrTick: abandon tail calls. + -- See (JCT2) in Note [Join points, casts, and ticks] in GHC.Core. - | Breakpoint _ _ ids _ <- tickish + usage2 + | Breakpoint { breakpointFVs = ids } <- tickish = -- Never substitute for any of the Ids in a Breakpoint - addManyOccs usage_lam (mkVarSet ids) + addManyOccs usage1 (mkVarSet ids) | otherwise - = usage_lam - - usage_lam = markAllNonTail (markAllInsideLam usage) - - -- TODO There may be ways to make ticks and join points play - -- nicer together, but right now there are problems: - -- let j x = ... in tick<t> (j 1) - -- Making j a join point may cause the simplifier to drop t - -- (if the tick is put into the continuation). So we don't - -- count j 1 as a tail call. - -- See #14242. + = usage1 occAnal env (Cast expr co) - = let (WUD usage expr') = occAnal env expr - usage1 = addManyOccs usage (coVarsOfCo co) - -- usage2: see Note [Gather occurrences of coercion variables] - usage2 = markAllNonTail usage1 - -- usage3: calls inside expr aren't tail calls any more - in WUD usage2 (Cast expr' co) + = let + WUD usage expr' = occAnal env expr + -- usage1: see Note [Gather occurrences of coercion variables] + usage1 = addManyOccs usage (coVarsOfCo co) + -- usage2: see (JCT1) in Note [Join points, casts, and ticks] in GHC.Core. + usage2 = markAllNonTail_CastOrTick env usage1 + in + WUD usage2 (Cast expr' co) occAnal env app@(App _ _) = occAnalApp env (collectArgsTicks tickishFloatable app) @@ -2849,6 +2851,11 @@ data OccEnv , occ_rule_act :: Activation -> Bool -- Which rules are active -- See Note [Finding rule RHS free vars] + , occ_allow_weak_joins :: !Bool + -- ^ Allow a join point jump to occur inside casts or profiling ticks? + -- + -- See (JCT3) in Note [Join points, casts, and ticks] in GHC.Core.Opt. + -- See Note [The binder-swap substitution] -- If x :-> (y, co) is in the env, -- then please replace x by (y |> mco) @@ -2912,6 +2919,8 @@ initOccEnv , occ_unf_act = \_ -> True , occ_rule_act = \_ -> True + , occ_allow_weak_joins = False + , occ_join_points = emptyVarEnv , occ_bs_env = emptyVarEnv , occ_bs_rng = emptyVarSet } @@ -2934,6 +2943,15 @@ setScrutCtxt !env alts -- non-default alternative. That in turn influences -- pre/postInlineUnconditionally. Grep for "occ_int_cxt"! +-- | Mark occurrences under a cast/non-soft-scope tick as non-tail-called, +-- except if 'occ_allow_weak_joins = True'. +-- +-- See Note [Join points, casts, and ticks] in GHC.Core. +markAllNonTail_CastOrTick :: OccEnv -> UsageDetails -> UsageDetails +markAllNonTail_CastOrTick env = + markAllNonTailIf + (not $ occ_allow_weak_joins env) + {- Note [The OccEnv for a right hand side] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ How do we create the OccEnv for a RHS (in mkRhsOccEnv)? @@ -3981,7 +3999,10 @@ okForJoinPoint :: TopLevelFlag -> Id -> TailCallInfo -> Bool -- See Note [Invariants on join points]; invariants cited by number below. -- Invariant 2 is always satisfiable by the simplifier by eta expansion. okForJoinPoint lvl bndr tail_call_info - | isJoinId bndr -- A current join point should still be one! + -- A current join point should still be one! + -- + -- See Note [JoinId vs TailCallInfo] in GHC.Core.SimpleOpt. + | isJoinId bndr = warnPprTrace lost_join "Lost join point" lost_join_doc $ True | valid_join ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -809,9 +809,9 @@ prepareRhs env top_lvl occ rhs0 = return (emptyLetFloats, Var fun) anfise (Tick t rhs) - -- We want to be able to float bindings past this - -- tick. Non-scoping ticks don't care. - | tickishScoped t == NoScope + -- We want to be able to float bindings past this tick. + -- Non-scoping ticks don't care. + | tickishHasNoScope t = do { (floats, rhs') <- anfise rhs ; return (floats, Tick t rhs') } @@ -1407,7 +1407,7 @@ simplTick env tickish expr cont -- bottom, then rebuildCall will discard the continuation. -------------------------- --- | tickishScoped tickish && not (tickishCounts tickish) +-- | not (tickishHasNoScope tickish) && not (tickishCounts tickish) -- = simplExprF env expr (TickIt tickish cont) -- XXX: we cannot do this, because the simplifier assumes that -- the context can be pushed into a case with a single branch. e.g. @@ -1419,12 +1419,11 @@ simplTick env tickish expr cont -- simplifier iterations that necessary in some cases. -------------------------- - -- For unscoped or soft-scoped ticks, we are allowed to float in new - -- cost, so we simply push the continuation inside the tick. This - -- has the effect of moving the tick to the outside of a case or - -- application context, allowing the normal case and application - -- optimisations to fire. - | tickish `tickishScopesLike` SoftScope + -- For soft-scoped ticks, we are allowed to float in new cost, so we simply + -- push the continuation inside the tick. This has the effect of moving the + -- tick to the outside of a case or application context, allowing the normal + -- 'case' and 'application' optimisations to fire. + | tickishHasSoftScope tickish = do { (floats, expr') <- simplExprF env expr cont ; return (floats, mkTick tickish expr') } @@ -1453,14 +1452,14 @@ simplTick env tickish expr cont _other -> Nothing where (ticks, expr0) = stripTicksTop movable (Tick tickish expr) movable t = not (tickishCounts t) || - t `tickishScopesLike` NoScope || + tickishHasNoScope t || tickishCanSplit t tickScrut e = foldr mkTick e ticks -- Alternatives get annotated with all ticks that scope in some way, -- but we don't want to count entries. tickAlt (Alt c bs e) = Alt c bs (foldr mkTick e ts_scope) ts_scope = map mkNoCount $ - filter (not . (`tickishScopesLike` NoScope)) ticks + filter (not . tickishHasNoScope) ticks no_floating_past_tick = do { let (inc,outc) = splitCont cont @@ -2167,16 +2166,15 @@ evaluation context E): As is evident from the example, there are two components to this behavior: - 1. When entering the RHS of a join point, copy the context inside. - 2. When a join point is invoked, discard the outer context. + (wrapJoinCont) When entering the RHS of a join point, copy the context inside. + (trimJoinCont) When a join point is invoked, discard the outer context. We need to be very careful here to remain consistent---neither part is optional! -We need do make the continuation E duplicable (since we are duplicating it) +We need to make the continuation E duplicable (since we are duplicating it) with mkDupableCont. - Note [Join points with -fno-case-of-case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Supose case-of-case is switched off, and we are simplifying @@ -2200,7 +2198,8 @@ case-of-case we may then end up with this totally bogus result This would be OK in the language of the paper, but not in GHC: j is no longer a join point. We can only do the "push continuation into the RHS of the join point j" if we also push the continuation right down to the /jumps/ to -j, so that it can evaporate there. If we are doing case-of-case, we'll get to +j, so that it can evaporate there (trimJoinCont). Then, if we are doing +case-of-case, we'll get to: join x = case <j-rhs> of <outer-alts> in case y of @@ -3612,9 +3611,11 @@ addBinderUnfolding env bndr unf = modifyInScope env (bndr `setIdUnfolding` unf) zapBndrOccInfo :: Bool -> Id -> Id --- Consider case e of b { (a,b) -> ... } --- Then if we bind b to (a,b) in "...", and b is not dead, --- then we must zap the deadness info on a,b +-- ^ Consider: +-- > case e of e' { (a,b) -> rhs } +-- +-- We bind @e'@ to @(a,b)@ in @rhs@. If @e'@ is not dead, +-- then we must zap the deadness info on @a@ and @b@. zapBndrOccInfo keep_occ_info pat_id | keep_occ_info = pat_id | otherwise = zapIdOccInfo pat_id ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -2669,7 +2669,7 @@ mkCase, mkCase1, mkCase2, mkCase3 mkCase mode scrut outer_bndr alts_ty alts | sm_case_merge mode - , Just (joins, alts') <- mergeCaseAlts outer_bndr alts + , Just (joins, alts') <- mergeCaseAlts scrut outer_bndr alts = do { tick (CaseMerge outer_bndr) ; case_expr <- mkCase1 mode scrut outer_bndr alts_ty alts' ; return (mkLets joins case_expr) } ===================================== compiler/GHC/Core/SimpleOpt.hs ===================================== @@ -381,7 +381,7 @@ simple_app env e@(Lam {}) as@(_:_) simple_app env (Tick t e) as -- Okay to do "(Tick t e) x ==> Tick t (e x)"? - | t `tickishScopesLike` SoftScope + | tickishHasSoftScope t = mkTick t $ simple_app env e as -- (let x = e in b) a1 .. an => let x = e in (b a1 .. an) @@ -914,23 +914,33 @@ and again its arity increases (#15517) -} --- | Returns Just (bndr,rhs) if the binding is a join point: --- If it's a JoinId, just return it --- If it's not yet a JoinId but is always tail-called, --- make it into a JoinId and return it. +-- | Returns @Just (bndr, rhs)@ if the binding is a join point, or can be made +-- into a join poin. Returns @Nothing@ otherwise. +-- +-- - If the input binder is a 'JoinId', just return it; +-- - if it's not yet a 'JoinId' but is always tail-called, +-- make it into a 'JoinId' and return that. +-- -- In the latter case, eta-expand the RHS if necessary, to make the --- lambdas explicit, as is required for join points +-- lambdas explicit, as is required for join points. +-- +-- Precondition: the 'TailCallInfo' of the 'InBndr' is conservative: -- --- Precondition: the InBndr has been occurrence-analysed, --- so its OccInfo is valid +-- - if it says 'AlwaysTailCalled', it is definitely always tail called, +-- - if it says 'NoTailCallInfo', then we're not sure. +-- +-- See Note [JoinId vs TailCallInfo]. joinPointBinding_maybe :: InBndr -> InExpr -> Maybe (InBndr, InExpr) joinPointBinding_maybe bndr rhs | not (isId bndr) = Nothing + -- Being a JoinId is robust: preserve that. See Note [JoinId vs TailCallInfo]. | isJoinId bndr = Just (bndr, rhs) + -- If the 'TailCallInfo' of 'bndr' says 'AlwaysTailCalled', then we know for + -- sure that it can be made into a join point. | AlwaysTailCalled join_arity <- tailCallInfo (idOccInfo bndr) , (bndrs, body) <- etaExpandToJoinPoint join_arity rhs , let str_sig = idDmdSig bndr @@ -946,6 +956,48 @@ joinPointBindings_maybe :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)] joinPointBindings_maybe bndrs = mapM (uncurry joinPointBinding_maybe) bndrs +{- Note [JoinId vs TailCallInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Occurrence information is /fundamentally fragile/; that is, it may + be invalidated by the Simplifier. + Example 1: + \y -> let x = y in ...x..x... + Here `y` is marked "occurs exactly once" but, after inlining `x`, + `y` now occurs many times. + Example 2: + f (let h x = ... in case y of { True -> h 1; False -> h 2 }) + Here `h` is tail-called; but if `f` is strict we could transform to + let h x = ... in + case y of { True -> f (h 1); False -> f (h 2) } + Now `h` is not tail called any more. + + Exception: Dead things (with no occurrences) usually stay dead. + There are exceptions e.g. + case x of y { (a,b) -> case y of (p,q) -> p } + Here `a` and `b` look dead, but we may well transform to + case x of y { (a,b) -> a } + + Because occurrence info is fragile, we recompute occurrence info + (including tail call info) before each run of the Simplifier. + + Whenever the simplifier performs a transformation that **might** invalidate + occurrence information, it calls 'zapFragileIdInfo'. This sets the + 'TailCallInfo' to 'NoTailCallInfo' (among other things). + +* Being a JoinId is /robust/, and is rigorously maintained by the + Simplifier. In Example 2 above, if `h` was marked as a JoinId, + that transformation would not have happened. Instead we'd have + transformed to + let h x = f (...) in + case y of { True -> h 1; False -> h 2 } + + The Simplifier takes an Id whose occurrences are marked as + `AlwaysTailCalled` and turns it into robust `JoinId`. This is + done by `joinPointBinding_maybe`. + + There is one exception: float-out, the only caller of 'zapJoinId'. + See Note [Zapping JoinId when floating]. +-} {- ********************************************************************* * * ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -32,7 +32,8 @@ module GHC.Core.Utils ( isCheapApp, isExpandableApp, isSaturatedConApp, exprIsTickedString, exprIsTickedString_maybe, exprIsTopLevelBindable, - altsAreExhaustive, etaExpansionTick, + altsAreExhaustive, + canCollectArgsThroughTick, cantEtaReduceFun, -- * Equality cheapEqExpr, cheapEqExpr', diffBinds, @@ -71,7 +72,7 @@ import GHC.Platform import GHC.Core import GHC.Core.Ppr -import GHC.Core.FVs( bindFreeVars ) +import GHC.Core.FVs( bindFreeVars, exprFreeVars ) import GHC.Core.DataCon import GHC.Core.Type as Type import GHC.Core.Predicate( isCoVarType ) @@ -650,11 +651,12 @@ filters down the matching alternatives in GHC.Core.Opt.Simplify.rebuildCase. -} --------------------------------- -mergeCaseAlts :: Id -> [CoreAlt] -> Maybe ([CoreBind], [CoreAlt]) +mergeCaseAlts :: CoreExpr -> Id -> [CoreAlt] -> Maybe ([CoreBind], [CoreAlt]) -- See Note [Merge Nested Cases] -mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts) +mergeCaseAlts scrut outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts) | Just (joins, inner_alts) <- go deflt_rhs - = Just (joins, mergeAlts outer_alts inner_alts) + , Just aux_binds <- mk_aux_binds joins + = Just (aux_binds ++ joins, mergeAlts outer_alts inner_alts ) -- NB: mergeAlts gives priority to the left -- case x of -- A -> e1 @@ -664,6 +666,19 @@ mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts) -- When we merge, we must ensure that e1 takes -- precedence over e2 as the value for A! where + scrut_fvs = exprFreeVars scrut + -- See Note [Floating join points out of DEFAULT alternatives] + mk_aux_binds join_binds + | not (any mentions_outer_bndr join_binds) + = Just [] -- Good! No auxiliary bindings needed + | exprIsTrivial scrut + , not (outer_bndr `elemVarSet` scrut_fvs) + = Just [NonRec outer_bndr scrut] -- Need a fixup binding + | otherwise + = Nothing -- Can't do it + + mentions_outer_bndr bind = outer_bndr `elemVarSet` bindFreeVars bind + go :: CoreExpr -> Maybe ([CoreBind], [CoreAlt]) -- Whizzo: we can merge! @@ -687,7 +702,7 @@ mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts) , Just tc <- tyConAppTyCon_maybe type_arg , Just (dc1:dcs) <- tyConDataCons_maybe tc -- At least one data constructor , dcs `lengthAtMost` 3 -- Arbitrary - = return ( [], mk_alts dc1 dcs) + = return ([], mk_alts dc1 dcs) where mk_lit dc = mkLitIntUnchecked $ toInteger $ dataConTagZ dc mk_rhs dc = Var (dataConWorkId dc) @@ -709,15 +724,20 @@ mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts) | otherwise = Nothing - -- We don't want ticks to get in the way; just push them inwards. - -- (This happens when you add SourceTicks e.g. GHC.Num.Integer.integerLt#) + -- Push ticks **inwards** (when possible). + -- See (MC5) in Note [Merge Nested Cases]. go (Tick t body) - = do { (joins, alts) <- go body - ; return (joins, [Alt con bs (Tick t rhs) | Alt con bs rhs <- alts]) } + = do { (joins, alts) <- go body -- (MC4): any join points inside are floated out of the tick. + + -- Abort if this would put a non-soft-scope tick in between + -- a join point binding and its jumps. See (MC6). + ; guard $ null joins || tickishHasSoftScope t + ; return (joins, [Alt con bs (mkTick t rhs) | Alt con bs rhs <- alts]) + } go _ = Nothing -mergeCaseAlts _ _ = Nothing +mergeCaseAlts _ _ _ = Nothing --------------------------------- mergeAlts :: [Alt a] -> [Alt a] -> [Alt a] @@ -924,9 +944,74 @@ Wrinkles So `mergeCaseAlts` floats out any join points. It doesn't float out non-join-points unless the /outer/ case has just one alternative; doing - so would risk more allocation + so would risk more allocation. + + Note also that `mergeCaseAlts` floats join points out of ticks, for which + we need to be extra careful; see (MC6). + + Floating out join points isn't entirely straightforward. + See Note [Floating join points out of DEFAULT alternatives] + +(MC5) We want to move ticks out of the way if possible, to prevent them from + inhibiting optimisation. For example, say we have: + + case expensive of r { + C1 -> rhs1; -- happy path + _ -> scctick<doEdgeCase> (case r of { C2 -> rhs2; C3 -> rhs3 }) + } + + In this situation, we push the "doEdgeCase" tick **inwards** and proceed + to merge cases, like so: + + case expensive of + C1 -> rhs1 + C2 -> scctick<doEdgeCase> rhs2 + C3 -> scctick<doEdgeCase> rhs3 + + This preserves the tick semantics (see Note [Scoping ticks and counting ticks] + in GHC.Types.Tickish), because this transformation: + + 1. preserves counts, + 2. does not move cost in or out of the tick scope. + + (1) is clear: we will tick 'doEdgeCase' exactly in the C2/C3 alternatives, + and we won't otherwise. + For (2), recall that case is strict in Core. We already evaluated 'expensive', + so re-scrutinising 'r' is free. + + This means that, perhaps surprisingly, this transformation is valid for + **all** ticks, including non-floatable ones. + + In contrast, we would not want to move the tick outwards, because this: + + - will lead to additional counting of 'doEdgeCase' in the 'C1' (happy path) case, + - risks attributing the cost of evaluating 'expensive' to 'doEdgeCase'. + +(MC6) There is a dangerous interaction between (MC4) and (MC5), which can lead + to invalid Core (as reported in #26642, #26929). Suppose we have: + + case f x of r -> + scctick<foo> + join j y = rhs in + case r of { C1 -> j 1; C2 -> bar } + + If we naively carried out (MC4) and (MC5) together, this would result in: + + join j y = rhs in + case f x of + C1 -> scctick<foo> (j 1) + C2 -> scctick<foo> bar + + This has moved the tick in between the join point binding 'j' and the + join point jump, which is invalid as per Note [Join points, casts, and ticks] + in GHC.Core. The simplifier cannot deal with such Core, resulting in #26642. + + The solution: abort whenever we would position a non-soft-scope tick + inside a join point in this manner. + An alternative would be to float the tick outwards, but as we saw in (MC5) + this risks a grave misattribution of profiling costs, so we don't do that. -(MC5) See Note [Cascading case merge] +(MC7) See Note [Cascading case merge] See also Note [Example of case-merging and caseRules] in GHC.Core.Opt.Simplify.Utils @@ -1953,14 +2038,31 @@ altsAreExhaustive (Alt con1 _ _ : alts) -- we behave conservatively here -- I don't think it's important -- enough to deserve special treatment --- | Should we look past this tick when eta-expanding the given function? +-- | Should we look past this tick when collecting arguments +-- for the given function? -- -- See Note [Ticks and mandatory eta expansion] --- Takes the function we are applying as argument. -etaExpansionTick :: Id -> GenTickish pass -> Bool -etaExpansionTick id t - = hasNoBinding id && - ( tickishFloatable t || isProfTick t ) +canCollectArgsThroughTick + :: Id -- ^ function at the head of the application + -> GenTickish pass -- ^ tick we want to collect arguments past + -> Bool +canCollectArgsThroughTick id t + = tickishFloatable t || cantEtaReduceFun id + +-- | Can we eta-reduce the given function? +-- See Note [Eta reduction soundness], criteria (B), (J), and (W). +cantEtaReduceFun :: Id -> Bool +cantEtaReduceFun fun + = hasNoBinding fun -- (B) + -- Don't undersaturate functions with no binding. + + || isJoinId fun -- (J) + -- Don't undersaturate join points. + -- See Note [Invariants on join points] in GHC.Core, and #20599 + + || isJust (idCbvMarks_maybe fun) -- (W) + -- Don't undersaturate StrictWorkerIds. + -- See Note [CBV Function Ids: overview] in GHC.Types.Id.Info. {- Note [exprOkForSpeculation and type classes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -41,7 +41,8 @@ import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.TyCon import GHC.Core.DataCon -import GHC.Core.Opt.OccurAnal +import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr_Prep ) +import GHC.Core.SimpleOpt ( joinPointBinding_maybe, joinPointBindings_maybe ) import GHC.Data.Maybe import GHC.Data.OrdList @@ -628,7 +629,18 @@ cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind Maybe CoreBind) -- Just bind' <=> returned new bind; no float -- Nothing <=> added bind' to floats instead cpeBind top_lvl env (NonRec bndr rhs) - | not (isJoinId bndr) + -- A join point. + -- NB: use 'joinPointBinding_maybe' instead of 'isJoinId' as per the plan + -- described in (JCT3) in Note [Join points, casts, and ticks]. + | Just (bndr, rhs) <- joinPointBinding_maybe bndr rhs + = assert (not (isTopLevel top_lvl)) $ -- can't have top-level join point; see Note [Join points and floating] + do { (_, bndr1) <- cpCloneBndr env bndr + ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs + ; return (extendCorePrepEnv env bndr bndr2, + emptyFloats, + Just (NonRec bndr2 rhs1)) } + + | otherwise = do { (env1, bndr1) <- cpCloneBndr env bndr ; let dmd = idDemandInfo bndr is_unlifted = isUnliftedType (idType bndr) @@ -648,16 +660,23 @@ cpeBind top_lvl env (NonRec bndr rhs) ; return (env2, floats1, Nothing) } - | otherwise -- A join point; see Note [Join points and floating] - = assert (not (isTopLevel top_lvl)) $ -- can't have top-level join point - do { (_, bndr1) <- cpCloneBndr env bndr - ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs - ; return (extendCorePrepEnv env bndr bndr2, - emptyFloats, - Just (NonRec bndr2 rhs1)) } - cpeBind top_lvl env (Rec pairs) - | not (isJoinId (head bndrs)) + -- A recursive join point. + -- NB: use 'joinPointBindings_maybe' instead of 'isJoinId' as per the plan + -- described in (JCT3) in Note [Join points, casts, and ticks]. + | Just pairs <- joinPointBindings_maybe pairs + , let (bndrs, rhss) = unzip pairs + = do { (env, bndrs1) <- cpCloneBndrs env bndrs + ; let env' = enterRecGroupRHSs env bndrs1 + ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss + + ; let bndrs2 = map fst pairs1 + -- use env below, so that we reset cpe_rec_ids + ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2), + emptyFloats, + Just (Rec pairs1)) } + | otherwise + , let (bndrs, rhss) = unzip pairs = do { (env, bndrs1) <- cpCloneBndrs env bndrs ; let env' = enterRecGroupRHSs env bndrs1 ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env') @@ -680,19 +699,9 @@ cpeBind top_lvl env (Rec pairs) (Float (Rec all_pairs) LetBound TopLvlFloatable), Nothing) } - | otherwise -- See Note [Join points and floating] - = do { (env, bndrs1) <- cpCloneBndrs env bndrs - ; let env' = enterRecGroupRHSs env bndrs1 - ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss - - ; let bndrs2 = map fst pairs1 - -- use env below, so that we reset cpe_rec_ids - ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2), - emptyFloats, - Just (Rec pairs1)) } where - (bndrs, rhss) = unzip pairs - + -- See Note [Join points and floating] + -- -- Flatten all the floats, and the current -- group into a single giant Rec add_float (Float bind bound _) prs2 @@ -707,7 +716,6 @@ cpeBind top_lvl env (Rec pairs) Rec prs1 -> prs1 ++ prs2 add_float f _ = pprPanic "cpeBind" (ppr f) - --------------- cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool -> CorePrepEnv -> OutId -> CoreExpr @@ -715,7 +723,7 @@ cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool -- Used for all bindings -- The binder is already cloned, hence an OutId cpePair top_lvl is_rec dmd is_unlifted env bndr rhs - = assert (not (isJoinId bndr)) $ -- those should use cpeJoinPair + = assert (isNothing $ joinPointBinding_maybe bndr rhs) $ -- those should use cpeJoinPair do { (floats1, rhs1) <- cpeRhsE env rhs -- See if we are allowed to float this stuff out of the RHS @@ -976,7 +984,7 @@ rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody) -- Remove top level lambdas by let-binding rhsToBody (Tick t expr) - | tickishScoped t == NoScope -- only float out of non-scoped annotations + | tickishHasNoScope t -- only float out of non-scoped annotations = do { (floats, expr') <- rhsToBody expr ; return (floats, mkTick t expr') } @@ -1034,43 +1042,74 @@ instance Outputable ArgInfo where {- Note [Ticks and mandatory eta expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Something like - `foo x = ({-# SCC foo #-} tagToEnum#) x :: Bool` -caused a compiler panic in #20938. Why did this happen? -The simplifier will eta-reduce the rhs giving us a partial -application of tagToEnum#. The tick is then pushed inside the -type argument. That is we get - `(Tick<foo> tagToEnum#) @Bool` +We must look through ticks when they get in the way of seeing the arguments to +'Id's that cannot be eta-reduced. + +For example, we may have + + myReallyUnsafePtrEquality + = \ @a x y -> + (src<loc> reallyUnsafePtrEquality#) + @Lifted @a @Lifted @a x y + +If we don't move the SourceNote out of the way, this looks like an unsaturated +occurrence of the PrimOp "reallyUnsafePtrEquality#", which we cannot generate +code for. + +Moreover, we must also move out non-floatable ticks. Case in point: #20938, +of the form: + + foo x = ({-# SCC foo #-} tagToEnum#) x :: Bool + +If we don't look past the tick "foo", the simplifier will eta-reduce the RHS, +giving us a partial application of 'tagToEnum#'. The tick is then pushed inside +the type argument, resulting in: + + (Tick<foo> tagToEnum#) @Bool + CorePrep would go on to see a undersaturated tagToEnum# application -and eta expand the expression under the tick. Giving us: +and eta-expand the expression under the tick. Giving us: + (Tick<scc> (\forall a. x -> tagToEnum# @a x) @Bool -Suddenly tagToEnum# is applied to a polymorphic type and the code generator + +Suddenly, 'tagToEnum#' is applied to a polymorphic type and the code generator panics as it needs a concrete type to determine the representation. -The problem in my eyes was that the tick covers a partial application -of a primop. There is no clear semantic for such a construct as we can't -partially apply a primop since they do not have bindings. -We fix this by expanding the scope of such ticks slightly to cover the body -of the eta-expanded expression. - -We do this by: -* Checking if an application is headed by a primOpish thing. -* If so we collect floatable ticks and usually but also profiling ticks - along with regular arguments. -* When rebuilding the application we check if any profiling ticks appear - before the primop is fully saturated. -* If the primop isn't fully satured we eta expand the primop application - and scope the tick to scope over the body of the saturated expression. - -Going back to #20938 this means starting with - `(Tick<foo> tagToEnum#) @Bool` -we check if the function head is a primop (yes). This means we collect the -profiling tick like if it was floatable. Giving us - (tagToEnum#, [CpeTick foo, CpeApp @Bool]). +The problem was that the tick covered a partial application of a primop. +There is no clear semantic for such a construct: we can't partially apply a +primop, since primops do not have bindings. + +To fix this, we expand the scope of ticks slightly to cover the body +of the eta-expanded expression, even when the tick isn't normally floatable. + +This is achieved by using 'GHC.Core.Utils.canCollectArgsThroughTick', which +responds 'True' in the following two situations: + + - The tick is floatable (i.e. satisfies 'tickishFloatable'), meaning that it + is OK to float it out slightly, moving in more code under it. + See also Note [Eta expansion and source notes] in GHC.Core.Opt.Arity. + - The tick is around an application that is headed by an 'Id' that cannot be + undersaturated, such as a PrimOp (see 'GHC.Core.Utils.cantEtaReduceFun'). + +This solves #20938. Indeed, starting with + + (scctick<foo> tagToEnum#) @Bool + +we see that the head of the application is 'tagToEnum#', which is a PrimOp and +thus satisfies 'hasNoBinding = True'. As a result, we collect the profiling tick +as if it was floatable, resulting in + + (tagToEnum#, [CpeTick foo, CpeApp @Bool]) + cpe_app filters out the tick as a underscoped tick on the expression -`tagToEnum# @Bool`. During eta expansion we then put that tick back onto the -body of the eta-expansion lambdas. Giving us `\x -> Tick<foo> (tagToEnum# @Bool x)`. +`tagToEnum# @Bool`. During eta-expansion, we put that tick back onto the +body of the eta-expansion lambda, resulting in + + \x -> scctick<foo> (tagToEnum# @Bool x) + +which is unproblematic. -} + cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) -- May return a CpeRhs (instead of CpeApp) because of saturating primops cpeApp top_env expr @@ -1095,15 +1134,14 @@ cpeApp top_env expr go (Cast fun co) as = go fun (AICast co : as) go (Tick tickish fun) as - -- Profiling ticks are slightly less strict so we expand their scope - -- if they cover partial applications of things like primOps. - -- See Note [Ticks and mandatory eta expansion] - -- Here we look inside `fun` before we make the final decision about - -- floating the tick which isn't optimal for perf. But this only makes - -- a difference if we have a non-floatable tick which is somewhat rare. + -- Try to move a tick out of the way, if: + -- - the tick can be floated out of the way ('tickishFloatable'), or + -- - the tick must be moved out of the way because it stands in between + -- an 'Id' that must be saturated and some of its arguments; + -- see Note [Ticks and mandatory eta expansion]. | Var vh <- head - , Var head' <- lookupCorePrepEnv top_env vh - , etaExpansionTick head' tickish + , Just head' <- getIdFromTrivialExpr_maybe (lookupCorePrepEnv top_env vh) + , canCollectArgsThroughTick head' tickish = (head,as') where (head,as') = go fun (AITick tickish : as) @@ -1181,7 +1219,10 @@ cpeApp top_env expr hd = getIdFromTrivialExpr_maybe e2 -- Determine number of required arguments. See Note [Ticks and mandatory eta expansion] min_arity = case hd of - Just v_hd -> if hasNoBinding v_hd then Just $! (idArity v_hd) else Nothing + Just v_hd -> + if cantEtaReduceFun v_hd + then Just $! idArity v_hd + else Nothing Nothing -> Nothing -- ; pprTraceM "cpe_app:stricts:" (ppr v <+> ppr args $$ ppr stricts $$ ppr (idCbvMarks_maybe v)) ; (app, floats, unsat_ticks) <- rebuild_app env args e2 emptyFloats stricts min_arity @@ -2259,8 +2300,8 @@ deFloatTop floats get b _ = pprPanic "deFloatTop" (ppr b) -- See Note [Dead code in CorePrep] - get_bind (NonRec x e) = NonRec x (occurAnalyseExpr e) - get_bind (Rec xes) = Rec [(x, occurAnalyseExpr e) | (x, e) <- xes] + get_bind (NonRec x e) = NonRec x (occurAnalyseExpr_Prep e) + get_bind (Rec xes) = Rec [(x, occurAnalyseExpr_Prep e) | (x, e) <- xes] --------------------------------------------------------------------------- ===================================== compiler/GHC/Driver/Config/Core/Lint.hs ===================================== @@ -126,7 +126,8 @@ perPassFlags dflags pass , lf_check_inline_loop_breakers = check_lbs , lf_check_static_ptrs = check_static_ptrs , lf_check_linearity = check_linearity - , lf_check_fixed_rep = check_fixed_rep } + , lf_check_fixed_rep = check_fixed_rep + , lf_allow_weak_joins = allow_weak_joins } where -- In the output of the desugarer, before optimisation, -- we have eta-expanded data constructors with representation-polymorphic @@ -169,6 +170,12 @@ perPassFlags dflags pass CoreDesugar -> True _ -> False) + + -- See Note [Linting join points with casts or ticks] in GHC.Core.Lint + allow_weak_joins = case pass of + CorePrep -> True + _ -> False + initLintConfig :: DynFlags -> [Var] -> LintConfig initLintConfig dflags vars =LintConfig { l_diagOpts = initDiagOpts dflags @@ -184,4 +191,5 @@ defaultLintFlags dflags = LF { lf_check_global_ids = False , lf_check_linearity = gopt Opt_DoLinearCoreLinting dflags , lf_report_unsat_syns = True , lf_check_fixed_rep = True + , lf_allow_weak_joins = False } ===================================== compiler/GHC/Iface/Tidy.hs ===================================== @@ -1353,7 +1353,7 @@ tidyTopIdInfo rhs_tidy_env name rhs_ty orig_rhs tidy_rhs idinfo show_unfold is_external = isExternalName name --------- OccInfo ------------ - robust_occ_info = zapFragileOcc (occInfo idinfo) + robust_occ_info = zapFragileOccInfo (occInfo idinfo) -- It's important to keep loop-breaker information -- when we are doing -fexpose-all-unfoldings ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -1271,5 +1271,5 @@ cgTick tick ProfNote cc t p -> emitSetCCC cc t p HpcTick m n -> emit (mkTickBox platform m n) SourceNote s n -> emitTick $ SourceNote s n - _other -> return () -- ignore + Breakpoint {} -> return () -- ignore } ===================================== compiler/GHC/Types/Basic.hs ===================================== @@ -67,7 +67,7 @@ module GHC.Types.Basic ( noOneShotInfo, hasNoOneShotInfo, isOneShotInfo, bestOneShot, worstOneShot, - OccInfo(..), noOccInfo, seqOccInfo, zapFragileOcc, isOneOcc, + OccInfo(..), noOccInfo, seqOccInfo, zapFragileOccInfo, isOneOcc, isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isManyOccs, isNoOccInfo, strongLoopBreaker, weakLoopBreaker, @@ -1289,10 +1289,13 @@ isOneOcc :: OccInfo -> Bool isOneOcc (OneOcc {}) = True isOneOcc _ = False -zapFragileOcc :: OccInfo -> OccInfo --- Keep only the most robust data: deadness, loop-breaker-hood -zapFragileOcc (OneOcc {}) = noOccInfo -zapFragileOcc occ = zapOccTailCallInfo occ +-- | Keep only the most robust occurrence info: deadness, loop-breaker-hood. +-- +-- In particular, it zaps 'TailCallInfo': see Note [JoinId vs TailCallInfo] +-- in 'GHC.Core.Opt.Simplify.Env'. +zapFragileOccInfo :: OccInfo -> OccInfo +zapFragileOccInfo (OneOcc {}) = noOccInfo +zapFragileOccInfo occ = zapOccTailCallInfo occ instance Outputable OccInfo where -- only used for debugging; never parsed. KSW 1999-07 ===================================== compiler/GHC/Types/Id/Info.hs ===================================== @@ -893,14 +893,15 @@ zapUsedOnceInfo info , demandInfo = zapUsedOnceDemand (demandInfo info) } zapFragileInfo :: IdInfo -> Maybe IdInfo --- ^ Zap info that depends on free variables +-- ^ Zap fragile 'IdInfo', such as info that depends on free variables +-- or fragile occurrence info (see 'zapFragileOccInfo'). zapFragileInfo info@(IdInfo { occInfo = occ, realUnfoldingInfo = unf }) = new_unf `seq` -- The unfolding field is not (currently) strict, so we -- force it here to avoid a (zapFragileUnfolding unf) thunk -- which might leak space Just (info `setRuleInfo` emptyRuleInfo `setUnfoldingInfo` new_unf - `setOccInfo` zapFragileOcc occ) + `setOccInfo` zapFragileOccInfo occ) where new_unf = zapFragileUnfolding unf ===================================== compiler/GHC/Types/Tickish.hs ===================================== @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} @@ -10,9 +11,8 @@ module GHC.Types.Tickish ( CoreTickish, StgTickish, CmmTickish, XTickishId, tickishCounts, - TickishScoping(..), - tickishScoped, - tickishScopesLike, + tickishHasNoScope, + tickishHasSoftScope, tickishFloatable, tickishCanSplit, mkNoCount, @@ -172,103 +172,177 @@ deriving instance Ord (GenTickish 'TickishPassCmm) deriving instance Data (GenTickish 'TickishPassCmm) --- | A "counting tick" (where tickishCounts is True) is one that +-- | A "counting tick" (for which 'tickishCounts' is True) is one that -- counts evaluations in some way. We cannot discard a counting tick, --- and the compiler should preserve the number of counting ticks as --- far as possible. +-- and the compiler should preserve the number of counting ticks (as +-- far as possible). -- --- However, we still allow the simplifier to increase or decrease --- sharing, so in practice the actual number of ticks may vary, except --- that we never change the value from zero to non-zero or vice versa. +-- See Note [Counting ticks] tickishCounts :: GenTickish pass -> Bool -tickishCounts n@ProfNote{} = profNoteCount n -tickishCounts HpcTick{} = True -tickishCounts Breakpoint{} = True -tickishCounts _ = False - - --- | Specifies the scoping behaviour of ticks. This governs the --- behaviour of ticks that care about the covered code and the cost --- associated with it. Important for ticks relating to profiling. -data TickishScoping = - -- | No scoping: The tick does not care about what code it - -- covers. Transformations can freely move code inside as well as - -- outside without any additional annotation obligations - NoScope - - -- | Soft scoping: We want all code that is covered to stay - -- covered. Note that this scope type does not forbid - -- transformations from happening, as long as all results of - -- the transformations are still covered by this tick or a copy of - -- it. For example - -- - -- let x = tick<...> (let y = foo in bar) in baz - -- ===> - -- let x = tick<...> bar; y = tick<...> foo in baz - -- - -- Is a valid transformation as far as "bar" and "foo" is - -- concerned, because both still are scoped over by the tick. - -- - -- Note though that one might object to the "let" not being - -- covered by the tick any more. However, we are generally lax - -- with this - constant costs don't matter too much, and given - -- that the "let" was effectively merged we can view it as having - -- lost its identity anyway. - -- - -- Also note that this scoping behaviour allows floating a tick - -- "upwards" in pretty much any situation. For example: - -- - -- case foo of x -> tick<...> bar - -- ==> - -- tick<...> case foo of x -> bar - -- - -- While this is always legal, we want to make a best effort to - -- only make us of this where it exposes transformation - -- opportunities. - | SoftScope - - -- | Cost centre scoping: We don't want any costs to move to other - -- cost-centre stacks. This means we not only want no code or cost - -- to get moved out of their cost centres, but we also object to - -- code getting associated with new cost-centre ticks - or - -- changing the order in which they get applied. - -- - -- A rule of thumb is that we don't want any code to gain new - -- annotations. However, there are notable exceptions, for - -- example: - -- - -- let f = \y -> foo in tick<...> ... (f x) ... - -- ==> - -- tick<...> ... foo[x/y] ... - -- - -- In-lining lambdas like this is always legal, because inlining a - -- function does not change the cost-centre stack when the - -- function is called. - | CostCentreScope - - deriving (Eq) - --- | Returns the intended scoping rule for a Tickish -tickishScoped :: GenTickish pass -> TickishScoping -tickishScoped n@ProfNote{} - | profNoteScope n = CostCentreScope - | otherwise = NoScope -tickishScoped HpcTick{} = NoScope -tickishScoped Breakpoint{} = CostCentreScope - -- Breakpoints are scoped: eventually we're going to do call - -- stacks, but also this helps prevent the simplifier from moving - -- breakpoints around and changing their result type (see #1531). -tickishScoped SourceNote{} = SoftScope - --- | Returns whether the tick scoping rule is at least as permissive --- as the given scoping rule. -tickishScopesLike :: GenTickish pass -> TickishScoping -> Bool -tickishScopesLike t scope = tickishScoped t `like` scope - where NoScope `like` _ = True - _ `like` NoScope = False - SoftScope `like` _ = True - _ `like` SoftScope = False - CostCentreScope `like` _ = True +tickishCounts = \case + ProfNote { profNoteCount = counts } -> counts + HpcTick {} -> True + Breakpoint {} -> True + SourceNote {} -> False + +-- | Is this a non-scoping tick, for which we don't care about precisely +-- the extent of code that the tick encompasses? +-- +-- See Note [Scoped ticks] +tickishHasNoScope :: GenTickish pass -> Bool +tickishHasNoScope = \case + ProfNote { profNoteScope = scopes } -> not scopes + HpcTick {} -> True + Breakpoint {} -> False + SourceNote {} -> False + +-- | A "tick with soft scoping" (for which 'tickishHasSoftScope' is True) is +-- one that either does not scope at all (for which 'tickishHasNoScope' is True), +-- or that has a "soft" scope: we allow new code to be floated into to the scope, +-- as long as all code that was covered remains covered. +-- +-- See Note [Scoped ticks] +tickishHasSoftScope :: GenTickish pass -> Bool +tickishHasSoftScope = \case + ProfNote { profNoteScope = scopes } -> not scopes + HpcTick {} -> True + Breakpoint {} -> False + SourceNote {} -> True + +{- Note [Scoping ticks and counting ticks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Ticks have two independent attributes: + + * Whether the tick /counts/. + Counting ticks are used when we want a counter to be bumped, e.g. counting + how many times a function is called. + + See Note [Counting ticks] + + * What kind of /scope/ the tick has: + * Cost-centre scope: you cannot move a redex into the scope of the tick, + nor can you float a redex out. + * Soft scope: you can move a redex /into/ the scope of a tick, + but you cannot float a redex /out/ + * No scope: there are no restrictions on floating in or out. + + See Note [Scoped ticks] + +Note [Counting ticks] +~~~~~~~~~~~~~~~~~~~~ +The following ticks count: + - ProfNote ticks with profNoteCounts = True + - HPC ticks + - Breakpoints + +Going past a counting tick implies bumping a counter. +Generally, the simplifier attempts to preserve counts when transforming +programs and moving ticks, for example by transforming: + + case <tick> e of + alt1 -> rhs1 + alt2 -> rhs2 + +to + + case e of + alt1 -> <tick> rhs1 + alt2 -> <tick> rhs2 + +which preserves the total count (as exactly one branch of the case +will be taken). + +However, we still allow the simplifier to increase or decrease +sharing, so in practice the actual number of ticks may vary, except +that we never change the value from zero to non-zero or vice-versa. + +Note [Scoped ticks] +~~~~~~~~~~~~~~~~~~~~ +The following ticks are scoped: + - ProfNote ticks with profNoteScope = True + - Breakpoints + - Source notes + +A scoped tick is one that scopes over a portion of code. For example, +an SCC anotation sets the cost centre for the code within; any allocations +within that piece of code should get attributed to that cost centre. + +When the simplifier deals with a scoping tick, it ensures that all code that +was covered remains covered. For example + + let x = tick<...> (let y = foo in bar) in baz + ===> + let x = tick<...> bar; y = tick<...> foo in baz + +is a valid transformation as far as "bar" and "foo" are concerned, because +both still are scoped over by the tick. One might object to the "let" not +being covered by the tick any more. However, we are generally lax with this; +constant costs don't matter too much, and given that the "let" was effectively +merged we can view it as having lost its identity anyway. + +Perhaps surprisingly, breakpoints are considered to be scoped, because we +don't want the simplifier to move them around, changing their result type (see #1531). + +We specifically forbid floating code outside of a scoping tick, as cost +associated with the floated-out code would no longer be attributed to the +appropriate scope. + +Whether we are allowed to float in additional cost depends on the tick: + + Cost-centre scope ticks + - ProfNote with profNoteScope = True + - Breakpoints + + A tick with cost-centre scope is one for which we can neither move + redexes into or move redexes outside of the tick. For example, we don't + want profiling costs to move to other cost-centre stacks. + Morever, we also object to changing the order in which such ticks + are applied. + + A rule of thumb is that we don't want any code to gain new + lexically-enclosing ticks. For example, we should not transform: + + f (scctick<foo> a) ==> scctick<foo> (f a) + + as this would attribute the cost of evaluating the application 'f a' + to the cost centre 'foo'. + + However, there are notable exceptions, for example: + + let f = \y -> foo in tick<...> ... (f x) ... + ==> + tick<...> ... foo[x/y] ... + + Inlining lambdas like this is always legal, because inlining a function + does not change the cost-centre stack when the function is called. + + Soft scope ticks + - Source notes + + A tick with soft scope is one for which we can move redexes inside the + tick, but cannot float redexes outside the tick. This is a slightly more + lenient notion of scoping than cost-centres, and is used only for source + note ticks (they are used to provide DWARF debug symbols, and for those + it matters less if code from outside gets moved under the tick). + + Examples: + + - FloatIn (GHC.Core.Opt.FloatIn.fiExpr) + + let x = rhs in <tick> body + ==> + <tick> (let x = rhs in body) + + - Moving a tick outside of a case or of an application + (GHC.Core.Opt.Simplify.Iteration.simplTick) + + case <tick> e of alts ==> <tick> case e of alts + + (<tick> e1) e2 ==> <tick> (e1 e2) + + While these transformations are legal, we want to make a best effort to + only make use of them where it exposes transformation opportunities. +-} -- | Returns @True@ for ticks that can be floated upwards easily even -- where it might change execution counts, such as: @@ -277,12 +351,11 @@ tickishScopesLike t scope = tickishScoped t `like` scope -- ==> -- tick<...> (Just foo) -- --- This is a combination of @tickishSoftScope@ and --- @tickishCounts@. Note that in principle splittable ticks can become --- floatable using @mkNoTick@ -- even though there's currently no --- tickish for which that is the case. +-- This is a combination of @tickishHasSoftScope@ and @tickishCounts@. +-- Note that in principle splittable ticks can become floatable using @mkNoTick@, +-- even though there's currently no tickish for which that is the case. tickishFloatable :: GenTickish pass -> Bool -tickishFloatable t = t `tickishScopesLike` SoftScope && not (tickishCounts t) +tickishFloatable t = tickishHasSoftScope t && not (tickishCounts t) -- | Returns @True@ for a tick that is both counting /and/ scoping and -- can be split into its (tick, scope) parts using 'mkNoScope' and @@ -300,7 +373,7 @@ mkNoCount n@ProfNote{} = let n' = n {profNoteCount = False} mkNoCount _ = panic "mkNoCount: Undefined split!" mkNoScope :: GenTickish pass -> GenTickish pass -mkNoScope n | tickishScoped n == NoScope = n +mkNoScope n | tickishHasNoScope n = n | not (tickishCanSplit n) = panic "mkNoScope: Cannot split!" mkNoScope n@ProfNote{} = let n' = n {profNoteScope = False} in assert (profNoteCount n) n' @@ -323,7 +396,9 @@ mkNoScope _ = panic "mkNoScope: Undefined split!" -- translate the code as if it found the latter. tickishIsCode :: GenTickish pass -> Bool tickishIsCode SourceNote{} = False -tickishIsCode _tickish = True -- all the rest for now +tickishIsCode ProfNote{} = True +tickishIsCode Breakpoint{} = True +tickishIsCode HpcTick{} = True isProfTick :: GenTickish pass -> Bool isProfTick ProfNote{} = True ===================================== testsuite/tests/codeGen/should_compile/debug.stdout ===================================== @@ -18,7 +18,6 @@ src<debug.hs:4:9> src<debug.hs:5:21-29> src<debug.hs:5:9-29> src<debug.hs:6:1-21> -src<debug.hs:6:16-21> == CBE == src<debug.hs:4:9> 89 ===================================== testsuite/tests/simplCore/should_compile/T26642.hs ===================================== @@ -0,0 +1,46 @@ +module T26642 ( saveClobberedTemps ) where + +import Prelude ( IO, Bool(..), Int, (>>=), (==), return ) +import Data.Word ( Word64 ) + +------------------------------------------------------------------------------- + +data Word64Map a + = Bin (Word64Map a) (Word64Map a) + | Tip a + | Nil + +{-# NOINLINE myFoldr #-} +myFoldr :: (a -> b -> b) -> b -> Word64Map a -> b +myFoldr f = go + where + {-# NOINLINE go #-} + go z' Nil = z' + go z' (Tip x) = f x z' + go z' (Bin l r) = go (go z' r) l + +{-# NOINLINE nonDetFold #-} +nonDetFold :: (b -> elt -> IO b) -> b -> Word64Map elt -> IO b +nonDetFold f z0 xs = myFoldr c return xs z0 + where + {-# NOINLINE c #-} + c x k z = f z x >>= k + +{-# NOINLINE myFalse #-} +myFalse :: Bool +myFalse = False + +type RealReg = Int +data Loc = InReg RealReg | InMem + +saveClobberedTemps :: forall instr. [RealReg] -> IO [instr] +saveClobberedTemps clobbered = nonDetFold maybe_spill [] Nil + where + {-# NOINLINE maybe_spill #-} + maybe_spill :: [instr] -> Loc -> IO [instr] + maybe_spill instrs !loc = + case loc of + InReg reg + | myFalse + -> return [] + _ -> return instrs ===================================== testsuite/tests/simplCore/should_compile/TrickyJoins.hs ===================================== @@ -0,0 +1,154 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module TrickyJoinPoints where + +import Data.Coerce + ( coerce ) +import Data.Kind + ( Type ) + + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +----------------------------------- +-- Join points and profiling ticks + +data ModGuts2 = MkModGuts2 + +runCorePasses3 :: Bool -> ModGuts2 -> IO ModGuts2 +runCorePasses3 pass guts = doCorePass3 pass guts + +doCorePass3 :: Bool -> ModGuts2 -> IO ModGuts2 +doCorePass3 pass guts = do + _ <- putStrLn "hi" + + let + updateBinds _ = return guts + + case pass of + True -> {-# SCC "XXX3" #-} updateBinds False + _ -> {-# SCC "YYY3" #-} updateBinds True + +-------------------------- +-- Join points & casts + +newtype AdjacencyMap a = AM { + adjacencyMap :: Map a (Set.Set a) } + +overlays :: Ord a => [AdjacencyMap a] -> AdjacencyMap a +overlays = AM . Map.unionsWith Set.union . map adjacencyMap + + +type SBool :: Bool -> Type +data SBool b where + SFalse :: SBool False + STrue :: SBool True + +type N :: Bool -> Type +data family N b +newtype instance N False = NF ( Int -> Int ) +newtype instance N True = NT ( Int -> Int ) + +testCast :: forall b. SBool b -> Int -> Int +testCast b n = + case + ( let + {-# NOINLINE juliet #-} + juliet :: Int -> Int -> Int + juliet x = \ y -> x + y + n + in + case b of + SFalse -> NF (juliet 1) + STrue -> NT (juliet 2) + ) :: N b of + n | SFalse <- b + , NF f <- n + -> f 100 + | STrue <- b + , NT g <- n + -> g 200 + + +------------------------------------------ +-- Join points, profiling ticks and casts + +newtype M = M ( Int -> Int -> Int ) + +testCastTick :: forall b. SBool b -> Int -> Int +testCastTick b n = + case + ( let + {-# NOINLINE j #-} + j :: Int -> Int -> Int + j x = \ y -> x + y + n + {-# NOINLINE k #-} + k :: M + k = coerce j + in + case b of + SFalse -> {-# SCC "ticked" #-} NF ( coerce @M @( Int -> Int -> Int ) k 1 ) + STrue -> NT ( coerce @M @( Int -> Int -> Int ) k 2 ) + ) :: N b of + n | SFalse <- b + , NF f <- n + -> f 100 + | STrue <- b + , NT g <- n + -> g 200 + +------------------------------------------ + +{-# NOINLINE testJoinTransitivity #-} +testJoinTransitivity :: Bool -> Int -> Int +testJoinTransitivity b n = + let + f x = x ^ ( 99 :: Int ) + 7 * ( x - 19 ) + {-# NOINLINE f #-} + in + f ( + let + j1 :: Int -> Int + j1 x = x + n + {-# NOINLINE j1 #-} + + j2 :: Int -> Int + j2 y = j1 (y * 2) + {-# NOINLINE j2 #-} + + j3 :: Int -> Int + j3 z = j2 (z * 3) + {-# NOINLINE j3 #-} + + in case b of + True -> {-# SCC "ticked" #-} j3 10 + False -> j3 20 + ) + +-------------------------------------------------------------------------------- +-- Test relating to Note [JoinId vs TailCallInfo] + +expt :: Int -> Int +expt _ = 3 +{-# NOINLINE expt #-} + +repro :: (Int, Int) -> (Int, Int) +repro (f0,e0) = + let + (f,e) = + let n = e0 + in + case n > 0 of + True -> (f0, e0 + n) + False -> (f0, e0) + r = let be = expt e in f * be + in + (r, 7) ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -470,6 +470,9 @@ test('T22272', normal, multimod_compile, ['T22272', '-O -fexpose-all-unfoldings # go should become a join point test('T22428', [grep_errmsg(r'jump go') ], compile, ['-O -ddump-simpl -dsuppress-uniques -dno-typeable-binds -dsuppress-unfoldings']) +test('TrickyJoins', normal, compile, ['']) +test('T26642', [unless(have_profiling(), skip)], compile, ['-O -prof -fprof-auto-calls']) + test('T22459', normal, compile, ['']) test('T22623', normal, multimod_compile, ['T22623', '-O -v0']) test('T22662', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ed54720f41718094b95dae20609972c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ed54720f41718094b95dae20609972c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/testsuite-merge
by sheaf (＠sheaf) 14 May '26

14 May '26

sheaf pushed new branch wip/testsuite-merge at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/testsuite-merge You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/dcoutts/issue-27086-wakeUpRts
by Duncan Coutts (＠dcoutts) 14 May '26

14 May '26

Duncan Coutts pushed new branch wip/dcoutts/issue-27086-wakeUpRts at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/dcoutts/issue-27086-wakeUpRts You're receiving this email because of your account on gitlab.haskell.org.

1 0