[Git][ghc/ghc][wip/fendor/ghci-debugger-unitid] 4 commits: Simplifier: Constant fold invald tagToEnum# calls to bottom expr.

Hannes Siebenhandl pushed to branch wip/fendor/ghci-debugger-unitid at Glasgow Haskell Compiler / GHC Commits: 2e204269 by Andreas Klebinger at 2025-04-22T12:20:41+02:00 Simplifier: Constant fold invald tagToEnum# calls to bottom expr. When applying tagToEnum# to a out-of-range value it's best to simply constant fold it to a bottom expression. That potentially allows more dead code elimination and makes debugging easier. Fixes #25976 - - - - - 7250fc0c by Matthew Pickering at 2025-04-22T16:24:04-04:00 Move -fno-code note into Downsweep module This note was left behind when all the code which referred to it was moved into the GHC.Driver.Downsweep module - - - - - d2dc89b4 by Matthew Pickering at 2025-04-22T16:24:04-04:00 Apply editing notes to Note [-fno-code mode] suggested by sheaf These notes were suggested in https://gitlab.haskell.org/ghc/ghc/-/merge_requests/14241 - - - - - 4d463c97 by fendor at 2025-04-23T12:24:28+02:00 Add `UnitId` to `EvalBreakpoint` The `EvalBreakpoint` is used to communicate that a breakpoint was encountered during code evaluation. This `EvalBreakpoint` needs to be converted to an `InternalBreakpointId` which stores a `Module` to uniquely find the correct `Module` in the Home Package Table. The `EvalBreakpoint` used to store only a `ModuleName` which is then converted to a `Module` based on the currently active home unit. This is incorrect in the face of multiple home units, the break point could be in an entirely other home unit! To fix this, we additionally store the `UnitId` of the `Module` in `EvalBreakpoint` to later reconstruct the correct `Module` All of the changes are the consequence of extending `EvalBreakpoint` with the additional `ShortByteString` of the `UnitId`. For performance reasons, we store the `ShortByteString` backing the `UnitId` directly, avoiding marshalling overhead. - - - - - 16 changed files: - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/HsToCore/Breakpoints.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/StgToByteCode.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - rts/Exception.cmm - rts/Interpreter.c - + testsuite/tests/simplCore/should_compile/T25976.hs - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== compiler/GHC/ByteCode/Asm.hs ===================================== @@ -732,13 +732,16 @@ assembleI platform i = case i of CCALL off m_addr i -> do np <- addr m_addr emit_ bci_CCALL [wOp off, Op np, SmallOp i] PRIMCALL -> emit_ bci_PRIMCALL [] - BRK_FUN arr tick_mod tickx info_mod infox cc -> + BRK_FUN arr tick_mod tick_mod_id tickx info_mod info_mod_id infox cc -> do p1 <- ptr (BCOPtrBreakArray arr) tick_addr <- addr tick_mod + tick_unitid_addr <- addr tick_mod_id info_addr <- addr info_mod + info_unitid_addr <- addr info_mod_id np <- addr cc emit_ bci_BRK_FUN [ Op p1 , Op tick_addr, Op info_addr + , Op tick_unitid_addr, Op info_unitid_addr , SmallOp tickx, SmallOp infox , Op np ] ===================================== compiler/GHC/ByteCode/Instr.hs ===================================== @@ -37,6 +37,7 @@ import GHC.Stg.Syntax import GHCi.BreakArray (BreakArray) import Language.Haskell.Syntax.Module.Name (ModuleName) import GHC.Types.Unique +import GHC.Unit.Types (UnitId) -- ---------------------------------------------------------------------------- -- Bytecode instructions @@ -233,8 +234,10 @@ data BCInstr -- Breakpoints | BRK_FUN (ForeignRef BreakArray) (RemotePtr ModuleName) -- breakpoint tick module + (RemotePtr UnitId) -- breakpoint tick module unit id !Word16 -- breakpoint tick index (RemotePtr ModuleName) -- breakpoint info module + (RemotePtr UnitId) -- breakpoint info module unit id !Word16 -- breakpoint info index (RemotePtr CostCentre) @@ -403,10 +406,10 @@ instance Outputable BCInstr where ppr ENTER = text "ENTER" ppr (RETURN pk) = text "RETURN " <+> ppr pk ppr (RETURN_TUPLE) = text "RETURN_TUPLE" - ppr (BRK_FUN _ _tick_mod tickx _info_mod infox _) + ppr (BRK_FUN _ _tick_mod _tick_mod_id tickx _info_mod _info_mod_id infox _) = text "BRK_FUN" <+> text "<breakarray>" - <+> text "" <+> ppr tickx - <+> text "" <+> ppr infox + <+> text "" <+> text "" <+> ppr tickx + <+> text "" <+> text "" <+> ppr infox <+> text "<cc>" #if MIN_VERSION_rts(1,0,3) ppr (BCO_NAME nm) = text "BCO_NAME" <+> text (show nm) ===================================== compiler/GHC/ByteCode/Types.hs ===================================== @@ -50,6 +50,7 @@ import GHC.Stack.CCS import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList ) import GHC.Iface.Syntax import Language.Haskell.Syntax.Module.Name (ModuleName) +import GHC.Unit.Types (UnitId) -- ----------------------------------------------------------------------------- -- Compiled Byte Code @@ -263,6 +264,9 @@ data ModBreaks , modBreaks_breakInfo :: IntMap CgBreakInfo -- ^ info about each breakpoint from the bytecode generator , modBreaks_module :: RemotePtr ModuleName + -- ^ info about the module in which we are setting the breakpoint + , modBreaks_module_unitid :: RemotePtr UnitId + -- ^ The 'UnitId' of the 'ModuleName' } seqModBreaks :: ModBreaks -> () @@ -273,7 +277,8 @@ seqModBreaks ModBreaks{..} = rnf modBreaks_decls `seq` rnf modBreaks_ccs `seq` rnf (fmap seqCgBreakInfo modBreaks_breakInfo) `seq` - rnf modBreaks_module + rnf modBreaks_module `seq` + rnf modBreaks_module_unitid -- | Construct an empty ModBreaks emptyModBreaks :: ModBreaks @@ -286,6 +291,7 @@ emptyModBreaks = ModBreaks , modBreaks_ccs = array (0,-1) [] , modBreaks_breakInfo = IntMap.empty , modBreaks_module = toRemotePtr nullPtr + , modBreaks_module_unitid = toRemotePtr nullPtr } {- ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -69,7 +69,6 @@ import GHC.Cmm.MachOp ( FMASign(..) ) import GHC.Cmm.Type ( Width(..) ) import GHC.Data.FastString -import GHC.Data.Maybe ( orElse ) import GHC.Utils.Outputable import GHC.Utils.Misc @@ -1997,6 +1996,14 @@ because we don't expect the user to call tagToEnum# at all; we merely generate calls in derived instances of Enum. So we compromise: a rewrite rule rewrites a bad instance of tagToEnum# to an error call, and emits a warning. + +We also do something similar if we can see that the argument of tagToEnum is out +of bounds, e.g. `tagToEnum# 99# :: Bool`. +Replacing this with an error expression is better for two reasons: +* It allow us to eliminate more dead code in cases like `case tagToEnum# 99# :: Bool of ...` +* Should we actually end up executing the relevant code at runtime the user will + see a meaningful error message, instead of a segfault or incorrect result. +See #25976. -} tagToEnumRule :: RuleM CoreExpr @@ -2008,9 +2015,13 @@ tagToEnumRule = do Just (tycon, tc_args) | isEnumerationTyCon tycon -> do let tag = fromInteger i correct_tag dc = (dataConTagZ dc) == tag - (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` []) - massert (null rest) - return $ mkTyApps (Var (dataConWorkId dc)) tc_args + Just dataCons <- pure $ tyConDataCons_maybe tycon + case filter correct_tag dataCons of + (dc:rest) -> do + massert (null rest) + pure $ mkTyApps (Var (dataConWorkId dc)) tc_args + -- Literal is out of range, e.g. tagToEnum @Bool #4 + [] -> pure $ mkImpossibleExpr ty "tagToEnum: Argument out of range" -- See Note [tagToEnum#] _ -> warnPprTrace True "tagToEnum# on non-enumeration type" (ppr ty) $ ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -947,6 +947,71 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = do hostFullWays in dflags_c +{- Note [-fno-code mode] +~~~~~~~~~~~~~~~~~~~~~~~~ +GHC offers the flag -fno-code for the purpose of parsing and typechecking a +program without generating object files. This is intended to be used by tooling +and IDEs to provide quick feedback on any parser or type errors as cheaply as +possible. + +When GHC is invoked with -fno-code, no object files or linked output will be +generated. As many errors and warnings as possible will be generated, as if +-fno-code had not been passed. The session DynFlags will have +backend == NoBackend. + +-fwrite-interface +~~~~~~~~~~~~~~~~ +Whether interface files are generated in -fno-code mode is controlled by the +-fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is +not also passed. Recompilation avoidance requires interface files, so passing +-fno-code without -fwrite-interface should be avoided. If -fno-code were +re-implemented today, there would be no need for -fwrite-interface as it +would considered always on; this behaviour is as it is for backwards compatibility. + +================================================================ +IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER +================================================================ + +Template Haskell +~~~~~~~~~~~~~~~~ +A module using Template Haskell may invoke an imported function from inside a +splice. This will cause the type-checker to attempt to execute that code, which +would fail if no object files had been generated. See #8025. To rectify this, +during the downsweep we patch the DynFlags in the ModSummary of any home module +that is imported by a module that uses Template Haskell to generate object +code. + +The flavour of the generated code depends on whether `-fprefer-byte-code` is enabled +or not in the module which needs the code generation. If the module requires byte-code then +dependencies will generate byte-code, otherwise they will generate object files. +In the case where some modules require byte-code and some object files, both are +generated by enabling `-fbyte-code-and-object-code`, the test "fat015" tests these +configurations. + +The object files (and interface files if -fwrite-interface is disabled) produced +for Template Haskell are written to temporary files. + +Note that since Template Haskell can run arbitrary IO actions, -fno-code mode +is no more secure than running without it. + +Potential TODOS: +~~~~~ +* Remove -fwrite-interface and have interface files always written in -fno-code + mode +* Both .o and .dyn_o files are generated for template haskell, but we only need + .dyn_o. Fix it. +* In make mode, a message like + Compiling A (A.hs, /tmp/ghc_123.o) + is shown if downsweep enabled object code generation for A. Perhaps we should + show "nothing" or "temporary object file" instead. Note that one + can currently use -keep-tmp-files and inspect the generated file with the + current behaviour. +* Offer a -no-codedir command line option, and write what were temporary + object files there. This would speed up recompilation. +* Use existing object files (if they are up to date) instead of always + generating temporary ones. +-} + -- | Populate the Downsweep cache with the root modules. mkRootMap :: [ModuleNodeInfo] ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -1246,70 +1246,6 @@ addSptEntries hsc_env mlinkable = , spt <- bc_spt_entries bco ] -{- Note [-fno-code mode] -~~~~~~~~~~~~~~~~~~~~~~~~ -GHC offers the flag -fno-code for the purpose of parsing and typechecking a -program without generating object files. This is intended to be used by tooling -and IDEs to provide quick feedback on any parser or type errors as cheaply as -possible. - -When GHC is invoked with -fno-code no object files or linked output will be -generated. As many errors and warnings as possible will be generated, as if --fno-code had not been passed. The session DynFlags will have -backend == NoBackend. - --fwrite-interface -~~~~~~~~~~~~~~~~ -Whether interface files are generated in -fno-code mode is controlled by the --fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is -not also passed. Recompilation avoidance requires interface files, so passing --fno-code without -fwrite-interface should be avoided. If -fno-code were -re-implemented today, -fwrite-interface would be discarded and it would be -considered always on; this behaviour is as it is for backwards compatibility. - -================================================================ -IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER -================================================================ - -Template Haskell -~~~~~~~~~~~~~~~~ -A module using template haskell may invoke an imported function from inside a -splice. This will cause the type-checker to attempt to execute that code, which -would fail if no object files had been generated. See #8025. To rectify this, -during the downsweep we patch the DynFlags in the ModSummary of any home module -that is imported by a module that uses template haskell, to generate object -code. - -The flavour of the generated code depends on whether `-fprefer-byte-code` is enabled -or not in the module which needs the code generation. If the module requires byte-code then -dependencies will generate byte-code, otherwise they will generate object files. -In the case where some modules require byte-code and some object files, both are -generated by enabling `-fbyte-code-and-object-code`, the test "fat015" tests these -configurations. - -The object files (and interface files if -fwrite-interface is disabled) produced -for template haskell are written to temporary files. - -Note that since template haskell can run arbitrary IO actions, -fno-code mode -is no more secure than running without it. - -Potential TODOS: -~~~~~ -* Remove -fwrite-interface and have interface files always written in -fno-code - mode -* Both .o and .dyn_o files are generated for template haskell, but we only need - .dyn_o. Fix it. -* In make mode, a message like - Compiling A (A.hs, /tmp/ghc_123.o) - is shown if downsweep enabled object code generation for A. Perhaps we should - show "nothing" or "temporary object file" instead. Note that one - can currently use -keep-tmp-files and inspect the generated file with the - current behaviour. -* Offer a -no-codedir command line option, and write what were temporary - object files there. This would speed up recompilation. -* Use existing object files (if they are up to date) instead of always - generating temporary ones. --} -- Note [When source is considered modified] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/HsToCore/Breakpoints.hs ===================================== @@ -34,7 +34,7 @@ mkModBreaks interp mod extendedMixEntries breakArray <- GHCi.newBreakArray interp count ccs <- mkCCSArray interp mod count entries - mod_ptr <- GHCi.newModuleName interp (moduleName mod) + (mod_ptr, mod_id_ptr) <- GHCi.newModule interp mod let locsTicks = listArray (0,count-1) [ tick_loc t | t <- entries ] varsTicks = listArray (0,count-1) [ tick_ids t | t <- entries ] @@ -46,6 +46,7 @@ mkModBreaks interp mod extendedMixEntries , modBreaks_decls = declsTicks , modBreaks_ccs = ccs , modBreaks_module = mod_ptr + , modBreaks_module_unitid = mod_id_ptr } mkCCSArray ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -345,7 +345,7 @@ handleRunStatus step expr bindings final_ids status history0 = do -- Just case: we stopped at a breakpoint EvalBreak apStack_ref (Just eval_break) resume_ctxt ccs -> do - ibi <- liftIO $ evalBreakpointToId (hsc_HPT hsc_env) eval_break + let ibi = evalBreakpointToId eval_break tick_brks <- liftIO $ readModBreaks hsc_env (ibi_tick_mod ibi) let span = modBreaks_locs tick_brks ! ibi_tick_index ibi ===================================== compiler/GHC/Runtime/Interpreter.hs ===================================== @@ -21,7 +21,7 @@ module GHC.Runtime.Interpreter , mkCostCentres , costCentreStackInfo , newBreakArray - , newModuleName + , newModule , storeBreakpoint , breakpointStatus , getBreakpointVar @@ -93,9 +93,7 @@ import GHC.Utils.Outputable(brackets, ppr, showSDocUnsafe) import GHC.Utils.Fingerprint import GHC.Unit.Module -import GHC.Unit.Module.ModIface import GHC.Unit.Home.ModInfo -import GHC.Unit.Home.PackageTable import GHC.Unit.Env #if defined(HAVE_INTERNAL_INTERPRETER) @@ -119,6 +117,7 @@ import qualified GHC.InfoProv as InfoProv import GHC.Builtin.Names import GHC.Types.Name +import qualified GHC.Unit.Home.Graph as HUG -- Standard libraries import GHC.Exts @@ -377,9 +376,13 @@ newBreakArray interp size = do breakArray <- interpCmd interp (NewBreakArray size) mkFinalizedHValue interp breakArray -newModuleName :: Interp -> ModuleName -> IO (RemotePtr ModuleName) -newModuleName interp mod_name = - castRemotePtr <$> interpCmd interp (NewBreakModule (moduleNameString mod_name)) +newModule :: Interp -> Module -> IO (RemotePtr ModuleName, RemotePtr UnitId) +newModule interp mod = do + let + mod_name = moduleNameString $ moduleName mod + mod_id = fastStringToShortByteString $ unitIdFS $ toUnitId $ moduleUnit mod + (mod_ptr, mod_id_ptr) <- interpCmd interp (NewBreakModule mod_name mod_id) + pure (castRemotePtr mod_ptr, castRemotePtr mod_id_ptr) storeBreakpoint :: Interp -> ForeignRef BreakArray -> Int -> Int -> IO () storeBreakpoint interp ref ix cnt = do -- #19157 @@ -415,19 +418,21 @@ seqHValue interp unit_env ref = status <- interpCmd interp (Seq hval) handleSeqHValueStatus interp unit_env status -evalBreakpointToId :: HomePackageTable -> EvalBreakpoint -> IO InternalBreakpointId -evalBreakpointToId hpt eval_break = - let load_mod x = mi_module . hm_iface . expectJust <$> lookupHpt hpt (mkModuleName x) - in do - tickl <- load_mod (eb_tick_mod eval_break) - infol <- load_mod (eb_info_mod eval_break) - return - InternalBreakpointId - { ibi_tick_mod = tickl - , ibi_tick_index = eb_tick_index eval_break - , ibi_info_mod = infol - , ibi_info_index = eb_info_index eval_break - } +evalBreakpointToId :: EvalBreakpoint -> InternalBreakpointId +evalBreakpointToId eval_break = + let + mkUnitId u = fsToUnit $ mkFastStringShortByteString u + + toModule u n = mkModule (mkUnitId u) (mkModuleName n) + tickl = toModule (eb_tick_mod_unit eval_break) (eb_tick_mod eval_break) + infol = toModule (eb_info_mod_unit eval_break) (eb_info_mod eval_break) + in + InternalBreakpointId + { ibi_tick_mod = tickl + , ibi_tick_index = eb_tick_index eval_break + , ibi_info_mod = infol + , ibi_info_index = eb_info_index eval_break + } -- | Process the result of a Seq or ResumeSeq message. #2950 handleSeqHValueStatus :: Interp -> UnitEnv -> EvalStatus () -> IO (EvalResult ()) @@ -447,12 +452,12 @@ handleSeqHValueStatus interp unit_env eval_status = mkGeneralSrcSpan (fsLit "<unknown>") Just break -> do - bi <- evalBreakpointToId (ue_hpt unit_env) break + let bi = evalBreakpointToId break -- Just case: Stopped at a breakpoint, extract SrcSpan information -- from the breakpoint. breaks_tick <- getModBreaks . expectJust <$> - lookupHpt (ue_hpt unit_env) (moduleName (ibi_tick_mod bi)) + HUG.lookupHugByModule (ibi_tick_mod bi) (ue_home_unit_graph unit_env) put $ brackets . ppr $ (modBreaks_locs breaks_tick) ! ibi_tick_index bi ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -416,7 +416,7 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do Nothing -> pure code Just current_mod_breaks -> break_info hsc_env tick_mod current_mod mb_current_mod_breaks >>= \case Nothing -> pure code - Just ModBreaks {modBreaks_flags = breaks, modBreaks_module = tick_mod_ptr, modBreaks_ccs = cc_arr} -> do + Just ModBreaks {modBreaks_flags = breaks, modBreaks_module = tick_mod_ptr, modBreaks_module_unitid = tick_mod_id_ptr, modBreaks_ccs = cc_arr} -> do platform <- profilePlatform <$> getProfile let idOffSets = getVarOffSets platform d p fvs ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs) @@ -425,6 +425,7 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty let info_mod_ptr = modBreaks_module current_mod_breaks + info_mod_id_ptr = modBreaks_module_unitid current_mod_breaks infox <- newBreakInfo breakInfo let cc | Just interp <- hsc_interp hsc_env @@ -437,7 +438,7 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do in if fromIntegral r == x then r else pprPanic "schemeER_wrk: breakpoint tick/info index too large!" (ppr x) - breakInstr = BRK_FUN breaks tick_mod_ptr (toW16 tick_no) info_mod_ptr (toW16 infox) cc + breakInstr = BRK_FUN breaks tick_mod_ptr tick_mod_id_ptr (toW16 tick_no) info_mod_ptr info_mod_id_ptr (toW16 infox) cc return $ breakInstr `consOL` code schemeER_wrk d p rhs = schemeE d 0 p rhs ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -23,6 +23,7 @@ module GHCi.Message , getMessage, putMessage, getTHMessage, putTHMessage , Pipe, mkPipeFromHandles, mkPipeFromContinuations, remoteCall, remoteTHCall, readPipe, writePipe , BreakModule + , BreakUnitId , LoadedDLL ) where @@ -62,6 +63,7 @@ import qualified GHC.Boot.TH.Syntax as TH import System.Exit import System.IO import System.IO.Error +import qualified Data.ByteString.Short as BS -- ----------------------------------------------------------------------------- -- The RPC protocol between GHC and the interactive server @@ -245,8 +247,9 @@ data Message a where -- | Allocate a string for a breakpoint module name. -- This uses an empty dummy type because @ModuleName@ isn't available here. NewBreakModule - :: String - -> Message (RemotePtr BreakModule) + :: String -- ^ @ModuleName@ + -> BS.ShortByteString -- ^ @UnitId@ for the given @ModuleName@ + -> Message (RemotePtr BreakModule, RemotePtr BreakUnitId) deriving instance Show (Message a) @@ -410,10 +413,12 @@ data EvalStatus_ a b instance Binary a => Binary (EvalStatus_ a b) data EvalBreakpoint = EvalBreakpoint - { eb_tick_mod :: String -- ^ Breakpoint tick module - , eb_tick_index :: Int -- ^ Breakpoint tick index - , eb_info_mod :: String -- ^ Breakpoint info module - , eb_info_index :: Int -- ^ Breakpoint info index + { eb_tick_mod :: String -- ^ Breakpoint tick module + , eb_tick_mod_unit :: BS.ShortByteString -- ^ Breakpoint tick module unit id + , eb_tick_index :: Int -- ^ Breakpoint tick index + , eb_info_mod :: String -- ^ Breakpoint info module + , eb_info_mod_unit :: BS.ShortByteString -- ^ Breakpoint tick module unit id + , eb_info_index :: Int -- ^ Breakpoint info index } deriving (Generic, Show) @@ -430,6 +435,10 @@ instance Binary a => Binary (EvalResult a) -- that type isn't available here. data BreakModule +-- | A dummy type that tags the pointer to a breakpoint's @UnitId@, because +-- that type isn't available here. +data BreakUnitId + -- | A dummy type that tags pointers returned by 'LoadDLL'. data LoadedDLL @@ -580,7 +589,7 @@ getMessage = do 36 -> Msg <$> (Seq <$> get) 37 -> Msg <$> return RtsRevertCAFs 38 -> Msg <$> (ResumeSeq <$> get) - 39 -> Msg <$> (NewBreakModule <$> get) + 39 -> Msg <$> (NewBreakModule <$> get <*> get) 40 -> Msg <$> (LookupSymbolInDLL <$> get <*> get) 41 -> Msg <$> (WhereFrom <$> get) _ -> error $ "Unknown Message code " ++ (show b) @@ -627,7 +636,7 @@ putMessage m = case m of Seq a -> putWord8 36 >> put a RtsRevertCAFs -> putWord8 37 ResumeSeq a -> putWord8 38 >> put a - NewBreakModule name -> putWord8 39 >> put name + NewBreakModule name unitid -> putWord8 39 >> put name >> put unitid LookupSymbolInDLL dll str -> putWord8 40 >> put dll >> put str WhereFrom a -> putWord8 41 >> put a ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -43,6 +43,7 @@ import GHC.Conc.Sync import GHC.IO hiding ( bracket ) import System.Mem.Weak ( deRefWeak ) import Unsafe.Coerce +import qualified Data.ByteString.Short as BS -- ----------------------------------------------------------------------------- -- Implement messages @@ -95,7 +96,10 @@ run m = case m of MkCostCentres mod ccs -> mkCostCentres mod ccs CostCentreStackInfo ptr -> ccsToStrings (fromRemotePtr ptr) NewBreakArray sz -> mkRemoteRef =<< newBreakArray sz - NewBreakModule name -> newModuleName name + NewBreakModule name unitid -> do + namePtr <- newModuleName name + uidPtr <- newUnitId unitid + pure (namePtr, uidPtr) SetupBreakpoint ref ix cnt -> do arr <- localRef ref; _ <- setupBreakpoint arr ix cnt @@ -335,7 +339,7 @@ withBreakAction opts breakMVar statusMVar act -- as soon as it is hit, or in resetBreakAction below. onBreak :: BreakpointCallback - onBreak tick_mod# tickx# info_mod# infox# is_exception apStack = do + onBreak tick_mod# tick_mod_uid# tickx# info_mod# info_mod_uid# infox# is_exception apStack = do tid <- myThreadId let resume = ResumeContext { resumeBreakMVar = breakMVar @@ -349,8 +353,10 @@ withBreakAction opts breakMVar statusMVar act then pure Nothing else do tick_mod <- peekCString (Ptr tick_mod#) + tick_mod_uid <- BS.packCString (Ptr tick_mod_uid#) info_mod <- peekCString (Ptr info_mod#) - pure (Just (EvalBreakpoint tick_mod (I# tickx#) info_mod (I# infox#))) + info_mod_uid <- BS.packCString (Ptr info_mod_uid#) + pure (Just (EvalBreakpoint tick_mod tick_mod_uid (I# tickx#) info_mod info_mod_uid (I# infox#))) putMVar statusMVar $ EvalBreak apStack_r breakpoint resume_r ccs takeMVar breakMVar @@ -400,8 +406,10 @@ resetStepFlag = poke stepFlag 0 type BreakpointCallback = Addr# -- pointer to the breakpoint tick module name + -> Addr# -- pointer to the breakpoint tick module unit id -> Int# -- breakpoint tick index -> Addr# -- pointer to the breakpoint info module name + -> Addr# -- pointer to the breakpoint info module unit id -> Int# -- breakpoint info index -> Bool -- exception? -> HValue -- the AP_STACK, or exception @@ -414,8 +422,8 @@ noBreakStablePtr :: StablePtr BreakpointCallback noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction noBreakAction :: BreakpointCallback -noBreakAction _ _ _ _ False _ = putStrLn "*** Ignoring breakpoint" -noBreakAction _ _ _ _ True _ = return () -- exception: just continue +noBreakAction _ _ _ _ _ _ False _ = putStrLn "*** Ignoring breakpoint" +noBreakAction _ _ _ _ _ _ True _ = return () -- exception: just continue -- Malloc and copy the bytes. We don't have any way to monitor the -- lifetime of this memory, so it just leaks. @@ -432,6 +440,13 @@ mkString0 bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do pokeElemOff (ptr :: Ptr CChar) len 0 return (castRemotePtr (toRemotePtr ptr)) +mkShortByteString0 :: BS.ShortByteString -> IO (RemotePtr ()) +mkShortByteString0 bs = BS.useAsCStringLen bs $ \(cstr,len) -> do + ptr <- mallocBytes (len+1) + copyBytes ptr cstr len + pokeElemOff (ptr :: Ptr CChar) len 0 + return (castRemotePtr (toRemotePtr ptr)) + mkCostCentres :: String -> [(String,String)] -> IO [RemotePtr CostCentre] #if defined(PROFILING) mkCostCentres mod ccs = do @@ -453,6 +468,10 @@ newModuleName :: String -> IO (RemotePtr BreakModule) newModuleName name = castRemotePtr . toRemotePtr <$> newCString name +newUnitId :: BS.ShortByteString -> IO (RemotePtr BreakUnitId) +newUnitId name = + castRemotePtr <$> mkShortByteString0 name + getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue) getIdValFromApStack apStack (I# stackDepth) = do case getApStackVal# apStack stackDepth of ===================================== rts/Exception.cmm ===================================== @@ -535,12 +535,16 @@ retry_pop_stack: // be per-thread. CInt[rts_stop_on_exception] = 0; ("ptr" ioAction) = ccall deRefStablePtr (W_[rts_breakpoint_io_action] "ptr"); - Sp = Sp - WDS(13); - Sp(12) = exception; - Sp(11) = stg_raise_ret_info; - Sp(10) = exception; - Sp(9) = ghczminternal_GHCziInternalziTypes_True_closure; // True <=> an exception - Sp(8) = stg_ap_ppv_info; + Sp = Sp - WDS(17); + Sp(16) = exception; + Sp(15) = stg_raise_ret_info; + Sp(14) = exception; + Sp(13) = ghczminternal_GHCziInternalziTypes_True_closure; // True <=> an exception + Sp(12) = stg_ap_ppv_info; + Sp(11) = 0; + Sp(10) = stg_ap_n_info; + Sp(9) = 0; + Sp(8) = stg_ap_n_info; Sp(7) = 0; Sp(6) = stg_ap_n_info; Sp(5) = 0; ===================================== rts/Interpreter.c ===================================== @@ -1245,9 +1245,9 @@ run_BCO: /* check for a breakpoint on the beginning of a let binding */ case bci_BRK_FUN: { - int arg1_brk_array, arg2_tick_mod, arg3_info_mod, arg4_tick_index, arg5_info_index; + int arg1_brk_array, arg2_tick_mod, arg3_info_mod, arg4_tick_mod_id, arg5_info_mod_id, arg6_tick_index, arg7_info_index; #if defined(PROFILING) - int arg6_cc; + int arg8_cc; #endif StgArrBytes *breakPoints; int returning_from_break; @@ -1264,10 +1264,12 @@ run_BCO: arg1_brk_array = BCO_GET_LARGE_ARG; arg2_tick_mod = BCO_GET_LARGE_ARG; arg3_info_mod = BCO_GET_LARGE_ARG; - arg4_tick_index = BCO_NEXT; - arg5_info_index = BCO_NEXT; + arg4_tick_mod_id = BCO_GET_LARGE_ARG; + arg5_info_mod_id = BCO_GET_LARGE_ARG; + arg6_tick_index = BCO_NEXT; + arg7_info_index = BCO_NEXT; #if defined(PROFILING) - arg6_cc = BCO_GET_LARGE_ARG; + arg8_cc = BCO_GET_LARGE_ARG; #else BCO_GET_LARGE_ARG; #endif @@ -1280,7 +1282,7 @@ run_BCO: #if defined(PROFILING) cap->r.rCCCS = pushCostCentre(cap->r.rCCCS, - (CostCentre*)BCO_LIT(arg6_cc)); + (CostCentre*)BCO_LIT(arg8_cc)); #endif // if we are returning from a break then skip this section @@ -1292,11 +1294,11 @@ run_BCO: // stop the current thread if either the // "rts_stop_next_breakpoint" flag is true OR if the // ignore count for this particular breakpoint is zero - StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg4_tick_index]; + StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg6_tick_index]; if (rts_stop_next_breakpoint == false && ignore_count > 0) { // decrement and write back ignore count - ((StgInt*)breakPoints->payload)[arg4_tick_index] = --ignore_count; + ((StgInt*)breakPoints->payload)[arg6_tick_index] = --ignore_count; } else if (rts_stop_next_breakpoint == true || ignore_count == 0) { @@ -1330,8 +1332,10 @@ run_BCO: // continue execution of this BCO when the IO action returns. // // ioAction :: Addr# -- the breakpoint tick module + // -> Addr# -- the breakpoint tick module unit id // -> Int# -- the breakpoint tick index // -> Addr# -- the breakpoint info module + // -> Addr# -- the breakpoint info module unit id // -> Int# -- the breakpoint info index // -> Bool -- exception? // -> HValue -- the AP_STACK, or exception @@ -1340,17 +1344,21 @@ run_BCO: ioAction = (StgClosure *) deRefStablePtr ( rts_breakpoint_io_action); - Sp_subW(15); - SpW(14) = (W_)obj; - SpW(13) = (W_)&stg_apply_interp_info; - SpW(12) = (W_)new_aps; - SpW(11) = (W_)False_closure; // True <=> an exception - SpW(10) = (W_)&stg_ap_ppv_info; - SpW(9) = (W_)arg5_info_index; + Sp_subW(19); + SpW(18) = (W_)obj; + SpW(17) = (W_)&stg_apply_interp_info; + SpW(16) = (W_)new_aps; + SpW(15) = (W_)False_closure; // True <=> an exception + SpW(14) = (W_)&stg_ap_ppv_info; + SpW(13) = (W_)arg7_info_index; + SpW(12) = (W_)&stg_ap_n_info; + SpW(11) = (W_)BCO_LIT(arg5_info_mod_id); + SpW(10) = (W_)&stg_ap_n_info; + SpW(9) = (W_)BCO_LIT(arg3_info_mod); SpW(8) = (W_)&stg_ap_n_info; - SpW(7) = (W_)BCO_LIT(arg3_info_mod); + SpW(7) = (W_)arg6_tick_index; SpW(6) = (W_)&stg_ap_n_info; - SpW(5) = (W_)arg4_tick_index; + SpW(5) = (W_)BCO_LIT(arg4_tick_mod_id); SpW(4) = (W_)&stg_ap_n_info; SpW(3) = (W_)BCO_LIT(arg2_tick_mod); SpW(2) = (W_)&stg_ap_n_info; ===================================== testsuite/tests/simplCore/should_compile/T25976.hs ===================================== @@ -0,0 +1,10 @@ +{-# LANGUAGE MagicHash #-} + +module T25976 where + +import GHC.PrimOps (tagToEnum#) + +-- Spoiler - it's all dead code since tagToEnum 3# is undefined +main = case (tagToEnum# 4# :: Bool) of + True -> print "Dead Code" + False -> print "Dead Code" ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -541,3 +541,5 @@ test('T25883', normal, compile_grep_core, ['']) test('T25883b', normal, compile_grep_core, ['']) test('T25883c', normal, compile_grep_core, ['']) test('T25883d', [extra_files(['T25883d_import.hs'])], multimod_compile_filter, ['T25883d', '-O -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques', r'grep -e "y ="']) + +test('T25976', [grep_errmsg('Dead Code')], compile, ['-O -ddump-simpl -dsuppress-uniques -dno-typeable-binds']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e7bb646b06c1d10f163311a7923f0e2... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e7bb646b06c1d10f163311a7923f0e2... You're receiving this email because of your account on gitlab.haskell.org.