[GHC] #13606: GHCi segfaults on Windows with D3D code

[GHC]

#13606: GHCi segfaults on Windows with D3D code
----------------------------------------+-------------------------------
           Reporter:  RyanGlScott       |             Owner:  (none)
               Type:  bug               |            Status:  new
           Priority:  normal            |         Milestone:
          Component:  GHCi              |           Version:  8.2.1-rc2
           Keywords:                    |  Operating System:  Windows
       Architecture:  Unknown/Multiple  |   Type of failure:  GHCi crash
          Test Case:                    |        Blocked By:
           Blocking:                    |   Related Tickets:
Differential Rev(s):                    |         Wiki Page:
----------------------------------------+-------------------------------
 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
 [https://github.com/jwvg0425/d3d11binding examples] from the
 `d3d11binding` library in GHCi, as they all failed.

 First, to conjure up the code needed for this:

 * `Main.hs`:

 {{{#!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.

--
Ticket URL: <http://ghc.haskell.org/trac/ghc/ticket/13606>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler