David Eichmann pushed to branch wip/27162/ghc-codegen-panic at Glasgow Haskell Compiler / GHC Commits: 27297996 by David Eichmann at 2026-04-16T17:02:06+01:00 WIP Fix windows dynamic linking panic: genForeignCall.assign_code many - - - - - 8 changed files: - compiler/GHC/CmmToAsm.hs - compiler/GHC/CmmToAsm/AArch64.hs - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/X86.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Utils/Panic/Plain.hs Changes: ===================================== compiler/GHC/CmmToAsm.hs ===================================== @@ -132,7 +132,7 @@ import System.IO import System.Directory ( getCurrentDirectory ) -------------------- -nativeCodeGen :: forall a . Logger -> ToolSettings -> NCGConfig -> ModLocation -> Handle +nativeCodeGen :: forall a . HasCallStack => Logger -> ToolSettings -> NCGConfig -> ModLocation -> Handle -> CgStream RawCmmGroup a -> UniqDSMT IO a nativeCodeGen logger ts config modLoc h cmms ===================================== compiler/GHC/CmmToAsm/AArch64.hs ===================================== @@ -18,8 +18,9 @@ import qualified GHC.CmmToAsm.AArch64.Ppr as AArch64 import qualified GHC.CmmToAsm.AArch64.CodeGen as AArch64 import qualified GHC.CmmToAsm.AArch64.Regs as AArch64 import qualified GHC.CmmToAsm.AArch64.RegInfo as AArch64 +import GHC.Stack (HasCallStack) -ncgAArch64 :: NCGConfig -> NcgImpl RawCmmStatics AArch64.Instr AArch64.JumpDest +ncgAArch64 :: HasCallStack => NCGConfig -> NcgImpl RawCmmStatics AArch64.Instr AArch64.JumpDest ncgAArch64 config = NcgImpl { ncgConfig = config ===================================== compiler/GHC/CmmToAsm/AArch64/CodeGen.hs ===================================== @@ -95,7 +95,7 @@ import GHC.Utils.Monad (mapAccumLM) -- data GenBasicBlock i = BasicBlock BlockId [i] cmmTopCodeGen - :: RawCmmDecl + :: HasCallStack => RawCmmDecl -> NatM [NatCmmDecl RawCmmStatics Instr] -- Thus we'll have to deal with either CmmProc ... @@ -123,7 +123,7 @@ cmmTopCodeGen _cmm@(CmmData sec dat) = do return [CmmData sec dat] -- no translation, we just use CmmStatic basicBlockCodeGen - :: Block CmmNode C C + :: HasCallStack => Block CmmNode C C -> NatM ( [NatBasicBlock Instr] , [NatCmmDecl RawCmmStatics Instr]) ===================================== compiler/GHC/CmmToAsm/X86.hs ===================================== @@ -24,7 +24,7 @@ ncgX86 :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics) X86.Instr X86.JumpDest ncgX86 = ncgX86_64 -ncgX86_64 :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics) X86.Instr X86.JumpDest +ncgX86_64 :: HasCallStack => NCGConfig -> NcgImpl (Alignment, RawCmmStatics) X86.Instr X86.JumpDest ncgX86_64 config = NcgImpl { ncgConfig = config , cmmTopCodeGen = X86.cmmTopCodeGen ===================================== compiler/GHC/CmmToAsm/X86/CodeGen.hs ===================================== @@ -142,7 +142,7 @@ avx512dqEnabled :: NatM Bool avx512dqEnabled = ncgAvx512dqEnabled <$> getConfig cmmTopCodeGen - :: RawCmmDecl + :: HasCallStack => RawCmmDecl -> NatM [NatCmmDecl (Alignment, RawCmmStatics) Instr] cmmTopCodeGen (CmmProc info lab live graph) = do @@ -212,7 +212,7 @@ verifyBasicBlock platform instrs (pprInstr platform i <+> text "in:" $$ vcat (map (pprInstr platform) instrs)) basicBlockCodeGen - :: CmmBlock + :: HasCallStack => CmmBlock -> NatM ( [NatBasicBlock Instr] , [NatCmmDecl (Alignment, RawCmmStatics) Instr]) @@ -325,7 +325,7 @@ which *are* known to change the basic block. -- See Note [Keeping track of the current block] for why -- we pass the BlockId. -stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in. +stmtsToInstrs :: HasCallStack => BlockId -- ^ Basic block these statement will start to be placed in. -> [CmmNode O O] -- ^ Cmm Statement -> NatM (InstrBlock, BlockId) -- ^ Resulting instruction stmtsToInstrs bid stmts = @@ -341,7 +341,8 @@ stmtsToInstrs bid stmts = -- | `bid` refers to the current block and is used to update the CFG -- if new blocks are inserted in the control flow. -- See Note [Keeping track of the current block] for more details. -stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in. +stmtToInstrs :: HasCallStack + => BlockId -- ^ Basic block this statement will start to be placed in. -> CmmNode e x -> NatM (InstrBlock, Maybe BlockId) -- ^ Instructions, and bid of new block if successive @@ -546,7 +547,7 @@ assignReg_I64Code (CmmLocal dst) valueTree = do assignReg_I64Code _ _ = panic "assignReg_I64Code(i386): invalid lvalue" -iselExpr64 :: HasDebugCallStack => CmmExpr -> NatM (RegCode64 InstrBlock) +iselExpr64 :: HasCallStack => CmmExpr -> NatM (RegCode64 InstrBlock) iselExpr64 (CmmLit (CmmInt i _)) = do Reg64 rhi rlo <- getNewReg64 let @@ -855,12 +856,12 @@ iselExpr64ParallelBin op e1 e2 = do -------------------------------------------------------------------------------- -getRegister :: HasDebugCallStack => CmmExpr -> NatM Register +getRegister :: HasCallStack => CmmExpr -> NatM Register getRegister e = do platform <- getPlatform is32Bit <- is32BitPlatform getRegister' platform is32Bit e -getRegister' :: HasDebugCallStack => Platform -> Bool -> CmmExpr -> NatM Register +getRegister' :: HasCallStack => Platform -> Bool -> CmmExpr -> NatM Register getRegister' platform is32Bit (CmmReg reg) = case reg of @@ -3412,12 +3413,12 @@ intLoadCode instr mem = do -- Compute an expression into *any* register, adding the appropriate -- move instruction if necessary. -getAnyReg :: HasDebugCallStack => CmmExpr -> NatM (Reg -> InstrBlock) +getAnyReg :: HasCallStack => CmmExpr -> NatM (Reg -> InstrBlock) getAnyReg expr = do r <- getRegister expr anyReg r -anyReg :: HasDebugCallStack => Register -> NatM (Reg -> InstrBlock) +anyReg :: HasCallStack => Register -> NatM (Reg -> InstrBlock) anyReg (Any _ code) = return code anyReg (Fixed rep reg fcode) = do config <- getConfig @@ -3426,7 +3427,7 @@ anyReg (Fixed rep reg fcode) = do -- A bit like getSomeReg, but we want a reg that can be byte-addressed. -- Fixed registers might not be byte-addressable, so we make sure we've -- got a temporary, inserting an extra reg copy if necessary. -getByteReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, InstrBlock) +getByteReg :: HasCallStack => CmmExpr -> NatM (Reg, InstrBlock) getByteReg expr = do config <- getConfig is32Bit <- is32BitPlatform @@ -3448,7 +3449,7 @@ getByteReg expr = do -- Another variant: this time we want the result in a register that cannot -- be modified by code to evaluate an arbitrary expression. -getNonClobberedReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, InstrBlock) +getNonClobberedReg :: HasCallStack => CmmExpr -> NatM (Reg, InstrBlock) getNonClobberedReg expr = do r <- getRegister expr config <- getConfig @@ -4324,7 +4325,8 @@ genCondBranch' _ bid id false bool = do -- to take/return a block id. genForeignCall - :: ForeignTarget -- ^ function to call + :: HasCallStack + => ForeignTarget -- ^ function to call -> [CmmFormal] -- ^ where to put the result -> [CmmActual] -- ^ arguments (of mixed type) -> BlockId -- ^ The block we are in @@ -4559,7 +4561,7 @@ loadIntoRegMightClobberOtherReg _ = True -- | Generate C call to the given function in ghc-prim genPrimCCall - :: BlockId + :: HasCallStack => BlockId -> FastString -> [CmmFormal] -> [CmmActual] @@ -4574,7 +4576,7 @@ genPrimCCall bid lbl_txt dsts args = do -- | Generate C call to the given function in libc genLibCCall - :: BlockId + :: HasCallStack => BlockId -> FastString -> [CmmFormal] -> [CmmActual] @@ -4592,7 +4594,7 @@ genLibCCall bid lbl_txt dsts args = do -- | Generate C call to the given function in the RTS genRTSCCall - :: BlockId + :: HasCallStack => BlockId -> FastString -> [CmmFormal] -> [CmmActual] @@ -4608,7 +4610,7 @@ genRTSCCall bid lbl_txt dsts args = do -- | Generate a real C call to the given address with the given convention genCCall - :: BlockId + :: HasCallStack => BlockId -> CmmExpr -> ForeignConvention -> [CmmFormal] @@ -4786,7 +4788,7 @@ genCCall32 addr _conv dest_regs args = do call `appOL` assign_code dest_regs) -genCCall64 :: CmmExpr -- ^ address of function to call +genCCall64 :: HasCallStack => CmmExpr -- ^ address of function to call -> ForeignConvention -- ^ calling convention -> [CmmFormal] -- ^ where to put the result -> [CmmActual] -- ^ arguments (of mixed type) ===================================== compiler/GHC/Driver/CodeOutput.hs ===================================== @@ -63,6 +63,7 @@ import GHC.Types.Unique.Supply ( UniqueTag(..) ) import System.IO import Data.Set (Set) import qualified Data.Set as Set +import GHC.Stack (HasCallStack) {- ************************************************************************ @@ -74,7 +75,7 @@ import qualified Data.Set as Set codeOutput :: forall a. - Logger + HasCallStack => Logger -> TmpFs -> LlvmConfigCache -> DynFlags @@ -192,7 +193,7 @@ outputC logger dflags filenm dus cmm_stream unit_deps = ************************************************************************ -} -outputAsm :: Logger +outputAsm :: HasCallStack => Logger -> DynFlags -> Module -> ModLocation ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -1941,7 +1941,7 @@ hscSimpleIface' mb_core_program tc_result summary = do -------------------------------------------------------------- -- | Compile to hard-code. -hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath +hscGenHardCode :: HasCallStack => HscEnv -> CgGuts -> ModLocation -> FilePath -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe StgCgInfos, Maybe CmmCgInfos ) -- ^ @Just f@ <=> _stub.c is f hscGenHardCode hsc_env cgguts mod_loc output_filename = do @@ -2246,7 +2246,7 @@ generateFreshByteCodeLinkable hsc_env mod_name cgguts mod_location = do return $ mkModuleByteCodeLinkable bco_time bco_object ------------------------------ -hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> FilePath -> IO (Maybe FilePath) +hscCompileCmmFile :: HasCallStack => HscEnv -> FilePath -> FilePath -> FilePath -> IO (Maybe FilePath) hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hsc_env $ do let dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env ===================================== compiler/GHC/Utils/Panic/Plain.hs ===================================== @@ -92,12 +92,12 @@ showPlainGhcException = . s . showString "\n\n" . showString "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug\n" -throwPlainGhcException :: PlainGhcException -> a +throwPlainGhcException :: HasCallStack => PlainGhcException -> a throwPlainGhcException = Exception.throw -- | Panics and asserts. panic, sorry, pgmError :: HasCallStack => String -> a -panic x = unsafeDupablePerformIO $ throwPlainGhcException (PlainPanic x) +panic x = unsafeDupablePerformIO $ throwPlainGhcException (PlainPanic (unlines [x, show callStack])) sorry x = throwPlainGhcException (PlainSorry x) pgmError x = throwPlainGhcException (PlainProgramError x) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/27297996ae63c1b1fdc5c93052cfda8c... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/27297996ae63c1b1fdc5c93052cfda8c... You're receiving this email because of your account on gitlab.haskell.org.