Ticket #7353: 0001-GHC.Windows-more-error-support-guards-system-error-s.patch

File 0001-GHC.Windows-more-error-support-guards-system-error-s.patch, 8.0 KB (added by joeyadams, 6 months ago)

Patch for base that extends GHC.Windows (mostly error code stuff)

  • GHC/Windows.hs 

    From 7f9bd4d7d04f4c9c99c0b52077c145b8255ab029 Mon Sep 17 00:00:00 2001
From: Joey Adams <joeyadams3.14159@gmail.com>
Date: Mon, 12 Nov 2012 21:48:08 -0500
Subject: [PATCH] GHC.Windows: more error support (guards, system error
 strings)

---
 GHC/Windows.hs     | 149 ++++++++++++++++++++++++++++++++++++++++++++++++-----
 cbits/Win32Utils.c |  69 +++++++++++++++----------
 include/HsBase.h   |   1 +
 3 files changed, 180 insertions(+), 39 deletions(-)

diff --git a/GHC/Windows.hs b/GHC/Windows.hs
index fa25f63..fbcf97e 100644
    a b  
    11{-# LANGUAGE Trustworthy #-} 
    2 {-# LANGUAGE NoImplicitPrelude, ForeignFunctionInterface #-} 
     2{-# LANGUAGE CPP #-} 
     3{-# LANGUAGE ForeignFunctionInterface #-} 
     4{-# LANGUAGE NoImplicitPrelude #-} 
    35----------------------------------------------------------------------------- 
    46-- | 
    57-- Module      :  GHC.Windows 
    … …  
    1921----------------------------------------------------------------------------- 
    2022 
    2123module GHC.Windows ( 
    22         HANDLE, DWORD, LPTSTR, iNFINITE, 
    23         throwGetLastError, c_maperrno 
    24     ) where 
     24        -- * Types 
     25        BOOL, 
     26        DWORD, 
     27        ErrCode, 
     28        HANDLE, 
     29        LPWSTR, 
     30        LPTSTR, 
    2531 
    26 import GHC.Base 
    27 import GHC.Ptr 
     32        -- * Constants 
     33        iNFINITE, 
     34        iNVALID_HANDLE_VALUE, 
    2835 
    29 import Data.Word 
     36        -- * System errors 
     37        throwGetLastError, 
     38        c_maperrno, 
     39        c_maperrno_func, 
     40        getErrorMessage, 
     41        getLastError, 
     42        errCodeToIOError, 
     43        failWith, 
    3044 
    31 import Foreign.C.Error (throwErrno) 
     45        -- ** Guards for system calls that might fail 
     46        failIf, 
     47        failIf_, 
     48        failIfNull, 
     49        failIfZero, 
     50        failIfFalse_, 
     51        failUnlessSuccess, 
     52        failUnlessSuccessOr, 
     53    ) where 
     54 
     55import Data.Char 
     56import Data.List 
     57import Data.Maybe 
     58import Data.Word 
     59import Foreign.C.Error 
     60import Foreign.C.String 
    3261import Foreign.C.Types 
     62import Foreign.Ptr 
     63import GHC.Base 
     64import GHC.IO 
     65import GHC.Num 
     66import System.IO.Error 
    3367 
     68import qualified Numeric 
    3469 
    35 type HANDLE       = Ptr () 
    36 type DWORD        = Word32 
     70#ifdef mingw32_HOST_OS 
     71# if defined(i386_HOST_ARCH) 
     72#  define WINDOWS_CCONV stdcall 
     73# elif defined(x86_64_HOST_ARCH) 
     74#  define WINDOWS_CCONV ccall 
     75# else 
     76#  error Unknown mingw32 arch 
     77# endif 
     78#endif 
    3779 
    38 type LPTSTR = Ptr CWchar 
     80type BOOL       = Bool 
     81type DWORD      = Word32 
     82type ErrCode    = DWORD 
     83type HANDLE     = Ptr () 
     84type LPWSTR     = Ptr CWchar 
     85type LPTSTR     = LPWSTR 
    3986 
    4087iNFINITE :: DWORD 
    4188iNFINITE = 0xFFFFFFFF -- urgh 
    4289 
     90iNVALID_HANDLE_VALUE :: HANDLE 
     91iNVALID_HANDLE_VALUE = wordPtrToPtr (-1) 
     92 
    4393throwGetLastError :: String -> IO a 
    44 throwGetLastError where_from = c_maperrno >> throwErrno where_from 
     94throwGetLastError where_from = 
     95    getLastError >>= failWith where_from 
    4596 
    4697foreign import ccall unsafe "maperrno"             -- in Win32Utils.c 
    4798   c_maperrno :: IO () 
    4899 
     100foreign import ccall unsafe "maperrno_func"        -- in Win32Utils.c 
     101   c_maperrno_func :: ErrCode -> Errno 
     102 
     103foreign import ccall unsafe "base_getErrorMessage" -- in Win32Utils.c 
     104    c_getErrorMessage :: DWORD -> IO LPWSTR 
     105 
     106foreign import WINDOWS_CCONV unsafe "windows.h LocalFree" 
     107    localFree :: Ptr a -> IO (Ptr a) 
     108 
     109foreign import WINDOWS_CCONV unsafe "windows.h GetLastError" 
     110    getLastError :: IO ErrCode 
     111 
     112 
     113failIf :: (a -> Bool) -> String -> IO a -> IO a 
     114failIf p wh act = do 
     115    v <- act 
     116    if p v then throwGetLastError wh else return v 
     117 
     118failIf_ :: (a -> Bool) -> String -> IO a -> IO () 
     119failIf_ p wh act = do 
     120    v <- act 
     121    if p v then throwGetLastError wh else return () 
     122 
     123failIfNull :: String -> IO (Ptr a) -> IO (Ptr a) 
     124failIfNull = failIf (== nullPtr) 
     125 
     126failIfZero :: (Eq a, Num a) => String -> IO a -> IO a 
     127failIfZero = failIf (== 0) 
     128 
     129failIfFalse_ :: String -> IO Bool -> IO () 
     130failIfFalse_ = failIf_ not 
     131 
     132failUnlessSuccess :: String -> IO ErrCode -> IO () 
     133failUnlessSuccess fn_name act = do 
     134    r <- act 
     135    if r == 0 then return () else failWith fn_name r 
     136 
     137failUnlessSuccessOr :: ErrCode -> String -> IO ErrCode -> IO Bool 
     138failUnlessSuccessOr val fn_name act = do 
     139    r <- act 
     140    if r == 0 then return False 
     141        else if r == val then return True 
     142        else failWith fn_name r 
     143 
     144-- | Convert a Windows error code to an exception, then throw it. 
     145failWith :: String -> ErrCode -> IO a 
     146failWith fn_name err_code = 
     147    errCodeToIOError fn_name err_code >>= throwIO 
     148 
     149-- | Convert a Windows error code to an exception. 
     150errCodeToIOError :: String -> ErrCode -> IO IOError 
     151errCodeToIOError fn_name err_code = do 
     152    msg <- getErrorMessage err_code 
     153 
     154    -- turn GetLastError() into errno, which errnoToIOError knows 
     155    -- how to convert to an IOException we can throw. 
     156    -- XXX we should really do this directly. 
     157    let errno = c_maperrno_func err_code 
     158 
     159    let msg' = reverse $ dropWhile isSpace $ reverse msg -- drop trailing \n 
     160        ioerror = errnoToIOError fn_name errno Nothing Nothing 
     161                    `ioeSetErrorString` msg' 
     162    return ioerror 
     163 
     164getErrorMessage :: ErrCode -> IO String 
     165getErrorMessage err_code = 
     166    mask_ $ do 
     167        c_msg <- c_getErrorMessage err_code 
     168        if c_msg == nullPtr 
     169          then return $ "Error 0x" ++ Numeric.showHex err_code "" 
     170          else do msg <- peekCWString c_msg 
     171                  -- We ignore failure of freeing c_msg, given we're already failing 
     172                  _ <- localFree c_msg 
     173                  return msg 

  • cbits/Win32Utils.c 

    diff --git a/cbits/Win32Utils.c b/cbits/Win32Utils.c
index ecd54f3..7038cbf 100644
    a b  
    8080#define MIN_EACCES_RANGE ERROR_WRITE_PROTECT 
    8181#define MAX_EACCES_RANGE ERROR_SHARING_BUFFER_EXCEEDED 
    8282 
    83 void maperrno (void) 
     83void maperrno(void) 
    8484{ 
    85         int i; 
    86         DWORD dwErrorCode; 
    87  
    88         dwErrorCode = GetLastError(); 
    89  
    90         /* check the table for the OS error code */ 
    91         for (i = 0; i < ERRTABLESIZE; ++i) 
    92         { 
    93                 if (dwErrorCode == errtable[i].oscode) 
    94                 { 
    95                         errno = errtable[i].errnocode; 
    96                         return; 
    97                 } 
    98         } 
    99  
    100         /* The error code wasn't in the table.  We check for a range of */ 
    101         /* EACCES errors or exec failure errors (ENOEXEC).  Otherwise   */ 
    102         /* EINVAL is returned.                                          */ 
    103  
    104         if (dwErrorCode >= MIN_EACCES_RANGE && dwErrorCode <= MAX_EACCES_RANGE) 
    105                 errno = EACCES; 
    106         else 
    107                 if (dwErrorCode >= MIN_EXEC_ERROR && dwErrorCode <= MAX_EXEC_ERROR) 
    108                         errno = ENOEXEC; 
    109                 else 
    110                         errno = EINVAL; 
     85    errno = maperrno_func(GetLastError()); 
     86} 
     87 
     88int maperrno_func(DWORD dwErrorCode) 
     89{ 
     90    int i; 
     91 
     92    /* check the table for the OS error code */ 
     93    for (i = 0; i < ERRTABLESIZE; ++i) 
     94        if (dwErrorCode == errtable[i].oscode) 
     95            return errtable[i].errnocode; 
     96 
     97    /* The error code wasn't in the table.  We check for a range of */ 
     98    /* EACCES errors or exec failure errors (ENOEXEC).  Otherwise   */ 
     99    /* EINVAL is returned.                                          */ 
     100 
     101    if (dwErrorCode >= MIN_EACCES_RANGE && dwErrorCode <= MAX_EACCES_RANGE) 
     102        return EACCES; 
     103    else if (dwErrorCode >= MIN_EXEC_ERROR && dwErrorCode <= MAX_EXEC_ERROR) 
     104        return ENOEXEC; 
     105    else 
     106        return EINVAL; 
     107} 
     108 
     109LPWSTR base_getErrorMessage(DWORD err) 
     110{ 
     111    LPWSTR what; 
     112    DWORD res; 
     113 
     114    res = FormatMessageW( 
     115              (FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER), 
     116              NULL, 
     117              err, 
     118              MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), /* Default language */ 
     119              (LPWSTR) &what, 
     120              0, 
     121              NULL 
     122          ); 
     123    if (res == 0) 
     124        return NULL; 
     125    return what; 
    111126} 
    112127 
    113128int get_unique_file_info(int fd, HsWord64 *dev, HsWord64 *ino) 

  • include/HsBase.h 

    diff --git a/include/HsBase.h b/include/HsBase.h
index 74ab816..b1a62fd 100644
    a b  
    141141#if defined(__MINGW32__) 
    142142/* in Win32Utils.c */ 
    143143extern void maperrno (void); 
     144extern int maperrno_func(DWORD dwErrorCode); 
    144145extern HsWord64 getMonotonicUSec(void); 
    145146#endif 
    146147