[Git][ghc/ghc][wip/27162/ghc-codegen-panic] WIP Fix windows dynamic linking panic: genForeignCall.assign_code many

16 Apr 2026


      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.

    

David Eichmann (＠DavidEichmann)

tags

participants (1)