Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC

Commits:

29 changed files:

Changes:

  • compiler/GHC/Cmm/Utils.hs
    ... ... @@ -37,6 +37,7 @@ module GHC.Cmm.Utils(
    37 37
    38 38 
             baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr,
    39 39 
             currentTSOExpr, currentNurseryExpr, cccsExpr,
    40 
    +        myCapabilityExpr,
    40 41
    41 42 
             -- Tagging
    42 43 
             cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged, cmmIsNotTagged,
    ... ... @@ -569,7 +570,7 @@ blockTicks b = reverse $ foldBlockNodesF goStmt b []
    569 570 
     -- Access to common global registers
    570 571
    571 572 
     baseExpr, spExpr, hpExpr, currentTSOExpr, currentNurseryExpr,
    572 
    -  spLimExpr, hpLimExpr, cccsExpr :: Platform -> CmmExpr
    573 
    +  spLimExpr, hpLimExpr, cccsExpr, myCapabilityExpr :: Platform -> CmmExpr
    573 574 
     baseExpr           p = CmmReg $ baseReg           p
    574 575 
     spExpr             p = CmmReg $ spReg             p
    575 576 
     spLimExpr          p = CmmReg $ spLimReg          p
    ... ... @@ -578,3 +579,5 @@ hpLimExpr p = CmmReg $ hpLimReg p
    578 579 
     currentTSOExpr     p = CmmReg $ currentTSOReg     p
    579 580 
     currentNurseryExpr p = CmmReg $ currentNurseryReg p
    580 581 
     cccsExpr           p = CmmReg $ cccsReg           p
    582 
    +myCapabilityExpr   p =
    583 
    +  cmmRegOff (baseReg p) $ negate $ pc_OFFSET_Capability_r $ platformConstants p

  • compiler/GHC/Iface/Ext/Utils.hs
    ... ... @@ -461,11 +461,11 @@ in which @foozball@ and @quuuuuux@ have overlapping spans:
    461 461 
     @
    462 462 
     module Baz where
    463 463
    464 
    -# line 3 "Baz.hs"
    464 
    +# \line 3 "Baz.hs"
    465 465 
     foozball :: Int
    466 466 
     foozball = 0
    467 467
    468 
    -# line 3 "Baz.hs"
    468 
    +# \line 3 "Baz.hs"
    469 469 
     bar, quuuuuux :: Int
    470 470 
     bar = 1
    471 471 
     quuuuuux = 2

  • compiler/GHC/StgToCmm/Prim.hs
    ... ... @@ -345,6 +345,25 @@ emitPrimOp cfg primop =
    345 345 
         emitPrimCall [res] (MO_Xchg (wordWidth platform)) [dst, val]
    346 346 
         emitDirtyMutVar mutv (CmmReg (CmmLocal res))
    347 347
    348 
    +  TryPutMVarOp -> \[mvar, val] -> inlinePrimop $ \[res] -> do
    349 
    +    cres <- newTemp b8
    350 
    +    emitCCall
    351 
    +      [(cres, NoHint)]
    352 
    +      ( CmmLit
    353 
    +          ( CmmLabel
    354 
    +              ( mkForeignLabel
    355 
    +                  (fsLit "performTryPutMVar")
    356 
    +                  ForeignLabelInExternalPackage
    357 
    +                  IsFunction
    358 
    +              )
    359 
    +          )
    360 
    +      )
    361 
    +      [(myCapabilityExpr platform, AddrHint), (mvar, AddrHint), (val, AddrHint)]
    362 
    +    emitAssign (CmmLocal res) $
    363 
    +      CmmMachOp
    364 
    +        (MO_UU_Conv W8 (wordWidth platform))
    365 
    +        [CmmReg (CmmLocal cres)]
    366 
    +
    348 367 
     --  #define sizzeofByteArrayzh(r,a) \
    349 368 
     --     r = ((StgArrBytes *)(a))->bytes
    350 369 
       SizeofByteArrayOp -> \[arg] -> inlinePrimop $ \[res] ->
    ... ... @@ -1777,7 +1796,6 @@ emitPrimOp cfg primop =
    1777 1796 
       TakeMVarOp -> alwaysExternal
    1778 1797 
       TryTakeMVarOp -> alwaysExternal
    1779 1798 
       PutMVarOp -> alwaysExternal
    1780 
    -  TryPutMVarOp -> alwaysExternal
    1781 1799 
       ReadMVarOp -> alwaysExternal
    1782 1800 
       TryReadMVarOp -> alwaysExternal
    1783 1801 
       IsEmptyMVarOp -> alwaysExternal

  • compiler/GHC/StgToJS/Object.hs
    ... ... @@ -72,7 +72,6 @@ import Data.List (sortOn)
    72 72 
     import qualified Data.List as List
    73 73 
     import           Data.Map (Map)
    74 74 
     import qualified Data.Map as M
    75 
    -import           Data.Word
    76 75 
     import           Data.Semigroup
    77 76 
     import           System.IO
    78 77

  • compiler/GHC/Tc/Gen/Foreign.hs
    ... ... @@ -449,8 +449,9 @@ tcFExport d = pprPanic "tcFExport" (ppr d)
    449 449
    450 450 
     tcCheckFEType :: Type -> ForeignExport GhcRn -> TcM (ForeignExport GhcTc)
    451 451 
     tcCheckFEType sig_ty edecl@(CExport src (L l (CExportStatic str cconv))) = do
    452 
    -    checkCg (Left edecl) backendValidityOfCExport
    453 
    -    when (cconv /= JavaScriptCallConv) $ checkTc (isCLabelString str) (TcRnInvalidCIdentifier str)
    452 
    +    when (cconv /= JavaScriptCallConv) $ do
    453 
    +      checkCg (Left edecl) backendValidityOfCExport
    454 
    +      checkTc (isCLabelString str) (TcRnInvalidCIdentifier str)
    454 455 
         cconv' <- checkCConv (Left edecl) cconv
    455 456 
         checkForeignArgs isFFIExternalTy arg_tys
    456 457 
         checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty

  • libraries/base/src/GHC/Fingerprint.hs
    ... ... @@ -9,3 +9,45 @@ module GHC.Fingerprint (
    9 9 
        ) where
    10 10
    11 11 
     import GHC.Internal.Fingerprint
    12 
    +
    13 
    +import Data.Function (($))
    14 
    +import Control.Monad (return, when)
    15 
    +import Data.Bool (not, (&&))
    16 
    +import Data.List ((++))
    17 
    +import Data.Maybe (Maybe (Nothing, Just))
    18 
    +import Data.Int (Int)
    19 
    +import Data.Word (Word8)
    20 
    +import Data.Eq ((/=))
    21 
    +import Text.Show (show)
    22 
    +import System.IO
    23 
    +       (
    24 
    +           IO,
    25 
    +           FilePath,
    26 
    +           IOMode (ReadMode),
    27 
    +           withBinaryFile,
    28 
    +           hGetBuf,
    29 
    +           hIsEOF
    30 
    +       )
    31 
    +import Foreign.Ptr (Ptr)
    32 
    +import GHC.Err (errorWithoutStackTrace)
    33 
    +
    34 
    +-- | Computes the hash of a given file.
    35 
    +-- This function runs in constant memory.
    36 
    +--
    37 
    +-- @since base-4.7.0.0
    38 
    +getFileHash :: FilePath -> IO Fingerprint
    39 
    +getFileHash path = withBinaryFile path ReadMode $ \ hdl ->
    40 
    +    let
    41 
    +        readChunk :: Ptr Word8 -> Int -> IO (Maybe Int)
    42 
    +        readChunk bufferPtr bufferSize = do
    43 
    +            chunkSize <- hGetBuf hdl bufferPtr bufferSize
    44 
    +            isFinished <- hIsEOF hdl
    45 
    +            when (chunkSize /= bufferSize && not isFinished)
    46 
    +                 (
    47 
    +                     errorWithoutStackTrace $
    48 
    +                     "GHC.Fingerprint.getFileHash: could only read " ++
    49 
    +                     show chunkSize                                  ++
    50 
    +                     " bytes, but more are available"
    51 
    +                 )
    52 
    +            return (if isFinished then Just chunkSize else Nothing)
    53 
    +    in fingerprintBufferedStream readChunk

  • libraries/base/src/GHC/ResponseFile.hs
    1 
    +{-# LANGUAGE ScopedTypeVariables #-}
    1 2 
     {-# LANGUAGE Safe #-}
    2 3
    3 4 
     -- |
    ... ... @@ -19,4 +20,145 @@ module GHC.ResponseFile (
    19 20 
         expandResponse
    20 21 
       ) where
    21 22
    22 
    -import GHC.Internal.ResponseFile
    23 
    +import Control.Monad      (return, (>>=), mapM)
    24 
    +import Control.Exception  (IOException, catch)
    25 
    +import Data.Function      (($), (.))
    26 
    +import Data.Bool          (Bool (False, True), otherwise, not, (||))
    27 
    +import Data.Char          (Char, isSpace)
    28 
    +import Data.List          ((++), map, filter, concat, reverse)
    29 
    +import Data.String        (String, unlines)
    30 
    +import Data.Functor       (fmap)
    31 
    +import Data.Foldable      (null, foldl')
    32 
    +import Data.Eq            ((==))
    33 
    +import Text.Show          (show)
    34 
    +import System.Environment (getArgs)
    35 
    +import System.IO          (IO, hPutStrLn, readFile, stderr)
    36 
    +import System.Exit        (exitFailure)
    37 
    +
    38 
    +{-|
    39 
    +Like 'getArgs', but can also read arguments supplied via response files.
    40 
    +
    41 
    +
    42 
    +For example, consider a program @foo@:
    43 
    +
    44 
    +@
    45 
    +main :: IO ()
    46 
    +main = do
    47 
    +  args <- getArgsWithResponseFiles
    48 
    +  putStrLn (show args)
    49 
    +@
    50 
    +
    51 
    +
    52 
    +And a response file @args.txt@:
    53 
    +
    54 
    +@
    55 
    +--one 1
    56 
    +--\'two\' 2
    57 
    +--"three" 3
    58 
    +@
    59 
    +
    60 
    +Then the result of invoking @foo@ with @args.txt@ is:
    61 
    +
    62 
    +> > ./foo @args.txt
    63 
    +> ["--one","1","--two","2","--three","3"]
    64 
    +
    65 
    +-}
    66 
    +getArgsWithResponseFiles :: IO [String]
    67 
    +getArgsWithResponseFiles = getArgs >>= expandResponse
    68 
    +
    69 
    +-- | Given a string of concatenated strings, separate each by removing
    70 
    +-- a layer of /quoting/ and\/or /escaping/ of certain characters.
    71 
    +--
    72 
    +-- These characters are: any whitespace, single quote, double quote,
    73 
    +-- and the backslash character.  The backslash character always
    74 
    +-- escapes (i.e., passes through without further consideration) the
    75 
    +-- character which follows.  Characters can also be escaped in blocks
    76 
    +-- by quoting (i.e., surrounding the blocks with matching pairs of
    77 
    +-- either single- or double-quotes which are not themselves escaped).
    78 
    +--
    79 
    +-- Any whitespace which appears outside of either of the quoting and
    80 
    +-- escaping mechanisms, is interpreted as having been added by this
    81 
    +-- special concatenation process to designate where the boundaries
    82 
    +-- are between the original, un-concatenated list of strings.  These
    83 
    +-- added whitespace characters are removed from the output.
    84 
    +--
    85 
    +-- > unescapeArgs "hello\\ \\\"world\\\"\n" == ["hello \"world\""]
    86 
    +unescapeArgs :: String -> [String]
    87 
    +unescapeArgs = filter (not . null) . unescape
    88 
    +
    89 
    +-- | Given a list of strings, concatenate them into a single string
    90 
    +-- with escaping of certain characters, and the addition of a newline
    91 
    +-- between each string.  The escaping is done by adding a single
    92 
    +-- backslash character before any whitespace, single quote, double
    93 
    +-- quote, or backslash character, so this escaping character must be
    94 
    +-- removed.  Unescaped whitespace (in this case, newline) is part
    95 
    +-- of this "transport" format to indicate the end of the previous
    96 
    +-- string and the start of a new string.
    97 
    +--
    98 
    +-- While 'unescapeArgs' allows using quoting (i.e., convenient
    99 
    +-- escaping of many characters) by having matching sets of single- or
    100 
    +-- double-quotes,'escapeArgs' does not use the quoting mechanism,
    101 
    +-- and thus will always escape any whitespace, quotes, and
    102 
    +-- backslashes.
    103 
    +--
    104 
    +-- > escapeArgs ["hello \"world\""] == "hello\\ \\\"world\\\"\n"
    105 
    +escapeArgs :: [String] -> String
    106 
    +escapeArgs = unlines . map escapeArg
    107 
    +
    108 
    +-- | Arguments which look like @\@foo@ will be replaced with the
    109 
    +-- contents of file @foo@. A gcc-like syntax for response files arguments
    110 
    +-- is expected.  This must re-constitute the argument list by doing an
    111 
    +-- inverse of the escaping mechanism done by the calling-program side.
    112 
    +--
    113 
    +-- We quit if the file is not found or reading somehow fails.
    114 
    +-- (A convenience routine for haddock or possibly other clients)
    115 
    +expandResponse :: [String] -> IO [String]
    116 
    +expandResponse = fmap concat . mapM expand
    117 
    +  where
    118 
    +    expand :: String -> IO [String]
    119 
    +    expand ('@':f) = readFileExc f >>= return . unescapeArgs
    120 
    +    expand x = return [x]
    121 
    +
    122 
    +    readFileExc f =
    123 
    +      readFile f `catch` \(e :: IOException) -> do
    124 
    +        hPutStrLn stderr $ "Error while expanding response file: " ++ show e
    125 
    +        exitFailure
    126 
    +
    127 
    +data Quoting = NoneQ | SngQ | DblQ
    128 
    +
    129 
    +unescape :: String -> [String]
    130 
    +unescape args = reverse . map reverse $ go args NoneQ False [] []
    131 
    +    where
    132 
    +      -- n.b., the order of these cases matters; these are cribbed from gcc
    133 
    +      -- case 1: end of input
    134 
    +      go []     _q    _bs   a as = a:as
    135 
    +      -- case 2: back-slash escape in progress
    136 
    +      go (c:cs) q     True  a as = go cs q     False (c:a) as
    137 
    +      -- case 3: no back-slash escape in progress, but got a back-slash
    138 
    +      go (c:cs) q     False a as
    139 
    +        | '\\' == c              = go cs q     True  a     as
    140 
    +      -- case 4: single-quote escaping in progress
    141 
    +      go (c:cs) SngQ  False a as
    142 
    +        | '\'' == c              = go cs NoneQ False a     as
    143 
    +        | otherwise              = go cs SngQ  False (c:a) as
    144 
    +      -- case 5: double-quote escaping in progress
    145 
    +      go (c:cs) DblQ  False a as
    146 
    +        | '"' == c               = go cs NoneQ False a     as
    147 
    +        | otherwise              = go cs DblQ  False (c:a) as
    148 
    +      -- case 6: no escaping is in progress
    149 
    +      go (c:cs) NoneQ False a as
    150 
    +        | isSpace c              = go cs NoneQ False []    (a:as)
    151 
    +        | '\'' == c              = go cs SngQ  False a     as
    152 
    +        | '"'  == c              = go cs DblQ  False a     as
    153 
    +        | otherwise              = go cs NoneQ False (c:a) as
    154 
    +
    155 
    +escapeArg :: String -> String
    156 
    +escapeArg = reverse . foldl' escape []
    157 
    +
    158 
    +escape :: String -> Char -> String
    159 
    +escape cs c
    160 
    +  |    isSpace c
    161 
    +    || '\\' == c
    162 
    +    || '\'' == c
    163 
    +    || '"'  == c = c:'\\':cs -- n.b., our caller must reverse the result
    164 
    +  | otherwise    = c:cs

  • libraries/base/src/System/Exit.hs
    ... ... @@ -21,4 +21,67 @@ module System.Exit
    21 21 
          die
    22 22 
          ) where
    23 23
    24 
    -import GHC.Internal.System.Exit
    \ No newline at end of file
    24 
    +import GHC.IO.Exception
    25 
    +       (
    26 
    +           IOErrorType (InvalidArgument),
    27 
    +           IOException (IOError),
    28 
    +           ExitCode (ExitSuccess, ExitFailure)
    29 
    +       )
    30 
    +import Control.Monad ((>>))
    31 
    +import Control.Exception (throwIO, ioError)
    32 
    +import Data.Bool (otherwise)
    33 
    +import Data.Maybe (Maybe (Nothing))
    34 
    +import Data.String (String)
    35 
    +import Data.Eq ((/=))
    36 
    +import System.IO (IO, hPutStrLn, stderr)
    37 
    +
    38 
    +-- ---------------------------------------------------------------------------
    39 
    +-- exitWith
    40 
    +
    41 
    +-- | Computation 'exitWith' @code@ throws 'ExitCode' @code@.
    42 
    +-- Normally this terminates the program, returning @code@ to the
    43 
    +-- program's caller.
    44 
    +--
    45 
    +-- On program termination, the standard 'Handle's 'stdout' and
    46 
    +-- 'stderr' are flushed automatically; any other buffered 'Handle's
    47 
    +-- need to be flushed manually, otherwise the buffered data will be
    48 
    +-- discarded.
    49 
    +--
    50 
    +-- A program that fails in any other way is treated as if it had
    51 
    +-- called 'exitFailure'.
    52 
    +-- A program that terminates successfully without calling 'exitWith'
    53 
    +-- explicitly is treated as if it had called 'exitWith' 'ExitSuccess'.
    54 
    +--
    55 
    +-- As an 'ExitCode' is an 'Control.Exception.Exception', it can be
    56 
    +-- caught using the functions of "Control.Exception".  This means that
    57 
    +-- cleanup computations added with 'GHC.Internal.Control.Exception.bracket' (from
    58 
    +-- "Control.Exception") are also executed properly on 'exitWith'.
    59 
    +--
    60 
    +-- Note: in GHC, 'exitWith' should be called from the main program
    61 
    +-- thread in order to exit the process.  When called from another
    62 
    +-- thread, 'exitWith' will throw an 'ExitCode' as normal, but the
    63 
    +-- exception will not cause the process itself to exit.
    64 
    +--
    65 
    +exitWith :: ExitCode -> IO a
    66 
    +exitWith ExitSuccess = throwIO ExitSuccess
    67 
    +exitWith code@(ExitFailure n)
    68 
    +  | n /= 0 = throwIO code
    69 
    +  | otherwise = ioError (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing Nothing)
    70 
    +
    71 
    +-- | The computation 'exitFailure' is equivalent to
    72 
    +-- 'exitWith' @(@'ExitFailure' /exitfail/@)@,
    73 
    +-- where /exitfail/ is implementation-dependent.
    74 
    +exitFailure :: IO a
    75 
    +exitFailure = exitWith (ExitFailure 1)
    76 
    +
    77 
    +-- | The computation 'exitSuccess' is equivalent to
    78 
    +-- 'exitWith' 'ExitSuccess', It terminates the program
    79 
    +-- successfully.
    80 
    +exitSuccess :: IO a
    81 
    +exitSuccess = exitWith ExitSuccess
    82 
    +
    83 
    +-- | Write given error message to `stderr` and terminate with `exitFailure`.
    84 
    +--
    85 
    +-- @since base-4.8.0.0
    86 
    +die :: String -> IO a
    87 
    +die err = hPutStrLn stderr err >> exitFailure

  • libraries/base/src/System/IO/OS.hs
    1 1 
     {-# LANGUAGE Safe #-}
    2 
    +{-# LANGUAGE CPP #-}
    3 
    +{-# LANGUAGE RankNTypes #-}
    2 4
    3 5 
     {-|
    4 6 
         This module bridges between Haskell handles and underlying operating-system
    ... ... @@ -21,17 +23,293 @@ module System.IO.OS
    21 23 
     )
    22 24 
     where
    23 25
    24 
    -import GHC.Internal.System.IO.OS
    26 
    +import Control.Monad (return)
    27 
    +import Control.Concurrent.MVar (MVar)
    28 
    +import Control.Exception (mask)
    29 
    +import Data.Function (const, (.), ($))
    30 
    +import Data.Functor (fmap)
    31 
    +import Data.Maybe (Maybe (Nothing), maybe)
    32 
    +#if defined(mingw32_HOST_OS)
    33 
    +import Data.Bool (otherwise)
    34 
    +import Data.Maybe (Maybe (Just))
    35 
    +#endif
    36 
    +import Data.List ((++))
    37 
    +import Data.String (String)
    38 
    +import Data.Typeable (Typeable, cast)
    39 
    +import System.IO (IO)
    40 
    +import GHC.IO.FD (fdFD)
    41 
    +#if defined(mingw32_HOST_OS)
    42 
    +import GHC.IO.Windows.Handle
    25 43 
            (
    26 
    -           withFileDescriptorReadingBiased,
    27 
    -           withFileDescriptorWritingBiased,
    28 
    -           withWindowsHandleReadingBiased,
    29 
    -           withWindowsHandleWritingBiased,
    30 
    -           withFileDescriptorReadingBiasedRaw,
    31 
    -           withFileDescriptorWritingBiasedRaw,
    32 
    -           withWindowsHandleReadingBiasedRaw,
    33 
    -           withWindowsHandleWritingBiasedRaw
    44 
    +           NativeHandle,
    45 
    +           ConsoleHandle,
    46 
    +           IoHandle,
    47 
    +           toHANDLE
    34 48 
            )
    49 
    +#endif
    50 
    +import GHC.IO.Handle.Types
    51 
    +       (
    52 
    +           Handle (FileHandle, DuplexHandle),
    53 
    +           Handle__ (Handle__, haDevice)
    54 
    +       )
    55 
    +import GHC.IO.Handle.Internals (withHandle_', flushBuffer)
    56 
    +import GHC.IO.Exception
    57 
    +       (
    58 
    +           IOErrorType (InappropriateType),
    59 
    +           IOException (IOError),
    60 
    +           ioException
    61 
    +       )
    62 
    +import Foreign.Ptr (Ptr)
    63 
    +import Foreign.C.Types (CInt)
    64 
    +
    65 
    +-- * Obtaining POSIX file descriptors and Windows handles
    66 
    +
    67 
    +{-|
    68 
    +    Executes a user-provided action on an operating-system handle that underlies
    69 
    +    a Haskell handle. Before the user-provided action is run, user-defined
    70 
    +    preparation based on the handle state that contains the operating-system
    71 
    +    handle is performed. While the user-provided action is executed, further
    72 
    +    operations on the Haskell handle are blocked to a degree that interference
    73 
    +    with this action is prevented.
    74 
    +
    75 
    +    See [below](#with-ref-caveats) for caveats regarding this operation.
    76 
    +-}
    77 
    +withOSHandle :: String
    78 
    +                -- ^ The name of the overall operation
    79 
    +             -> (Handle -> MVar Handle__)
    80 
    +                {-^
    81 
    +                    Obtaining of the handle state variable that holds the
    82 
    +                    operating-system handle
    83 
    +                -}
    84 
    +             -> (forall d. Typeable d => d -> IO a)
    85 
    +                -- ^ Conversion of a device into an operating-system handle
    86 
    +             -> (Handle__ -> IO ())
    87 
    +                -- ^ The preparation
    88 
    +             -> Handle
    89 
    +                -- ^ The Haskell handle to use
    90 
    +             -> (a -> IO r)
    91 
    +                -- ^ The action to execute on the operating-system handle
    92 
    +             -> IO r
    93 
    +withOSHandle opName handleStateVar getOSHandle prepare handle act
    94 
    +    = mask $ \ withOriginalMaskingState ->
    95 
    +      withHandleState $ \ handleState@Handle__ {haDevice = dev} -> do
    96 
    +          osHandle <- getOSHandle dev
    97 
    +          prepare handleState
    98 
    +          withOriginalMaskingState $ act osHandle
    99 
    +      where
    100 
    +
    101 
    +      withHandleState = withHandle_' opName handle (handleStateVar handle)
    102 
    +{-
    103 
    +    The 'withHandle_'' operation, which we use here, already performs masking.
    104 
    +    Still, we have to employ 'mask', in order do obtain the operation that
    105 
    +    restores the original masking state. The user-provided action should be
    106 
    +    executed with this original masking state, as there is no inherent reason to
    107 
    +    generally perform it with masking in place. The masking that 'withHandle_''
    108 
    +    performs is only for safely accessing handle state and thus constitutes an
    109 
    +    implementation detail; it has nothing to do with the user-provided action.
    110 
    +-}
    111 
    +{-
    112 
    +    The order of actions in 'withOSHandle' is such that any exception from
    113 
    +    'getOSHandle' is thrown before the user-defined preparation is performed.
    114 
    +-}
    115 
    +
    116 
    +{-|
    117 
    +    Obtains the handle state variable that underlies a handle or specifically
    118 
    +    the handle state variable for reading if the handle uses different state
    119 
    +    variables for reading and writing.
    120 
    +-}
    121 
    +handleStateVarReadingBiased :: Handle -> MVar Handle__
    122 
    +handleStateVarReadingBiased (FileHandle _ var)            = var
    123 
    +handleStateVarReadingBiased (DuplexHandle _ readingVar _) = readingVar
    124 
    +
    125 
    +{-|
    126 
    +    Obtains the handle state variable that underlies a handle or specifically
    127 
    +    the handle state variable for writing if the handle uses different state
    128 
    +    variables for reading and writing.
    129 
    +-}
    130 
    +handleStateVarWritingBiased :: Handle -> MVar Handle__
    131 
    +handleStateVarWritingBiased (FileHandle _ var)            = var
    132 
    +handleStateVarWritingBiased (DuplexHandle _ _ writingVar) = writingVar
    133 
    +
    134 
    +{-|
    135 
    +    Yields the result of another operation if that operation succeeded, and
    136 
    +    otherwise throws an exception that signals that the other operation failed
    137 
    +    because some Haskell handle does not use an operating-system handle of a
    138 
    +    required type.
    139 
    +-}
    140 
    +requiringOSHandleOfType :: String
    141 
    +                           -- ^ The name of the operating-system handle type
    142 
    +                        -> Maybe a
    143 
    +                           {-^
    144 
    +                               The result of the other operation if it succeeded
    145 
    +                           -}
    146 
    +                        -> IO a
    147 
    +requiringOSHandleOfType osHandleTypeName
    148 
    +    = maybe (ioException osHandleOfTypeRequired) return
    149 
    +    where
    150 
    +
    151 
    +    osHandleOfTypeRequired :: IOException
    152 
    +    osHandleOfTypeRequired
    153 
    +        = IOError Nothing
    154 
    +                  InappropriateType
    155 
    +                  ""
    156 
    +                  ("handle does not use " ++ osHandleTypeName ++ "s")
    157 
    +                  Nothing
    158 
    +                  Nothing
    159 
    +
    160 
    +{-|
    161 
    +    Obtains the POSIX file descriptor of a device if the device contains one,
    162 
    +    and throws an exception otherwise.
    163 
    +-}
    164 
    +getFileDescriptor :: Typeable d => d -> IO CInt
    165 
    +getFileDescriptor = requiringOSHandleOfType "POSIX file descriptor" .
    166 
    +                    fmap fdFD . cast
    167 
    +
    168 
    +{-|
    169 
    +    Obtains the Windows handle of a device if the device contains one, and
    170 
    +    throws an exception otherwise.
    171 
    +-}
    172 
    +getWindowsHandle :: Typeable d => d -> IO (Ptr ())
    173 
    +getWindowsHandle = requiringOSHandleOfType "Windows handle" .
    174 
    +                   toMaybeWindowsHandle
    175 
    +    where
    176 
    +
    177 
    +    toMaybeWindowsHandle :: Typeable d => d -> Maybe (Ptr ())
    178 
    +#if defined(mingw32_HOST_OS)
    179 
    +    toMaybeWindowsHandle dev
    180 
    +        | Just nativeHandle <- cast dev :: Maybe (IoHandle NativeHandle)
    181 
    +            = Just (toHANDLE nativeHandle)
    182 
    +        | Just consoleHandle <- cast dev :: Maybe (IoHandle ConsoleHandle)
    183 
    +            = Just (toHANDLE consoleHandle)
    184 
    +        | otherwise
    185 
    +            = Nothing
    186 
    +    {-
    187 
    +        This is inspired by the implementation of
    188 
    +        'System.Win32.Types.withHandleToHANDLENative'.
    189 
    +    -}
    190 
    +#else
    191 
    +    toMaybeWindowsHandle _ = Nothing
    192 
    +#endif
    193 
    +
    194 
    +{-|
    195 
    +    Executes a user-provided action on the POSIX file descriptor that underlies
    196 
    +    a handle or specifically on the POSIX file descriptor for reading if the
    197 
    +    handle uses different file descriptors for reading and writing. The
    198 
    +    Haskell-managed buffers related to the file descriptor are flushed before
    199 
    +    the user-provided action is run. While this action is executed, further
    200 
    +    operations on the handle are blocked to a degree that interference with this
    201 
    +    action is prevented.
    202 
    +
    203 
    +    If the handle does not use POSIX file descriptors, an exception is thrown.
    204 
    +
    205 
    +    See [below](#with-ref-caveats) for caveats regarding this operation.
    206 
    +-}
    207 
    +withFileDescriptorReadingBiased :: Handle -> (CInt -> IO r) -> IO r
    208 
    +withFileDescriptorReadingBiased = withOSHandle "withFileDescriptorReadingBiased"
    209 
    +                                               handleStateVarReadingBiased
    210 
    +                                               getFileDescriptor
    211 
    +                                               flushBuffer
    212 
    +
    213 
    +{-|
    214 
    +    Executes a user-provided action on the POSIX file descriptor that underlies
    215 
    +    a handle or specifically on the POSIX file descriptor for writing if the
    216 
    +    handle uses different file descriptors for reading and writing. The
    217 
    +    Haskell-managed buffers related to the file descriptor are flushed before
    218 
    +    the user-provided action is run. While this action is executed, further
    219 
    +    operations on the handle are blocked to a degree that interference with this
    220 
    +    action is prevented.
    221 
    +
    222 
    +    If the handle does not use POSIX file descriptors, an exception is thrown.
    223 
    +
    224 
    +    See [below](#with-ref-caveats) for caveats regarding this operation.
    225 
    +-}
    226 
    +withFileDescriptorWritingBiased :: Handle -> (CInt -> IO r) -> IO r
    227 
    +withFileDescriptorWritingBiased = withOSHandle "withFileDescriptorWritingBiased"
    228 
    +                                               handleStateVarWritingBiased
    229 
    +                                               getFileDescriptor
    230 
    +                                               flushBuffer
    231 
    +
    232 
    +{-|
    233 
    +    Executes a user-provided action on the Windows handle that underlies a
    234 
    +    Haskell handle or specifically on the Windows handle for reading if the
    235 
    +    Haskell handle uses different Windows handles for reading and writing. The
    236 
    +    Haskell-managed buffers related to the Windows handle are flushed before the
    237 
    +    user-provided action is run. While this action is executed, further
    238 
    +    operations on the Haskell handle are blocked to a degree that interference
    239 
    +    with this action is prevented.
    240 
    +
    241 
    +    If the Haskell handle does not use Windows handles, an exception is thrown.
    242 
    +
    243 
    +    See [below](#with-ref-caveats) for caveats regarding this operation.
    244 
    +-}
    245 
    +withWindowsHandleReadingBiased :: Handle -> (Ptr () -> IO r) -> IO r
    246 
    +withWindowsHandleReadingBiased = withOSHandle "withWindowsHandleReadingBiased"
    247 
    +                                              handleStateVarReadingBiased
    248 
    +                                              getWindowsHandle
    249 
    +                                              flushBuffer
    250 
    +
    251 
    +{-|
    252 
    +    Executes a user-provided action on the Windows handle that underlies a
    253 
    +    Haskell handle or specifically on the Windows handle for writing if the
    254 
    +    Haskell handle uses different Windows handles for reading and writing. The
    255 
    +    Haskell-managed buffers related to the Windows handle are flushed before the
    256 
    +    user-provided action is run. While this action is executed, further
    257 
    +    operations on the Haskell handle are blocked to a degree that interference
    258 
    +    with this action is prevented.
    259 
    +
    260 
    +    If the Haskell handle does not use Windows handles, an exception is thrown.
    261 
    +
    262 
    +    See [below](#with-ref-caveats) for caveats regarding this operation.
    263 
    +-}
    264 
    +withWindowsHandleWritingBiased :: Handle -> (Ptr () -> IO r) -> IO r
    265 
    +withWindowsHandleWritingBiased = withOSHandle "withWindowsHandleWritingBiased"
    266 
    +                                              handleStateVarWritingBiased
    267 
    +                                              getWindowsHandle
    268 
    +                                              flushBuffer
    269 
    +
    270 
    +{-|
    271 
    +    Like 'withFileDescriptorReadingBiased' except that Haskell-managed buffers
    272 
    +    are not flushed.
    273 
    +-}
    274 
    +withFileDescriptorReadingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r
    275 
    +withFileDescriptorReadingBiasedRaw
    276 
    +    = withOSHandle "withFileDescriptorReadingBiasedRaw"
    277 
    +                   handleStateVarReadingBiased
    278 
    +                   getFileDescriptor
    279 
    +                   (const $ return ())
    280 
    +
    281 
    +{-|
    282 
    +    Like 'withFileDescriptorWritingBiased' except that Haskell-managed buffers
    283 
    +    are not flushed.
    284 
    +-}
    285 
    +withFileDescriptorWritingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r
    286 
    +withFileDescriptorWritingBiasedRaw
    287 
    +    = withOSHandle "withFileDescriptorWritingBiasedRaw"
    288 
    +                   handleStateVarWritingBiased
    289 
    +                   getFileDescriptor
    290 
    +                   (const $ return ())
    291 
    +
    292 
    +{-|
    293 
    +    Like 'withWindowsHandleReadingBiased' except that Haskell-managed buffers
    294 
    +    are not flushed.
    295 
    +-}
    296 
    +withWindowsHandleReadingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r
    297 
    +withWindowsHandleReadingBiasedRaw
    298 
    +    = withOSHandle "withWindowsHandleReadingBiasedRaw"
    299 
    +                   handleStateVarReadingBiased
    300 
    +                   getWindowsHandle
    301 
    +                   (const $ return ())
    302 
    +
    303 
    +{-|
    304 
    +    Like 'withWindowsHandleWritingBiased' except that Haskell-managed buffers
    305 
    +    are not flushed.
    306 
    +-}
    307 
    +withWindowsHandleWritingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r
    308 
    +withWindowsHandleWritingBiasedRaw
    309 
    +    = withOSHandle "withWindowsHandleWritingBiasedRaw"
    310 
    +                   handleStateVarWritingBiased
    311 
    +                   getWindowsHandle
    312 
    +                   (const $ return ())
    35 313
    36 314 
     -- ** Caveats
    37 315

  • libraries/base/tests/IO/T18832.hs
    ... ... @@ -41,7 +41,6 @@ test dir' = do
    41 41
    42 42 
       -- cleanup
    43 43 
       mapM_ killThread [interrupter, deleter, closer]
    44 
    -  removeDirectoryRecursive dir
    45 44
    46 45 
       either throwIO (const $ putStrLn "No failures observed - success") result
    47 46

  • libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
    1 
    -{-# LANGUAGE CPP #-}
    2 
    -{-# LANGUAGE ForeignFunctionInterface #-}
    3 
    -{-# LANGUAGE GHCForeignImportPrim #-}
    4 
    -{-# LANGUAGE MagicHash #-}
    5 
    -{-# LANGUAGE RecordWildCards #-}
    6 
    -{-# LANGUAGE UnliftedFFITypes #-}
    7 
    -{-# LANGUAGE DeriveGeneric #-}
    8 
    -{-# LANGUAGE DeriveTraversable #-}
    9 
    --- Late cost centres introduce a thunk in the asBox function, which leads to
    10 
    --- an additional wrapper being added to any value placed inside a box.
    11 
    --- This can be removed once our boot compiler is no longer affected by #25212
    12 
    -{-# OPTIONS_GHC -fno-prof-late  #-}
    13 
    -{-# LANGUAGE NamedFieldPuns #-}
    14 
    -
    15 1 
     module GHC.Exts.Heap.Closures (
    16 2 
         -- * Closures
    17 3 
           Closure

  • libraries/ghc-internal/ghc-internal.cabal.in
    ... ... @@ -284,7 +284,6 @@ Library
    284 284 
             GHC.Internal.Read
    285 285 
             GHC.Internal.Real
    286 286 
             GHC.Internal.Records
    287 
    -        GHC.Internal.ResponseFile
    288 287 
             GHC.Internal.RTS.Flags
    289 288 
             GHC.Internal.RTS.Flags.Test
    290 289 
             GHC.Internal.ST
    ... ... @@ -324,10 +323,8 @@ Library
    324 323 
             GHC.Internal.Numeric.Natural
    325 324 
             GHC.Internal.System.Environment
    326 325 
             GHC.Internal.System.Environment.Blank
    327 
    -        GHC.Internal.System.Exit
    328 326 
             GHC.Internal.System.IO
    329 327 
             GHC.Internal.System.IO.Error
    330 
    -        GHC.Internal.System.IO.OS
    331 328 
             GHC.Internal.System.Mem
    332 329 
             GHC.Internal.System.Mem.StableName
    333 330 
             GHC.Internal.System.Posix.Internals

  • libraries/ghc-internal/src/GHC/Internal/Data/Version.hs
    ... ... @@ -41,8 +41,7 @@ import GHC.Internal.Data.Eq
    41 41 
     import GHC.Internal.Int              ( Int )
    42 42 
     import GHC.Internal.Data.List        ( map, sort, concat, concatMap, intersperse, (++) )
    43 43 
     import GHC.Internal.Data.Ord
    44 
    -import GHC.Internal.Data.String      ( String )
    45 
    -import GHC.Internal.Base             ( Applicative(..), (&&) )
    44 
    +import GHC.Internal.Base             ( Applicative(..), (&&), String )
    46 45 
     import GHC.Internal.Generics
    47 46 
     import GHC.Internal.Unicode          ( isDigit, isAlphaNum )
    48 47 
     import GHC.Internal.Read

  • libraries/ghc-internal/src/GHC/Internal/Fingerprint.hs
    ... ... @@ -16,23 +16,22 @@ module GHC.Internal.Fingerprint (
    16 16 
             fingerprintData,
    17 17 
             fingerprintString,
    18 18 
             fingerprintFingerprints,
    19 
    -        getFileHash
    19 
    +        fingerprintBufferedStream
    20 20 
        ) where
    21 21
    22 22 
     import GHC.Internal.IO
    23 23 
     import GHC.Internal.Base
    24 24 
     import GHC.Internal.Bits
    25 25 
     import GHC.Internal.Num
    26 
    +import GHC.Internal.Data.Maybe
    26 27 
     import GHC.Internal.List
    27 28 
     import GHC.Internal.Real
    28 29 
     import GHC.Internal.Word
    29 
    -import GHC.Internal.Show
    30 30 
     import GHC.Internal.Ptr
    31 31 
     import GHC.Internal.Foreign.C.Types
    32 32 
     import GHC.Internal.Foreign.Marshal.Alloc
    33 33 
     import GHC.Internal.Foreign.Marshal.Array
    34 34 
     import GHC.Internal.Foreign.Storable
    35 
    -import GHC.Internal.System.IO
    36 35
    37 36 
     import GHC.Internal.Fingerprint.Type
    38 37
    ... ... @@ -71,41 +70,27 @@ fingerprintString str = unsafeDupablePerformIO $
    71 70 
                         fromIntegral (w32 `shiftR` 8),
    72 71 
                         fromIntegral w32]
    73 72
    74 
    --- | Computes the hash of a given file.
    75 
    --- This function loops over the handle, running in constant memory.
    76 
    ---
    77 
    --- @since base-4.7.0.0
    78 
    -getFileHash :: FilePath -> IO Fingerprint
    79 
    -getFileHash path = withBinaryFile path ReadMode $ \h ->
    73 
    +-- | Reads data in chunks and computes its hash.
    74 
    +-- This function runs in constant memory.
    75 
    +fingerprintBufferedStream :: (Ptr Word8 -> Int -> IO (Maybe Int))
    76 
    +                          -> IO Fingerprint
    77 
    +fingerprintBufferedStream readChunk =
    80 78 
       allocaBytes SIZEOF_STRUCT_MD5CONTEXT $ \pctxt -> do
    81 79 
         c_MD5Init pctxt
    82 
    -
    83 
    -    processChunks h (\buf size -> c_MD5Update pctxt buf (fromIntegral size))
    84 
    -
    80 
    +    allocaBytes _BUFSIZE $ \arrPtr ->
    81 
    +      let loop = do
    82 
    +            maybeRemainderSize <- readChunk arrPtr _BUFSIZE
    83 
    +            c_MD5Update pctxt
    84 
    +                        arrPtr
    85 
    +                        (fromIntegral (fromMaybe _BUFSIZE maybeRemainderSize))
    86 
    +            when (isNothing maybeRemainderSize) loop
    87 
    +      in loop
    85 88 
         allocaBytes 16 $ \pdigest -> do
    86 89 
           c_MD5Final pdigest pctxt
    87 90 
           peek (castPtr pdigest :: Ptr Fingerprint)
    88 
    -
    89 91 
       where
    90 92 
         _BUFSIZE = 4096
    91 93
    92 
    -    -- Loop over _BUFSIZE sized chunks read from the handle,
    93 
    -    -- passing the callback a block of bytes and its size.
    94 
    -    processChunks :: Handle -> (Ptr Word8 -> Int -> IO ()) -> IO ()
    95 
    -    processChunks h f = allocaBytes _BUFSIZE $ \arrPtr ->
    96 
    -
    97 
    -      let loop = do
    98 
    -            count <- hGetBuf h arrPtr _BUFSIZE
    99 
    -            eof <- hIsEOF h
    100 
    -            when (count /= _BUFSIZE && not eof) $ errorWithoutStackTrace $
    101 
    -              "GHC.Internal.Fingerprint.getFileHash: only read " ++ show count ++ " bytes"
    102 
    -
    103 
    -            f arrPtr count
    104 
    -
    105 
    -            when (not eof) loop
    106 
    -
    107 
    -      in loop
    108 
    -
    109 94 
     data MD5Context
    110 95
    111 96 
     foreign import ccall unsafe "__hsbase_MD5Init"

  • libraries/ghc-internal/src/GHC/Internal/GHCi/Helpers.hs
    ... ... @@ -24,9 +24,10 @@ module GHC.Internal.GHCi.Helpers
    24 24 
       , evalWrapper
    25 25 
       ) where
    26 26
    27 
    -import GHC.Internal.Base
    28 
    -import GHC.Internal.System.IO
    29 
    -import GHC.Internal.System.Environment
    27 
    +import GHC.Internal.Base (String, IO)
    28 
    +import GHC.Internal.IO.Handle (BufferMode (NoBuffering), hSetBuffering, hFlush)
    29 
    +import GHC.Internal.IO.StdHandles (stdin, stdout, stderr)
    30 
    +import GHC.Internal.System.Environment (withProgName, withArgs)
    30 31
    31 32 
     disableBuffering :: IO ()
    32 33 
     disableBuffering = do

  • libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs deleted
    1 
    -{-# LANGUAGE ScopedTypeVariables #-}
    2 
    -{-# LANGUAGE Trustworthy #-}
    3 
    -
    4 
    ------------------------------------------------------------------------------
    5 
    --- |
    6 
    --- Module      :  GHC.Internal.ResponseFile
    7 
    --- License     :  BSD-style (see the file LICENSE)
    8 
    ---
    9 
    --- Maintainer  :  libraries@haskell.org
    10 
    --- Stability   :  internal
    11 
    --- Portability :  portable
    12 
    ---
    13 
    --- GCC style response files.
    14 
    ---
    15 
    --- @since base-4.12.0.0
    16 
    -----------------------------------------------------------------------------
    17 
    -
    18 
    --- Migrated from Haddock.
    19 
    -
    20 
    -module GHC.Internal.ResponseFile (
    21 
    -    getArgsWithResponseFiles,
    22 
    -    unescapeArgs,
    23 
    -    escapeArgs, escapeArg,
    24 
    -    expandResponse
    25 
    -  ) where
    26 
    -
    27 
    -import GHC.Internal.Control.Exception
    28 
    -import GHC.Internal.Data.Foldable      (Foldable(..))
    29 
    -import GHC.Internal.Base
    30 
    -import GHC.Internal.Unicode        (isSpace)
    31 
    -import GHC.Internal.Data.List          (filter, unlines, concat, reverse)
    32 
    -import GHC.Internal.Text.Show          (show)
    33 
    -import GHC.Internal.System.Environment (getArgs)
    34 
    -import GHC.Internal.System.Exit        (exitFailure)
    35 
    -import GHC.Internal.System.IO
    36 
    -
    37 
    -{-|
    38 
    -Like 'getArgs', but can also read arguments supplied via response files.
    39 
    -
    40 
    -
    41 
    -For example, consider a program @foo@:
    42 
    -
    43 
    -@
    44 
    -main :: IO ()
    45 
    -main = do
    46 
    -  args <- getArgsWithResponseFiles
    47 
    -  putStrLn (show args)
    48 
    -@
    49 
    -
    50 
    -
    51 
    -And a response file @args.txt@:
    52 
    -
    53 
    -@
    54 
    ---one 1
    55 
    ---\'two\' 2
    56 
    ---"three" 3
    57 
    -@
    58 
    -
    59 
    -Then the result of invoking @foo@ with @args.txt@ is:
    60 
    -
    61 
    -> > ./foo @args.txt
    62 
    -> ["--one","1","--two","2","--three","3"]
    63 
    -
    64 
    --}
    65 
    -getArgsWithResponseFiles :: IO [String]
    66 
    -getArgsWithResponseFiles = getArgs >>= expandResponse
    67 
    -
    68 
    --- | Given a string of concatenated strings, separate each by removing
    69 
    --- a layer of /quoting/ and\/or /escaping/ of certain characters.
    70 
    ---
    71 
    --- These characters are: any whitespace, single quote, double quote,
    72 
    --- and the backslash character.  The backslash character always
    73 
    --- escapes (i.e., passes through without further consideration) the
    74 
    --- character which follows.  Characters can also be escaped in blocks
    75 
    --- by quoting (i.e., surrounding the blocks with matching pairs of
    76 
    --- either single- or double-quotes which are not themselves escaped).
    77 
    ---
    78 
    --- Any whitespace which appears outside of either of the quoting and
    79 
    --- escaping mechanisms, is interpreted as having been added by this
    80 
    --- special concatenation process to designate where the boundaries
    81 
    --- are between the original, un-concatenated list of strings.  These
    82 
    --- added whitespace characters are removed from the output.
    83 
    ---
    84 
    --- > unescapeArgs "hello\\ \\\"world\\\"\n" == ["hello \"world\""]
    85 
    -unescapeArgs :: String -> [String]
    86 
    -unescapeArgs = filter (not . null) . unescape
    87 
    -
    88 
    --- | Given a list of strings, concatenate them into a single string
    89 
    --- with escaping of certain characters, and the addition of a newline
    90 
    --- between each string.  The escaping is done by adding a single
    91 
    --- backslash character before any whitespace, single quote, double
    92 
    --- quote, or backslash character, so this escaping character must be
    93 
    --- removed.  Unescaped whitespace (in this case, newline) is part
    94 
    --- of this "transport" format to indicate the end of the previous
    95 
    --- string and the start of a new string.
    96 
    ---
    97 
    --- While 'unescapeArgs' allows using quoting (i.e., convenient
    98 
    --- escaping of many characters) by having matching sets of single- or
    99 
    --- double-quotes,'escapeArgs' does not use the quoting mechanism,
    100 
    --- and thus will always escape any whitespace, quotes, and
    101 
    --- backslashes.
    102 
    ---
    103 
    --- > escapeArgs ["hello \"world\""] == "hello\\ \\\"world\\\"\n"
    104 
    -escapeArgs :: [String] -> String
    105 
    -escapeArgs = unlines . map escapeArg
    106 
    -
    107 
    --- | Arguments which look like @\@foo@ will be replaced with the
    108 
    --- contents of file @foo@. A gcc-like syntax for response files arguments
    109 
    --- is expected.  This must re-constitute the argument list by doing an
    110 
    --- inverse of the escaping mechanism done by the calling-program side.
    111 
    ---
    112 
    --- We quit if the file is not found or reading somehow fails.
    113 
    --- (A convenience routine for haddock or possibly other clients)
    114 
    -expandResponse :: [String] -> IO [String]
    115 
    -expandResponse = fmap concat . mapM expand
    116 
    -  where
    117 
    -    expand :: String -> IO [String]
    118 
    -    expand ('@':f) = readFileExc f >>= return . unescapeArgs
    119 
    -    expand x = return [x]
    120 
    -
    121 
    -    readFileExc f =
    122 
    -      readFile f `catch` \(e :: IOException) -> do
    123 
    -        hPutStrLn stderr $ "Error while expanding response file: " ++ show e
    124 
    -        exitFailure
    125 
    -
    126 
    -data Quoting = NoneQ | SngQ | DblQ
    127 
    -
    128 
    -unescape :: String -> [String]
    129 
    -unescape args = reverse . map reverse $ go args NoneQ False [] []
    130 
    -    where
    131 
    -      -- n.b., the order of these cases matters; these are cribbed from gcc
    132 
    -      -- case 1: end of input
    133 
    -      go []     _q    _bs   a as = a:as
    134 
    -      -- case 2: back-slash escape in progress
    135 
    -      go (c:cs) q     True  a as = go cs q     False (c:a) as
    136 
    -      -- case 3: no back-slash escape in progress, but got a back-slash
    137 
    -      go (c:cs) q     False a as
    138 
    -        | '\\' == c              = go cs q     True  a     as
    139 
    -      -- case 4: single-quote escaping in progress
    140 
    -      go (c:cs) SngQ  False a as
    141 
    -        | '\'' == c              = go cs NoneQ False a     as
    142 
    -        | otherwise              = go cs SngQ  False (c:a) as
    143 
    -      -- case 5: double-quote escaping in progress
    144 
    -      go (c:cs) DblQ  False a as
    145 
    -        | '"' == c               = go cs NoneQ False a     as
    146 
    -        | otherwise              = go cs DblQ  False (c:a) as
    147 
    -      -- case 6: no escaping is in progress
    148 
    -      go (c:cs) NoneQ False a as
    149 
    -        | isSpace c              = go cs NoneQ False []    (a:as)
    150 
    -        | '\'' == c              = go cs SngQ  False a     as
    151 
    -        | '"'  == c              = go cs DblQ  False a     as
    152 
    -        | otherwise              = go cs NoneQ False (c:a) as
    153 
    -
    154 
    -escapeArg :: String -> String
    155 
    -escapeArg = reverse . foldl' escape []
    156 
    -
    157 
    -escape :: String -> Char -> String
    158 
    -escape cs c
    159 
    -  |    isSpace c
    160 
    -    || '\\' == c
    161 
    -    || '\'' == c
    162 
    -    || '"'  == c = c:'\\':cs -- n.b., our caller must reverse the result
    163 
    -  | otherwise    = c:cs

  • libraries/ghc-internal/src/GHC/Internal/System/Exit.hs deleted
    1 
    -{-# LANGUAGE Trustworthy #-}
    2 
    -
    3 
    ------------------------------------------------------------------------------
    4 
    --- |
    5 
    --- Module      :  GHC.Internal.System.Exit
    6 
    --- Copyright   :  (c) The University of Glasgow 2001
    7 
    --- License     :  BSD-style (see the file libraries/base/LICENSE)
    8 
    ---
    9 
    --- Maintainer  :  libraries@haskell.org
    10 
    --- Stability   :  provisional
    11 
    --- Portability :  portable
    12 
    ---
    13 
    --- Exiting the program.
    14 
    ---
    15 
    ------------------------------------------------------------------------------
    16 
    -
    17 
    -module GHC.Internal.System.Exit
    18 
    -    (
    19 
    -      ExitCode(ExitSuccess,ExitFailure)
    20 
    -    , exitWith
    21 
    -    , exitFailure
    22 
    -    , exitSuccess
    23 
    -    , die
    24 
    -  ) where
    25 
    -
    26 
    -import GHC.Internal.System.IO
    27 
    -
    28 
    -import GHC.Internal.Base
    29 
    -import GHC.Internal.IO
    30 
    -import GHC.Internal.IO.Exception
    31 
    -
    32 
    --- ---------------------------------------------------------------------------
    33 
    --- exitWith
    34 
    -
    35 
    --- | Computation 'exitWith' @code@ throws 'ExitCode' @code@.
    36 
    --- Normally this terminates the program, returning @code@ to the
    37 
    --- program's caller.
    38 
    ---
    39 
    --- On program termination, the standard 'Handle's 'stdout' and
    40 
    --- 'stderr' are flushed automatically; any other buffered 'Handle's
    41 
    --- need to be flushed manually, otherwise the buffered data will be
    42 
    --- discarded.
    43 
    ---
    44 
    --- A program that fails in any other way is treated as if it had
    45 
    --- called 'exitFailure'.
    46 
    --- A program that terminates successfully without calling 'exitWith'
    47 
    --- explicitly is treated as if it had called 'exitWith' 'ExitSuccess'.
    48 
    ---
    49 
    --- As an 'ExitCode' is an 'Control.Exception.Exception', it can be
    50 
    --- caught using the functions of "Control.Exception".  This means that
    51 
    --- cleanup computations added with 'GHC.Internal.Control.Exception.bracket' (from
    52 
    --- "Control.Exception") are also executed properly on 'exitWith'.
    53 
    ---
    54 
    --- Note: in GHC, 'exitWith' should be called from the main program
    55 
    --- thread in order to exit the process.  When called from another
    56 
    --- thread, 'exitWith' will throw an 'ExitCode' as normal, but the
    57 
    --- exception will not cause the process itself to exit.
    58 
    ---
    59 
    -exitWith :: ExitCode -> IO a
    60 
    -exitWith ExitSuccess = throwIO ExitSuccess
    61 
    -exitWith code@(ExitFailure n)
    62 
    -  | n /= 0 = throwIO code
    63 
    -  | otherwise = ioError (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing Nothing)
    64 
    -
    65 
    --- | The computation 'exitFailure' is equivalent to
    66 
    --- 'exitWith' @(@'ExitFailure' /exitfail/@)@,
    67 
    --- where /exitfail/ is implementation-dependent.
    68 
    -exitFailure :: IO a
    69 
    -exitFailure = exitWith (ExitFailure 1)
    70 
    -
    71 
    --- | The computation 'exitSuccess' is equivalent to
    72 
    --- 'exitWith' 'ExitSuccess', It terminates the program
    73 
    --- successfully.
    74 
    -exitSuccess :: IO a
    75 
    -exitSuccess = exitWith ExitSuccess
    76 
    -
    77 
    --- | Write given error message to `stderr` and terminate with `exitFailure`.
    78 
    ---
    79 
    --- @since base-4.8.0.0
    80 
    -die :: String -> IO a
    81 
    -die err = hPutStrLn stderr err >> exitFailure

  • libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs deleted
    1 
    -{-# LANGUAGE Trustworthy #-}
    2 
    -{-# LANGUAGE CPP #-}
    3 
    -{-# LANGUAGE RankNTypes #-}
    4 
    -
    5 
    -{-|
    6 
    -    This module bridges between Haskell handles and underlying operating-system
    7 
    -    features.
    8 
    --}
    9 
    -module GHC.Internal.System.IO.OS
    10 
    -(
    11 
    -    -- * Obtaining file descriptors and Windows handles
    12 
    -    withFileDescriptorReadingBiased,
    13 
    -    withFileDescriptorWritingBiased,
    14 
    -    withWindowsHandleReadingBiased,
    15 
    -    withWindowsHandleWritingBiased,
    16 
    -    withFileDescriptorReadingBiasedRaw,
    17 
    -    withFileDescriptorWritingBiasedRaw,
    18 
    -    withWindowsHandleReadingBiasedRaw,
    19 
    -    withWindowsHandleWritingBiasedRaw
    20 
    -
    21 
    -    -- ** Caveats
    22 
    -    -- $with-ref-caveats
    23 
    -)
    24 
    -where
    25 
    -
    26 
    -#if defined(mingw32_HOST_OS)
    27 
    -import GHC.Internal.Base (otherwise)
    28 
    -#endif
    29 
    -import GHC.Internal.Control.Monad (return)
    30 
    -import GHC.Internal.Control.Concurrent.MVar (MVar)
    31 
    -import GHC.Internal.Control.Exception (mask)
    32 
    -import GHC.Internal.Data.Function (const, (.), ($))
    33 
    -import GHC.Internal.Data.Functor (fmap)
    34 
    -import GHC.Internal.Data.Maybe (Maybe (Nothing), maybe)
    35 
    -#if defined(mingw32_HOST_OS)
    36 
    -import GHC.Internal.Data.Maybe (Maybe (Just))
    37 
    -#endif
    38 
    -import GHC.Internal.Data.List ((++))
    39 
    -import GHC.Internal.Data.String (String)
    40 
    -import GHC.Internal.Data.Typeable (Typeable, cast)
    41 
    -import GHC.Internal.System.IO (IO)
    42 
    -import GHC.Internal.IO.FD (fdFD)
    43 
    -#if defined(mingw32_HOST_OS)
    44 
    -import GHC.Internal.IO.Windows.Handle
    45 
    -       (
    46 
    -           NativeHandle,
    47 
    -           ConsoleHandle,
    48 
    -           IoHandle,
    49 
    -           toHANDLE
    50 
    -       )
    51 
    -#endif
    52 
    -import GHC.Internal.IO.Handle.Types
    53 
    -       (
    54 
    -           Handle (FileHandle, DuplexHandle),
    55 
    -           Handle__ (Handle__, haDevice)
    56 
    -       )
    57 
    -import GHC.Internal.IO.Handle.Internals (withHandle_', flushBuffer)
    58 
    -import GHC.Internal.IO.Exception
    59 
    -       (
    60 
    -           IOErrorType (InappropriateType),
    61 
    -           IOException (IOError),
    62 
    -           ioException
    63 
    -       )
    64 
    -import GHC.Internal.Foreign.Ptr (Ptr)
    65 
    -import GHC.Internal.Foreign.C.Types (CInt)
    66 
    -
    67 
    --- * Obtaining POSIX file descriptors and Windows handles
    68 
    -
    69 
    -{-|
    70 
    -    Executes a user-provided action on an operating-system handle that underlies
    71 
    -    a Haskell handle. Before the user-provided action is run, user-defined
    72 
    -    preparation based on the handle state that contains the operating-system
    73 
    -    handle is performed. While the user-provided action is executed, further
    74 
    -    operations on the Haskell handle are blocked to a degree that interference
    75 
    -    with this action is prevented.
    76 
    -
    77 
    -    See [below](#with-ref-caveats) for caveats regarding this operation.
    78 
    --}
    79 
    -withOSHandle :: String
    80 
    -                -- ^ The name of the overall operation
    81 
    -             -> (Handle -> MVar Handle__)
    82 
    -                {-^
    83 
    -                    Obtaining of the handle state variable that holds the
    84 
    -                    operating-system handle
    85 
    -                -}
    86 
    -             -> (forall d. Typeable d => d -> IO a)
    87 
    -                -- ^ Conversion of a device into an operating-system handle
    88 
    -             -> (Handle__ -> IO ())
    89 
    -                -- ^ The preparation
    90 
    -             -> Handle
    91 
    -                -- ^ The Haskell handle to use
    92 
    -             -> (a -> IO r)
    93 
    -                -- ^ The action to execute on the operating-system handle
    94 
    -             -> IO r
    95 
    -withOSHandle opName handleStateVar getOSHandle prepare handle act
    96 
    -    = mask $ \ withOriginalMaskingState ->
    97 
    -      withHandleState $ \ handleState@Handle__ {haDevice = dev} -> do
    98 
    -          osHandle <- getOSHandle dev
    99 
    -          prepare handleState
    100 
    -          withOriginalMaskingState $ act osHandle
    101 
    -      where
    102 
    -
    103 
    -      withHandleState = withHandle_' opName handle (handleStateVar handle)
    104 
    -{-
    105 
    -    The 'withHandle_'' operation, which we use here, already performs masking.
    106 
    -    Still, we have to employ 'mask', in order do obtain the operation that
    107 
    -    restores the original masking state. The user-provided action should be
    108 
    -    executed with this original masking state, as there is no inherent reason to
    109 
    -    generally perform it with masking in place. The masking that 'withHandle_''
    110 
    -    performs is only for safely accessing handle state and thus constitutes an
    111 
    -    implementation detail; it has nothing to do with the user-provided action.
    112 
    --}
    113 
    -{-
    114 
    -    The order of actions in 'withOSHandle' is such that any exception from
    115 
    -    'getOSHandle' is thrown before the user-defined preparation is performed.
    116 
    --}
    117 
    -
    118 
    -{-|
    119 
    -    Obtains the handle state variable that underlies a handle or specifically
    120 
    -    the handle state variable for reading if the handle uses different state
    121 
    -    variables for reading and writing.
    122 
    --}
    123 
    -handleStateVarReadingBiased :: Handle -> MVar Handle__
    124 
    -handleStateVarReadingBiased (FileHandle _ var)            = var
    125 
    -handleStateVarReadingBiased (DuplexHandle _ readingVar _) = readingVar
    126 
    -
    127 
    -{-|
    128 
    -    Obtains the handle state variable that underlies a handle or specifically
    129 
    -    the handle state variable for writing if the handle uses different state
    130 
    -    variables for reading and writing.
    131 
    --}
    132 
    -handleStateVarWritingBiased :: Handle -> MVar Handle__
    133 
    -handleStateVarWritingBiased (FileHandle _ var)            = var
    134 
    -handleStateVarWritingBiased (DuplexHandle _ _ writingVar) = writingVar
    135 
    -
    136 
    -{-|
    137 
    -    Yields the result of another operation if that operation succeeded, and
    138 
    -    otherwise throws an exception that signals that the other operation failed
    139 
    -    because some Haskell handle does not use an operating-system handle of a
    140 
    -    required type.
    141 
    --}
    142 
    -requiringOSHandleOfType :: String
    143 
    -                           -- ^ The name of the operating-system handle type
    144 
    -                        -> Maybe a
    145 
    -                           {-^
    146 
    -                               The result of the other operation if it succeeded
    147 
    -                           -}
    148 
    -                        -> IO a
    149 
    -requiringOSHandleOfType osHandleTypeName
    150 
    -    = maybe (ioException osHandleOfTypeRequired) return
    151 
    -    where
    152 
    -
    153 
    -    osHandleOfTypeRequired :: IOException
    154 
    -    osHandleOfTypeRequired
    155 
    -        = IOError Nothing
    156 
    -                  InappropriateType
    157 
    -                  ""
    158 
    -                  ("handle does not use " ++ osHandleTypeName ++ "s")
    159 
    -                  Nothing
    160 
    -                  Nothing
    161 
    -
    162 
    -{-|
    163 
    -    Obtains the POSIX file descriptor of a device if the device contains one,
    164 
    -    and throws an exception otherwise.
    165 
    --}
    166 
    -getFileDescriptor :: Typeable d => d -> IO CInt
    167 
    -getFileDescriptor = requiringOSHandleOfType "POSIX file descriptor" .
    168 
    -                    fmap fdFD . cast
    169 
    -
    170 
    -{-|
    171 
    -    Obtains the Windows handle of a device if the device contains one, and
    172 
    -    throws an exception otherwise.
    173 
    --}
    174 
    -getWindowsHandle :: Typeable d => d -> IO (Ptr ())
    175 
    -getWindowsHandle = requiringOSHandleOfType "Windows handle" .
    176 
    -                   toMaybeWindowsHandle
    177 
    -    where
    178 
    -
    179 
    -    toMaybeWindowsHandle :: Typeable d => d -> Maybe (Ptr ())
    180 
    -#if defined(mingw32_HOST_OS)
    181 
    -    toMaybeWindowsHandle dev
    182 
    -        | Just nativeHandle <- cast dev :: Maybe (IoHandle NativeHandle)
    183 
    -            = Just (toHANDLE nativeHandle)
    184 
    -        | Just consoleHandle <- cast dev :: Maybe (IoHandle ConsoleHandle)
    185 
    -            = Just (toHANDLE consoleHandle)
    186 
    -        | otherwise
    187 
    -            = Nothing
    188 
    -    {-
    189 
    -        This is inspired by the implementation of
    190 
    -        'System.Win32.Types.withHandleToHANDLENative'.
    191 
    -    -}
    192 
    -#else
    193 
    -    toMaybeWindowsHandle _ = Nothing
    194 
    -#endif
    195 
    -
    196 
    -{-|
    197 
    -    Executes a user-provided action on the POSIX file descriptor that underlies
    198 
    -    a handle or specifically on the POSIX file descriptor for reading if the
    199 
    -    handle uses different file descriptors for reading and writing. The
    200 
    -    Haskell-managed buffers related to the file descriptor are flushed before
    201 
    -    the user-provided action is run. While this action is executed, further
    202 
    -    operations on the handle are blocked to a degree that interference with this
    203 
    -    action is prevented.
    204 
    -
    205 
    -    If the handle does not use POSIX file descriptors, an exception is thrown.
    206 
    -
    207 
    -    See [below](#with-ref-caveats) for caveats regarding this operation.
    208 
    --}
    209 
    -withFileDescriptorReadingBiased :: Handle -> (CInt -> IO r) -> IO r
    210 
    -withFileDescriptorReadingBiased = withOSHandle "withFileDescriptorReadingBiased"
    211 
    -                                               handleStateVarReadingBiased
    212 
    -                                               getFileDescriptor
    213 
    -                                               flushBuffer
    214 
    -
    215 
    -{-|
    216 
    -    Executes a user-provided action on the POSIX file descriptor that underlies
    217 
    -    a handle or specifically on the POSIX file descriptor for writing if the
    218 
    -    handle uses different file descriptors for reading and writing. The
    219 
    -    Haskell-managed buffers related to the file descriptor are flushed before
    220 
    -    the user-provided action is run. While this action is executed, further
    221 
    -    operations on the handle are blocked to a degree that interference with this
    222 
    -    action is prevented.
    223 
    -
    224 
    -    If the handle does not use POSIX file descriptors, an exception is thrown.
    225 
    -
    226 
    -    See [below](#with-ref-caveats) for caveats regarding this operation.
    227 
    --}
    228 
    -withFileDescriptorWritingBiased :: Handle -> (CInt -> IO r) -> IO r
    229 
    -withFileDescriptorWritingBiased = withOSHandle "withFileDescriptorWritingBiased"
    230 
    -                                               handleStateVarWritingBiased
    231 
    -                                               getFileDescriptor
    232 
    -                                               flushBuffer
    233 
    -
    234 
    -{-|
    235 
    -    Executes a user-provided action on the Windows handle that underlies a
    236 
    -    Haskell handle or specifically on the Windows handle for reading if the
    237 
    -    Haskell handle uses different Windows handles for reading and writing. The
    238 
    -    Haskell-managed buffers related to the Windows handle are flushed before the
    239 
    -    user-provided action is run. While this action is executed, further
    240 
    -    operations on the Haskell handle are blocked to a degree that interference
    241 
    -    with this action is prevented.
    242 
    -
    243 
    -    If the Haskell handle does not use Windows handles, an exception is thrown.
    244 
    -
    245 
    -    See [below](#with-ref-caveats) for caveats regarding this operation.
    246 
    --}
    247 
    -withWindowsHandleReadingBiased :: Handle -> (Ptr () -> IO r) -> IO r
    248 
    -withWindowsHandleReadingBiased = withOSHandle "withWindowsHandleReadingBiased"
    249 
    -                                              handleStateVarReadingBiased
    250 
    -                                              getWindowsHandle
    251 
    -                                              flushBuffer
    252 
    -
    253 
    -{-|
    254 
    -    Executes a user-provided action on the Windows handle that underlies a
    255 
    -    Haskell handle or specifically on the Windows handle for writing if the
    256 
    -    Haskell handle uses different Windows handles for reading and writing. The
    257 
    -    Haskell-managed buffers related to the Windows handle are flushed before the
    258 
    -    user-provided action is run. While this action is executed, further
    259 
    -    operations on the Haskell handle are blocked to a degree that interference
    260 
    -    with this action is prevented.
    261 
    -
    262 
    -    If the Haskell handle does not use Windows handles, an exception is thrown.
    263 
    -
    264 
    -    See [below](#with-ref-caveats) for caveats regarding this operation.
    265 
    --}
    266 
    -withWindowsHandleWritingBiased :: Handle -> (Ptr () -> IO r) -> IO r
    267 
    -withWindowsHandleWritingBiased = withOSHandle "withWindowsHandleWritingBiased"
    268 
    -                                              handleStateVarWritingBiased
    269 
    -                                              getWindowsHandle
    270 
    -                                              flushBuffer
    271 
    -
    272 
    -{-|
    273 
    -    Like 'withFileDescriptorReadingBiased' except that Haskell-managed buffers
    274 
    -    are not flushed.
    275 
    --}
    276 
    -withFileDescriptorReadingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r
    277 
    -withFileDescriptorReadingBiasedRaw
    278 
    -    = withOSHandle "withFileDescriptorReadingBiasedRaw"
    279 
    -                   handleStateVarReadingBiased
    280 
    -                   getFileDescriptor
    281 
    -                   (const $ return ())
    282 
    -
    283 
    -{-|
    284 
    -    Like 'withFileDescriptorWritingBiased' except that Haskell-managed buffers
    285 
    -    are not flushed.
    286 
    --}
    287 
    -withFileDescriptorWritingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r
    288 
    -withFileDescriptorWritingBiasedRaw
    289 
    -    = withOSHandle "withFileDescriptorWritingBiasedRaw"
    290 
    -                   handleStateVarWritingBiased
    291 
    -                   getFileDescriptor
    292 
    -                   (const $ return ())
    293 
    -
    294 
    -{-|
    295 
    -    Like 'withWindowsHandleReadingBiased' except that Haskell-managed buffers
    296 
    -    are not flushed.
    297 
    --}
    298 
    -withWindowsHandleReadingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r
    299 
    -withWindowsHandleReadingBiasedRaw
    300 
    -    = withOSHandle "withWindowsHandleReadingBiasedRaw"
    301 
    -                   handleStateVarReadingBiased
    302 
    -                   getWindowsHandle
    303 
    -                   (const $ return ())
    304 
    -
    305 
    -{-|
    306 
    -    Like 'withWindowsHandleWritingBiased' except that Haskell-managed buffers
    307 
    -    are not flushed.
    308 
    --}
    309 
    -withWindowsHandleWritingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r
    310 
    -withWindowsHandleWritingBiasedRaw
    311 
    -    = withOSHandle "withWindowsHandleWritingBiasedRaw"
    312 
    -                   handleStateVarWritingBiased
    313 
    -                   getWindowsHandle
    314 
    -                   (const $ return ())
    315 
    -
    316 
    --- ** Caveats
    317 
    -
    318 
    -{-$with-ref-caveats
    319 
    -    #with-ref-caveats#This subsection is just a dummy, whose purpose is to serve
    320 
    -    as the target of the hyperlinks above. The real documentation of the caveats
    321 
    -    is in the /Caveats/ subsection in the @base@ module @System.IO.OS@, which
    322 
    -    re-exports the above operations.
    323 
    --}

  • libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs
    ... ... @@ -26,17 +26,19 @@ module GHC.Internal.TH.Monad
    26 26 
     import Prelude
    27 27 
     import Data.Data hiding (Fixity(..))
    28 28 
     import Data.IORef
    29 
    -import System.IO.Unsafe ( unsafePerformIO )
    29 
    +import System.IO.Unsafe (unsafePerformIO)
    30 30 
     import Control.Monad.IO.Class (MonadIO (..))
    31 
    -import System.IO        ( hPutStrLn, stderr )
    31 
    +import System.IO (FilePath, hPutStrLn, stderr)
    32 32 
     import qualified Data.Kind as Kind (Type)
    33 
    -import GHC.Types        (TYPE, RuntimeRep(..))
    33 
    +import GHC.Types (TYPE, RuntimeRep(..))
    34 34 
     #else
    35 35 
     import GHC.Internal.Base hiding (NonEmpty(..),Type, Module, sequence)
    36 36 
     import GHC.Internal.Data.Data hiding (Fixity(..))
    37 37 
     import GHC.Internal.Data.Traversable
    38 38 
     import GHC.Internal.IORef
    39 
    -import GHC.Internal.System.IO
    39 
    +import GHC.Internal.IO (FilePath)
    40 
    +import GHC.Internal.IO.Handle.Text (hPutStrLn)
    41 
    +import GHC.Internal.IO.StdHandles (stderr)
    40 42 
     import GHC.Internal.Data.Foldable
    41 43 
     import GHC.Internal.Data.Typeable
    42 44 
     import GHC.Internal.Control.Monad.IO.Class
    ... ... @@ -819,38 +821,6 @@ addTempFile suffix = Q (qAddTempFile suffix)
    819 821 
     addTopDecls :: [Dec] -> Q ()
    820 822 
     addTopDecls ds = Q (qAddTopDecls ds)
    821 823
    822 
    -
    823 
    --- | Emit a foreign file which will be compiled and linked to the object for
    824 
    --- the current module. Currently only languages that can be compiled with
    825 
    --- the C compiler are supported, and the flags passed as part of -optc will
    826 
    --- be also applied to the C compiler invocation that will compile them.
    827 
    ---
    828 
    --- Note that for non-C languages (for example C++) @extern "C"@ directives
    829 
    --- must be used to get symbols that we can access from Haskell.
    830 
    ---
    831 
    --- To get better errors, it is recommended to use #line pragmas when
    832 
    --- emitting C files, e.g.
    833 
    ---
    834 
    --- > {-# LANGUAGE CPP #-}
    835 
    --- > ...
    836 
    --- > addForeignSource LangC $ unlines
    837 
    --- >   [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__
    838 
    --- >   , ...
    839 
    --- >   ]
    840 
    -addForeignSource :: ForeignSrcLang -> String -> Q ()
    841 
    -addForeignSource lang src = do
    842 
    -  let suffix = case lang of
    843 
    -                 LangC      -> "c"
    844 
    -                 LangCxx    -> "cpp"
    845 
    -                 LangObjc   -> "m"
    846 
    -                 LangObjcxx -> "mm"
    847 
    -                 LangAsm    -> "s"
    848 
    -                 LangJs     -> "js"
    849 
    -                 RawObject  -> "a"
    850 
    -  path <- addTempFile suffix
    851 
    -  runIO $ writeFile path src
    852 
    -  addForeignFilePath lang path
    853 
    -
    854 824 
     -- | Same as 'addForeignSource', but expects to receive a path pointing to the
    855 825 
     -- foreign file instead of a 'String' of its contents. Consider using this in
    856 826 
     -- conjunction with 'addTempFile'.

  • libraries/template-haskell/Language/Haskell/TH/Syntax.hs
    ... ... @@ -209,7 +209,7 @@ import Data.List.NonEmpty (NonEmpty(..))
    209 209 
     import GHC.Lexeme ( startsVarSym, startsVarId )
    210 210
    211 211 
     -- This module completely re-exports 'GHC.Boot.TH.Syntax',
    212 
    +-- and exports additionally functions that depend on @filepath@ or @System.IO@.
    212 213
    213 214 
     -- |
    214 215 
     addForeignFile :: ForeignSrcLang -> String -> Q ()
    ... ... @@ -218,6 +218,37 @@ addForeignFile = addForeignSource
    218 218 
                    "Use 'Language.Haskell.TH.Syntax.addForeignSource' instead"
    219 219 
       #-} -- deprecated in 8.6
    220 220
    221 
    +-- | Emit a foreign file which will be compiled and linked to the object for
    222 
    +-- the current module. Currently only languages that can be compiled with
    223 
    +-- the C compiler are supported, and the flags passed as part of -optc will
    224 
    +-- be also applied to the C compiler invocation that will compile them.
    225 
    +--
    226 
    +-- Note that for non-C languages (for example C++) @extern "C"@ directives
    227 
    +-- must be used to get symbols that we can access from Haskell.
    228 
    +--
    229 
    +-- To get better errors, it is recommended to use #line pragmas when
    230 
    +-- emitting C files, e.g.
    231 
    +--
    232 
    +-- > {-# LANGUAGE CPP #-}
    233 
    +-- > ...
    234 
    +-- > addForeignSource LangC $ unlines
    235 
    +-- >   [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__
    236 
    +-- >   , ...
    237 
    +-- >   ]
    238 
    +addForeignSource :: ForeignSrcLang -> String -> Q ()
    239 
    +addForeignSource lang src = do
    240 
    +  let suffix = case lang of
    241 
    +                 LangC      -> "c"
    242 
    +                 LangCxx    -> "cpp"
    243 
    +                 LangObjc   -> "m"
    244 
    +                 LangObjcxx -> "mm"
    245 
    +                 LangAsm    -> "s"
    246 
    +                 LangJs     -> "js"
    247 
    +                 RawObject  -> "a"
    248 
    +  path <- addTempFile suffix
    249 
    +  runIO $ writeFile path src
    250 
    +  addForeignFilePath lang path
    251 
    +
    221 252 
     -- | The input is a filepath, which if relative is offset by the package root.
    222 253 
     makeRelativeToProject :: FilePath -> Q FilePath
    223 254 
     makeRelativeToProject fp | isRelative fp = do

  • rts/PrimOps.cmm
    ... ... @@ -1927,95 +1927,6 @@ loop:
    1927 1927 
     }
    1928 1928
    1929 1929
    1930 
    -// NOTE: there is another implementation of this function in
    1931 
    -// Threads.c:performTryPutMVar().  Keep them in sync!  It was
    1932 
    -// measurably slower to call the C function from here (70% for a
    1933 
    -// tight loop doing tryPutMVar#).
    1934 
    -//
    1935 
    -// TODO: we could kill the duplication by making tryPutMVar# into an
    1936 
    -// inline primop that expands into a C call to performTryPutMVar().
    1937 
    -stg_tryPutMVarzh ( P_ mvar, /* :: MVar a */
    1938 
    -                   P_ val,  /* :: a */ )
    1939 
    -{
    1940 
    -    W_ info, tso, q, qinfo;
    1941 
    -
    1942 
    -    LOCK_CLOSURE(mvar, info);
    1943 
    -
    1944 
    -    if (StgMVar_value(mvar) != stg_END_TSO_QUEUE_closure) {
    1945 
    -#if defined(THREADED_RTS)
    1946 
    -        unlockClosure(mvar, info);
    1947 
    -#endif
    1948 
    -        return (0);
    1949 
    -    }
    1950 
    -
    1951 
    -    q = StgMVar_head(mvar);
    1952 
    -loop:
    1953 
    -    if (q == stg_END_TSO_QUEUE_closure) {
    1954 
    -        /* No further takes, the MVar is now full. */
    1955 
    -        if (info == stg_MVAR_CLEAN_info) {
    1956 
    -            ccall dirty_MVAR(BaseReg "ptr", mvar "ptr", StgMVar_value(mvar) "ptr");
    1957 
    -        }
    1958 
    -
    1959 
    -        StgMVar_value(mvar) = val;
    1960 
    -        unlockClosure(mvar, stg_MVAR_DIRTY_info);
    1961 
    -        return (1);
    1962 
    -    }
    1963 
    -
    1964 
    -    qinfo = GET_INFO_ACQUIRE(q);
    1965 
    -
    1966 
    -    if (qinfo == stg_IND_info ||
    1967 
    -        qinfo == stg_MSG_NULL_info) {
    1968 
    -        q = %acquire StgInd_indirectee(q);
    1969 
    -        goto loop;
    1970 
    -    }
    1971 
    -
    1972 
    -    // There are takeMVar(s) waiting: wake up the first one
    1973 
    -
    1974 
    -    tso = StgMVarTSOQueue_tso(q);
    1975 
    -    q = StgMVarTSOQueue_link(q);
    1976 
    -    StgMVar_head(mvar) = q;
    1977 
    -    if (q == stg_END_TSO_QUEUE_closure) {
    1978 
    -        StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
    1979 
    -    } else {
    1980 
    -        if (info == stg_MVAR_CLEAN_info) {
    1981 
    -            // Resolve #18919.
    1982 
    -            ccall dirty_MVAR(BaseReg "ptr", mvar "ptr",
    1983 
    -                             StgMVar_value(mvar) "ptr");
    1984 
    -            info = stg_MVAR_DIRTY_info;
    1985 
    -        }
    1986 
    -    }
    1987 
    -
    1988 
    -    // save why_blocked here, because waking up the thread destroys
    1989 
    -    // this information
    1990 
    -    W_ why_blocked;
    1991 
    -    why_blocked = TO_W_(StgTSO_why_blocked(tso)); // TODO: Missing barrier
    1992 
    -    ASSERT(StgTSO_block_info(tso) == mvar);
    1993 
    -
    1994 
    -    // actually perform the takeMVar
    1995 
    -    W_ stack;
    1996 
    -    stack = StgTSO_stackobj(tso);
    1997 
    -    if (IS_STACK_CLEAN(stack)) {
    1998 
    -        ccall dirty_STACK(MyCapability() "ptr", stack "ptr");
    1999 
    -    }
    2000 
    -    PerformTake(stack, val);
    2001 
    -
    2002 
    -    // indicate that the MVar operation has now completed.
    2003 
    -    StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
    2004 
    -
    2005 
    -    ccall tryWakeupThread(MyCapability() "ptr", tso);
    2006 
    -
    2007 
    -    // If it was a readMVar, then we can still do work,
    2008 
    -    // so loop back. (XXX: This could take a while)
    2009 
    -    if (why_blocked == BlockedOnMVarRead)
    2010 
    -        goto loop;
    2011 
    -
    2012 
    -    ASSERT(why_blocked == BlockedOnMVar);
    2013 
    -
    2014 
    -    unlockClosure(mvar, info);
    2015 
    -    return (1);
    2016 
    -}
    2017 
    -
    2018 
    -
    2019 1930 
     stg_readMVarzh ( P_ mvar, /* :: MVar a */ )
    2020 1931 
     {
    2021 1932 
         W_ val, info, tso, q;

  • rts/RtsSymbols.c
    ... ... @@ -678,6 +678,7 @@ extern char **environ;
    678 678 
           SymI_HasDataProto(stg_readTVarIOzh)                                   \
    679 679 
           SymI_HasProto(resumeThread)                                       \
    680 680 
           SymI_HasProto(setNumCapabilities)                                 \
    681 
    +      SymI_HasProto(performTryPutMVar)                                  \
    681 682 
           SymI_HasProto(getNumberOfProcessors)                              \
    682 683 
           SymI_HasProto(resolveObjs)                                        \
    683 684 
           SymI_HasDataProto(stg_retryzh)                                        \
    ... ... @@ -869,7 +870,6 @@ extern char **environ;
    869 870 
           SymI_HasDataProto(stg_takeMVarzh)                                     \
    870 871 
           SymI_HasDataProto(stg_readMVarzh)                                     \
    871 872 
           SymI_HasDataProto(stg_threadStatuszh)                                 \
    872 
    -      SymI_HasDataProto(stg_tryPutMVarzh)                                   \
    873 873 
           SymI_HasDataProto(stg_tryTakeMVarzh)                                  \
    874 874 
           SymI_HasDataProto(stg_tryReadMVarzh)                                  \
    875 875 
           SymI_HasDataProto(stg_unmaskAsyncExceptionszh)                        \

  • rts/Threads.c
    ... ... @@ -795,8 +795,6 @@ threadStackUnderflow (Capability *cap, StgTSO *tso)
    795 795
    796 796 
     /* ----------------------------------------------------------------------------
    797 797 
        Implementation of tryPutMVar#
    798 
    -
    799 
    -   NOTE: this should be kept in sync with stg_tryPutMVarzh in PrimOps.cmm
    800 798 
        ------------------------------------------------------------------------- */
    801 799
    802 800 
     bool performTryPutMVar(Capability *cap, StgMVar *mvar, StgClosure *value)

  • rts/Threads.h
    ... ... @@ -24,7 +24,7 @@ void migrateThread (Capability *from, StgTSO *tso, Capability *to);
    24 24 
     //
    25 25 
     #if defined(THREADED_RTS)
    26 26 
     void wakeupThreadOnCapability (Capability *cap,
    27 
    -                               Capability *other_cap,
    27 
    +                               Capability *other_cap,
    28 28 
                                    StgTSO *tso);
    29 29 
     #endif
    30 30
    ... ... @@ -40,8 +40,6 @@ StgBool isThreadBound (StgTSO* tso);
    40 40 
     void threadStackOverflow  (Capability *cap, StgTSO *tso);
    41 41 
     W_   threadStackUnderflow (Capability *cap, StgTSO *tso);
    42 42
    43 
    -bool performTryPutMVar(Capability *cap, StgMVar *mvar, StgClosure *value);
    44 
    -
    45 43 
     #if defined(DEBUG)
    46 44 
     void printThreadBlockage (StgTSO *tso);
    47 45 
     void printThreadStatus (StgTSO *t);

  • rts/include/rts/Threads.h
    ... ... @@ -90,3 +90,5 @@ extern Capability MainCapability;
    90 90 
     // current value at the moment).
    91 91 
     //
    92 92 
     extern void setNumCapabilities (uint32_t new_);
    93 
    +
    94 
    +bool performTryPutMVar(Capability *cap, StgMVar *mvar, StgClosure *value);

  • rts/include/stg/MiscClosures.h
    ... ... @@ -512,7 +512,6 @@ RTS_FUN_DECL(stg_takeMVarzh);
    512 512 
     RTS_FUN_DECL(stg_putMVarzh);
    513 513 
     RTS_FUN_DECL(stg_readMVarzh);
    514 514 
     RTS_FUN_DECL(stg_tryTakeMVarzh);
    515 
    -RTS_FUN_DECL(stg_tryPutMVarzh);
    516 515 
     RTS_FUN_DECL(stg_tryReadMVarzh);
    517 516
    518 517 
     RTS_FUN_DECL(stg_waitReadzh);

  • testsuite/tests/ffi/should_compile/all.T
    ... ... @@ -33,6 +33,7 @@ test(
    33 33 
         compile,
    34 34 
         [
    35 35 
             '-optc=-DC -optcxx=-DCXX -optcxx=-std=c++11'
    36 
    +        + ' -package=template-haskell'
    36 37 
             + (' -optcxx=-stdlib=libc++' if opsys('darwin') else '')
    37 38 
         ],
    38 39 
     )

  • testsuite/tests/ghci-wasm/T26998.hs
    1 
    +main :: IO ()
    2 
    +main = pure ()
    3 
    +
    4 
    +foreign export javascript "my_main" main :: IO ()

  • testsuite/tests/ghci-wasm/all.T
    ... ... @@ -10,3 +10,5 @@ test('T26430', [
    10 10 
       extra_hc_opts('-L. -lT26430B')]
    11 11 
     , compile_and_run, ['']
    12 12 
     )
    13 
    +
    14 
    +test('T26998', [], compile_and_run, [''])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help