GHCi segfaults on Windows with D3D code

Warning: this is about as Windows-specific of a bug as it possibly gets, since it requires the use of D3D. I noticed this when trying to run examples from the d3d11binding library in GHCi, as they all failed.

First, to conjure up the code needed for this:

• Main.hs:

{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main (main) where

import Data.Bits (Bits(..))
import Data.Int (Int32)
import Data.Word (Word32)
import Foreign.C.String (CString, peekCString, withCString, withCStringLen)
import Foreign.Marshal.Alloc (alloca)
import Foreign.Ptr (Ptr, castPtr, nullPtr)
import Foreign.Storable (Storable(..))
import System.IO (IOMode(..), hGetContents, withFile)

#if defined(i386_HOST_ARCH)
# define WINDOWS_CCONV stdcall
#elif defined(x86_64_HOST_ARCH)
# define WINDOWS_CCONV ccall
#else
# error Unknown mingw32 arch
#endif

foreign import WINDOWS_CCONV "D3DCompile" c_d3dCompile
 :: Ptr () -> Word32 -> CString ->
    Ptr D3DShaderMacro -> Ptr ID3DInclude ->
    CString -> CString -> D3DCompileFlag -> D3DCompileEffectFlag ->
    Ptr (Ptr ID3DBlob) -> Ptr (Ptr ID3DBlob) -> IO HRESULT

maybePoke :: (Storable a) => Maybe a -> (Ptr a -> IO b) -> IO b
maybePoke Nothing proc = proc nullPtr
maybePoke (Just m) proc = alloca $ \ptr -> do
  poke ptr m
  proc ptr

maybeWithCString :: Maybe String -> (CString -> IO a) -> IO a
maybeWithCString Nothing proc = proc nullPtr
maybeWithCString (Just m) proc = withCString m proc

type HRESULT = LONG
data ID3DBlob = ID3DBlob
data ID3DInclude = ID3DInclue
type LONG = Int32

data D3DShaderMacro = D3DShaderMacro
  { _name :: String
  , _definition :: String }

instance Storable D3DShaderMacro where
  sizeOf _ = 8
  alignment _ = 8
  peek ptr = do
    n <- peekByteOff ptr 0
    d <- peekByteOff ptr 4
    n' <- peekCString n
    d' <- peekCString d
    return $ D3DShaderMacro n' d'
  poke ptr (D3DShaderMacro n d) = do
    withCString n $ \n' -> withCString d $ \d' -> do
      pokeByteOff ptr 0 n'
      pokeByteOff ptr 4 d'

type D3DCompileFlag = Word32
type D3DCompileEffectFlag = Word32

d3dCompileEnableStrictness :: D3DCompileFlag
d3dCompileEnableStrictness = shift 1 11

d3dCompile
  :: String -> Maybe String ->
     Maybe D3DShaderMacro -> Ptr ID3DInclude ->
     Maybe String -> String ->
     [D3DCompileFlag] -> [D3DCompileEffectFlag] ->
     IO (Either (HRESULT, Ptr ID3DBlob) (Ptr ID3DBlob))
d3dCompile source sourceName defines pInclude entryPoint target compileFlags effectFlags = do
  withCStringLen source $ \(csource, len) -> withCString target $ \pTarget ->
    maybeWithCString sourceName $ \pSourceName -> maybePoke defines $ \pDefines ->
      maybeWithCString entryPoint $ \pEntryPoint -> alloca $ \ppCode -> alloca $ \ppErrorMsgs -> do
        let sFlag = foldl (.|.) 0 compileFlags
        let eFlag = foldl (.|.) 0 effectFlags
        putStrLn "Before d3dCompile"
        hr <- c_d3dCompile
                (castPtr csource)
                (fromIntegral len)
                pSourceName
                pDefines
                pInclude
                pEntryPoint
                pTarget
                sFlag
                eFlag
                ppCode
                ppErrorMsgs
        putStrLn "After d3dCompile"
        if hr < 0
        then do
          pErrorMsgs <- peek ppErrorMsgs
          return $ Left (hr, pErrorMsgs)
        else do
          pCode <- peek ppCode
          return $ Right pCode

d3dCompileFromFile
  :: String -> Maybe String ->
     Maybe D3DShaderMacro -> Ptr ID3DInclude ->
     Maybe String -> String ->
     [D3DCompileFlag] -> [D3DCompileEffectFlag] ->
     IO (Either (HRESULT, Ptr ID3DBlob) (Ptr ID3DBlob))
d3dCompileFromFile fileName sourceName defines pInclude entryPoint target compileFlags effectFlags =
  withFile fileName ReadMode $ \handle -> do
    contents <- hGetContents handle
    d3dCompile contents sourceName defines pInclude entryPoint target compileFlags effectFlags

main :: IO ()
main = do
  _vb <- compileShaderFromFile "Triangle.fx" "VS" "vs_4_0"
  return ()

compileShaderFromFile :: String -> String -> String -> IO (Ptr ID3DBlob)
compileShaderFromFile fileName entryPoint shaderModel = do
  Right res <- d3dCompileFromFile
      fileName
      Nothing
      Nothing
      nullPtr
      (Just entryPoint)
      shaderModel
      [d3dCompileEnableStrictness]
      []
  return res

• Triangle.fx

float4 VS( float4 Pos : POSITION ) : SV_POSITION
{
    return Pos;
}

float4 PS( float4 Pos : SV_POSITION ) : SV_Target
{
    return float4( 1.0f, 1.0f, 0.0f, 1.0f );    // Yellow, with Alpha = 1
}

Make sure that Triangle.fx is in the same directory as Main.hs when running this program.

When compiled, this program works OK:

$ C:\Users\RyanGlScott\Software\ghc-8.2.0.20170404\bin\ghc -lD3DCompiler Main.hs -fforce-recomp
[1 of 1] Compiling Main             ( Main.hs, Main.o )
Linking Main.exe ...
$ .\Main.exe
Before d3dCompile
After d3dCompile

But with GHCi, it crashes:

$ C:\Users\RyanGlScott\Software\ghc-8.2.0.20170404\bin\runghc -lD3DCompiler Main.hs
Before d3dCompile
Access violation in generated code when writing 0000000000000000

I ran these tests on GHC 8.2.1, but I've also reproduced this bug in the past on GHC 8.0.2, so I don't think this is a new bug by any means.

Trac metadata

Trac field	Value
Version	8.2.1-rc2
Type	Bug
TypeOfFailure	OtherFailure
Priority	normal
Resolution	Unresolved
Component	GHCi
Test case
Differential revisions
BlockedBy
Related
Blocking
CC	Phyx-
Operating system
Architecture