[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: winio: restore console cp on exit
Marge Bot
gitlab at gitlab.haskell.org
Fri Jul 24 07:02:06 UTC 2020
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
50a9151b by Tamar Christina at 2020-07-24T03:02:00-04:00
winio: restore console cp on exit
- - - - -
5a6b4355 by Tamar Christina at 2020-07-24T03:02:02-04:00
winio: change memory allocation strategy and fix double free errors.
- - - - -
f5c95a23 by Simon Peyton Jones at 2020-07-24T03:02:02-04:00
Care with occCheckExpand in kind of occurrences
Issue #18451 showed that we could get an infinite type, through
over-use of occCheckExpand in the kind of an /occurrence/ of a
type variable.
See Note [Occurrence checking: look inside kinds] in GHC.Core.Type
This patch fixes the problem by making occCheckExpand less eager
to expand synonyms in kinds.
It also improves pretty printing of kinds, by *not* suppressing
the kind on a tyvar-binder like
(a :: Const Type b)
where type Const p q = p. Even though the kind of 'a' is Type,
we don't want to suppress the kind ascription. Example: the
error message for polykinds/T18451{a,b}. See GHC.Core.TyCo.Ppr
Note [Suppressing * kinds].
- - - - -
15 changed files:
- compiler/GHC/Core/TyCo/Ppr.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Tc/Utils/Unify.hs
- includes/HsFFI.h
- libraries/base/GHC/Event/Windows.hsc
- libraries/base/GHC/Event/Windows/FFI.hsc
- rts/RtsStartup.c
- rts/win32/veh_excn.c
- + testsuite/tests/polykinds/T18451.hs
- + testsuite/tests/polykinds/T18451.stderr
- + testsuite/tests/polykinds/T18451a.hs
- + testsuite/tests/polykinds/T18451a.stderr
- + testsuite/tests/polykinds/T18451b.hs
- + testsuite/tests/polykinds/T18451b.stderr
- testsuite/tests/polykinds/all.T
Changes:
=====================================
compiler/GHC/Core/TyCo/Ppr.hs
=====================================
@@ -34,10 +34,9 @@ import {-# SOURCE #-} GHC.CoreToIface
, toIfaceTyCon, toIfaceTcArgs, toIfaceCoercionX )
import {-# SOURCE #-} GHC.Core.DataCon
- ( dataConFullSig , dataConUserTyVarBinders
- , DataCon )
+ ( dataConFullSig , dataConUserTyVarBinders, DataCon )
-import GHC.Core.Type ( isLiftedTypeKind, pattern One, pattern Many )
+import GHC.Core.Type ( pickyIsLiftedTypeKind, pattern One, pattern Many )
import GHC.Core.TyCon
import GHC.Core.TyCo.Rep
@@ -192,11 +191,35 @@ pprTyVar :: TyVar -> SDoc
-- pprIfaceTvBndr is minimal, and the loss of uniques etc in
-- debug printing is disastrous
pprTyVar tv
- | isLiftedTypeKind kind = ppr tv
- | otherwise = parens (ppr tv <+> dcolon <+> ppr kind)
+ | pickyIsLiftedTypeKind kind = ppr tv -- See Note [Suppressing * kinds]
+ | otherwise = parens (ppr tv <+> dcolon <+> ppr kind)
where
kind = tyVarKind tv
+{- Note [Suppressing * kinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Generally we want to print
+ forall a. a->a
+not forall (a::*). a->a
+or forall (a::Type). a->a
+That is, for brevity we suppress a kind ascription of '*' (or Type).
+
+But what if the kind is (Const Type x)?
+ type Const p q = p
+
+Then (Const Type x) is just a long way of saying Type. But it may be
+jolly confusing to suppress the 'x'. Suppose we have (polykinds/T18451a)
+ foo :: forall a b (c :: Const Type b). Proxy '[a, c]
+
+Then this error message
+ • These kind and type variables: a b (c :: Const Type b)
+ are out of dependency order. Perhaps try this ordering:
+ (b :: k) (a :: Const (*) b) (c :: Const (*) b)
+would be much less helpful if we suppressed the kind ascription on 'a'.
+
+Hence the use of pickyIsLiftedTypeKind.
+-}
+
-----------------
debugPprType :: Type -> SDoc
-- ^ debugPprType is a simple pretty printer that prints a type
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -120,7 +120,7 @@ module GHC.Core.Type (
-- *** Levity and boxity
isLiftedType_maybe,
- isLiftedTypeKind, isUnliftedTypeKind,
+ isLiftedTypeKind, isUnliftedTypeKind, pickyIsLiftedTypeKind,
isLiftedRuntimeRep, isUnliftedRuntimeRep,
isUnliftedType, mightBeUnliftedType, isUnboxedTupleType, isUnboxedSumType,
isAlgType, isDataFamilyAppType,
@@ -554,6 +554,23 @@ isLiftedTypeKind kind
Just rep -> isLiftedRuntimeRep rep
Nothing -> False
+pickyIsLiftedTypeKind :: Kind -> Bool
+-- Checks whether the kind is literally
+-- TYPE LiftedRep
+-- or Type
+-- without expanding type synonyms or anything
+-- Used only when deciding whether to suppress the ":: *" in
+-- (a :: *) when printing kinded type variables
+-- See Note [Suppressing * kinds] in GHC.Core.TyCo.Ppr
+pickyIsLiftedTypeKind kind
+ | TyConApp tc [arg] <- kind
+ , tc `hasKey` tYPETyConKey
+ , TyConApp rr_tc [] <- arg
+ , rr_tc `hasKey` liftedRepDataConKey = True
+ | TyConApp tc [] <- kind
+ , tc `hasKey` liftedTypeKindTyConKey = True
+ | otherwise = False
+
isLiftedRuntimeRep :: Type -> Bool
-- isLiftedRuntimeRep is true of LiftedRep :: RuntimeRep
-- False of type variables (a :: RuntimeRep)
@@ -2619,6 +2636,46 @@ prefer doing inner expansions first. For example,
We have
occCheckExpand b (F (G b)) = Just (F Char)
even though we could also expand F to get rid of b.
+
+Note [Occurrence checking: look inside kinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we are considering unifying
+ (alpha :: *) ~ Int -> (beta :: alpha -> alpha)
+This may be an error (what is that alpha doing inside beta's kind?),
+but we must not make the mistake of actually unifying or we'll
+build an infinite data structure. So when looking for occurrences
+of alpha in the rhs, we must look in the kinds of type variables
+that occur there.
+
+occCheckExpand tries to expand type synonyms to remove
+unnecessary occurrences of a variable, and thereby get past an
+occurs-check failure. This is good; but
+ we can't do it in the /kind/ of a variable /occurrence/
+
+For example #18451 built an infinite type:
+ type Const a b = a
+ data SameKind :: k -> k -> Type
+ type T (k :: Const Type a) = forall (b :: k). SameKind a b
+
+We have
+ b :: k
+ k :: Const Type a
+ a :: k (must be same as b)
+
+So if we aren't careful, a's kind mentions a, which is bad.
+And expanding an /occurrence/ of 'a' doesn't help, because the
+/binding site/ is the master copy and all the occurrences should
+match it.
+
+Here's a related example:
+ f :: forall a b (c :: Const Type b). Proxy '[a, c]
+
+The list means that 'a' gets the same kind as 'c'; but that
+kind mentions 'b', so the binders are out of order.
+
+Bottom line: in occCheckExpand, do not expand inside the kinds
+of occurrences. See bad_var_occ in occCheckExpand. And
+see #18451 for more debate.
-}
occCheckExpand :: [Var] -> Type -> Maybe Type
@@ -2639,11 +2696,10 @@ occCheckExpand vs_to_avoid ty
-- The VarSet is the set of variables we are trying to avoid
-- The VarEnv carries mappings necessary
-- because of kind expansion
- go cxt@(as, env) (TyVarTy tv')
- | tv' `elemVarSet` as = Nothing
- | Just tv'' <- lookupVarEnv env tv' = return (mkTyVarTy tv'')
- | otherwise = do { tv'' <- go_var cxt tv'
- ; return (mkTyVarTy tv'') }
+ go (as, env) ty@(TyVarTy tv)
+ | Just tv' <- lookupVarEnv env tv = return (mkTyVarTy tv')
+ | bad_var_occ as tv = Nothing
+ | otherwise = return ty
go _ ty@(LitTy {}) = return ty
go cxt (AppTy ty1 ty2) = do { ty1' <- go cxt ty1
@@ -2656,7 +2712,7 @@ occCheckExpand vs_to_avoid ty
; return (ty { ft_mult = w', ft_arg = ty1', ft_res = ty2' }) }
go cxt@(as, env) (ForAllTy (Bndr tv vis) body_ty)
= do { ki' <- go cxt (varType tv)
- ; let tv' = setVarType tv ki'
+ ; let tv' = setVarType tv ki'
env' = extendVarEnv env tv tv'
as' = as `delVarSet` tv
; body' <- go (as', env') body_ty
@@ -2680,9 +2736,12 @@ occCheckExpand vs_to_avoid ty
; return (mkCoercionTy co') }
------------------
- go_var cxt v = updateVarTypeM (go cxt) v
- -- Works for TyVar and CoVar
- -- See Note [Occurrence checking: look inside kinds]
+ bad_var_occ :: VarSet -> Var -> Bool
+ -- Works for TyVar and CoVar
+ -- See Note [Occurrence checking: look inside kinds]
+ bad_var_occ vs_to_avoid v
+ = v `elemVarSet` vs_to_avoid
+ || tyCoVarsOfType (varType v) `intersectsVarSet` vs_to_avoid
------------------
go_mco _ MRefl = return MRefl
@@ -2712,13 +2771,15 @@ occCheckExpand vs_to_avoid ty
; co2' <- go_co cxt co2
; w' <- go_co cxt w
; return (mkFunCo r w' co1' co2') }
- go_co cxt@(as,env) (CoVarCo c)
- | c `elemVarSet` as = Nothing
+ go_co (as,env) co@(CoVarCo c)
| Just c' <- lookupVarEnv env c = return (mkCoVarCo c')
- | otherwise = do { c' <- go_var cxt c
- ; return (mkCoVarCo c') }
- go_co cxt (HoleCo h) = do { c' <- go_var cxt (ch_co_var h)
- ; return (HoleCo (h { ch_co_var = c' })) }
+ | bad_var_occ as c = Nothing
+ | otherwise = return co
+
+ go_co (as,_) co@(HoleCo h)
+ | bad_var_occ as (ch_co_var h) = Nothing
+ | otherwise = return co
+
go_co cxt (AxiomInstCo ax ind args) = do { args' <- mapM (go_co cxt) args
; return (mkAxiomInstCo ax ind args') }
go_co cxt (UnivCo p r ty1 ty2) = do { p' <- go_prov cxt p
=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -1879,21 +1879,8 @@ matchExpectedFunKind hs_ty n k = go n k
********************************************************************* -}
-{- Note [Occurrence checking: look inside kinds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we are considering unifying
- (alpha :: *) ~ Int -> (beta :: alpha -> alpha)
-This may be an error (what is that alpha doing inside beta's kind?),
-but we must not make the mistake of actually unifying or we'll
-build an infinite data structure. So when looking for occurrences
-of alpha in the rhs, we must look in the kinds of type variables
-that occur there.
-
-NB: we may be able to remove the problem via expansion; see
- Note [Occurs check expansion]. So we have to try that.
-
-Note [Checking for foralls]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Checking for foralls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Unless we have -XImpredicativeTypes (which is a totally unsupported
feature), we do not want to unify
alpha ~ (forall a. a->a) -> Int
@@ -1906,10 +1893,10 @@ Consider
(alpha :: forall k. k->*) ~ (beta :: forall k. k->*)
This is legal; e.g. dependent/should_compile/T11635.
-We don't want to reject it because of the forall in beta's kind,
-but (see Note [Occurrence checking: look inside kinds]) we do
-need to look in beta's kind. So we carry a flag saying if a 'forall'
-is OK, and switch the flag on when stepping inside a kind.
+We don't want to reject it because of the forall in beta's kind, but
+(see Note [Occurrence checking: look inside kinds] in GHC.Core.Type)
+we do need to look in beta's kind. So we carry a flag saying if a
+'forall' is OK, and switch the flag on when stepping inside a kind.
Why is it OK? Why does it not count as impredicative polymorphism?
The reason foralls are bad is because we reply on "seeing" foralls
@@ -2030,6 +2017,7 @@ preCheck dflags ty_fam_ok tv ty
| tv == tv' = MTVU_Occurs
| otherwise = fast_check_occ (tyVarKind tv')
-- See Note [Occurrence checking: look inside kinds]
+ -- in GHC.Core.Type
fast_check (TyConApp tc tys)
| bad_tc tc = MTVU_Bad
=====================================
includes/HsFFI.h
=====================================
@@ -102,6 +102,7 @@ extern void hs_exit (void);
extern void hs_exit_nowait(void);
extern void hs_set_argv (int argc, char *argv[]);
extern void hs_thread_done (void);
+extern void hs_restoreConsoleCP (void);
extern void hs_perform_gc (void);
=====================================
libraries/base/GHC/Event/Windows.hsc
=====================================
@@ -86,7 +86,9 @@ import Data.Foldable (mapM_, length, forM_)
import Data.Maybe (isJust, maybe)
import GHC.Event.Windows.Clock (Clock, Seconds, getClock, getTime)
-import GHC.Event.Windows.FFI (LPOVERLAPPED, OVERLAPPED_ENTRY(..))
+import GHC.Event.Windows.FFI (LPOVERLAPPED, OVERLAPPED_ENTRY(..),
+ CompletionData(..), CompletionCallback,
+ withRequest)
import GHC.Event.Windows.ManagedThreadPool
import GHC.Event.Internal.Types
import GHC.Event.Unique
@@ -300,43 +302,6 @@ foreign import ccall safe "completeSynchronousRequest"
------------------------------------------------------------------------
-- Manager structures
--- | Callback type that will be called when an I/O operation completes.
-type IOCallback = CompletionCallback ()
-
--- | Wrap the IOCallback type into a FunPtr.
-foreign import ccall "wrapper"
- wrapIOCallback :: IOCallback -> IO (FunPtr IOCallback)
-
--- | Unwrap a FunPtr IOCallback to a normal Haskell function.
-foreign import ccall "dynamic"
- mkIOCallback :: FunPtr IOCallback -> IOCallback
-
--- | Structure that the I/O manager uses to associate callbacks with
--- additional payload such as their OVERLAPPED structure and Win32 handle
--- etc. *Must* be kept in sync with that in `winio_structs.h` or horrible things
--- happen.
---
--- We keep the handle around for the benefit of ghc-external libraries making
--- use of the manager.
-data CompletionData = CompletionData { cdHandle :: !HANDLE
- , cdCallback :: !IOCallback
- }
-
-instance Storable CompletionData where
- sizeOf _ = #{size CompletionData}
- alignment _ = #{alignment CompletionData}
-
- peek ptr = do
- cdCallback <- mkIOCallback `fmap` #{peek CompletionData, cdCallback} ptr
- cdHandle <- #{peek CompletionData, cdHandle} ptr
- let !cd = CompletionData{..}
- return cd
-
- poke ptr CompletionData{..} = do
- cb <- wrapIOCallback cdCallback
- #{poke CompletionData, cdCallback} ptr cb
- #{poke CompletionData, cdHandle} ptr cdHandle
-
-- | Pointer offset in bytes to the location of hoData in HASKELL_OVERLAPPPED
cdOffset :: Int
cdOffset = #{const __builtin_offsetof (HASKELL_OVERLAPPED, hoData)}
@@ -507,11 +472,6 @@ data CbResult a
-- manager will perform additional checks.
deriving Show
--- | Called when the completion is delivered.
-type CompletionCallback a = ErrCode -- ^ 0 indicates success
- -> DWORD -- ^ Number of bytes transferred
- -> IO a
-
-- | Associate a 'HANDLE' with the current I/O manager's completion port.
-- This must be done before using the handle with 'withOverlapped'.
associateHandle' :: HANDLE -> IO ()
@@ -581,23 +541,18 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
signalThrow ex = failIfFalse_ (dbgMsg "signalThrow") $
writeIOPort signal (IOFailed ex)
mask_ $ do
- let completionCB' e b = completionCB e b >>= \result ->
- case result of
- IOSuccess val -> signalReturn val
- IOFailed err -> signalThrow err
- hs_lpol <- FFI.allocOverlapped offset
- -- Create the completion record and store it.
- -- We only need the record when we enqueue a request, however if we
- -- delay creating it then we will run into a race condition where the
- -- driver may have finished servicing the request before we were ready
- -- and so the request won't have the book keeping information to know
- -- what to do. So because of that we always create the payload, If we
- -- need it ok, if we don't that's no problem. This approach prevents
- -- expensive lookups in hash-tables.
- --
- -- Todo: Use a memory pool for this so we don't have to hit malloc every
- -- time. This would allow us to scale better.
- cdData <- new (CompletionData h completionCB') :: IO (Ptr CompletionData)
+ let completionCB' e b = completionCB e b >>= \result ->
+ case result of
+ IOSuccess val -> signalReturn val
+ IOFailed err -> signalThrow err
+ let callbackData = CompletionData h completionCB'
+ -- Note [Memory Management]
+ -- These callback data and especially the overlapped structs have to keep
+ -- alive throughout the entire lifetime of the requests. Since this
+ -- function will block until done so it can call completionCB at the end
+ -- we can safely use dynamic memory management here and so reduce the
+ -- possibility of memory errors.
+ withRequest offset callbackData $ \hs_lpol cdData -> do
let ptr_lpol = hs_lpol `plusPtr` cdOffset
let lpol = castPtr hs_lpol
debugIO $ "hs_lpol:" ++ show hs_lpol
@@ -713,11 +668,8 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
debugIO $ "## Waiting for cancellation record... "
_ <- FFI.getOverlappedResult h lpol True
oldDataPtr <- exchangePtr ptr_lpol nullReq
- -- Check if we have to free and cleanup pointer
when (oldDataPtr == cdData) $
- do free oldDataPtr
- free hs_lpol
- reqs <- removeRequest
+ do reqs <- removeRequest
debugIO $ "-1.. " ++ show reqs ++ " requests queued after error."
status <- fmap fromIntegral getLastError
completionCB' status 0
@@ -741,7 +693,6 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
case startCBResult of
CbPending -> runner
CbDone rdata -> do
- free cdData
debugIO $ dbgMsg $ ":: done " ++ show lpol ++ " - " ++ show rdata
bytes <- if isJust rdata
then return rdata
@@ -749,23 +700,18 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
else FFI.getOverlappedResult h lpol False
debugIO $ dbgMsg $ ":: done bytes: " ++ show bytes
case bytes of
- Just res -> free hs_lpol >> completionCB 0 res
+ Just res -> completionCB 0 res
Nothing -> do err <- FFI.overlappedIOStatus lpol
numBytes <- FFI.overlappedIONumBytes lpol
-- TODO: Remap between STATUS_ and ERROR_ instead
-- of re-interpret here. But for now, don't care.
let err' = fromIntegral err
- free hs_lpol
debugIO $ dbgMsg $ ":: done callback: " ++ show err' ++ " - " ++ show numBytes
completionCB err' (fromIntegral numBytes)
CbError err -> do
- free cdData
- free hs_lpol
let err' = fromIntegral err
completionCB err' 0
_ -> do
- free cdData
- free hs_lpol
error "unexpected case in `startCBResult'"
where dbgMsg s = s ++ " (" ++ show h ++ ":" ++ show offset ++ ")"
-- Wait for .25ms (threaded) and 1ms (non-threaded)
@@ -1099,15 +1045,17 @@ processCompletion Manager{..} n delay = do
do debugIO $ "exchanged: " ++ show oldDataPtr
payload <- peek oldDataPtr :: IO CompletionData
let !cb = cdCallback payload
- free oldDataPtr
reqs <- removeRequest
debugIO $ "-1.. " ++ show reqs ++ " requests queued."
status <- FFI.overlappedIOStatus (lpOverlapped oe)
-- TODO: Remap between STATUS_ and ERROR_ instead
-- of re-interpret here. But for now, don't care.
let status' = fromIntegral status
+ -- We no longer explicitly free the memory, this is because we
+ -- now require the callback to free the memory since the
+ -- callback allocated it. This allows us to simplify memory
+ -- management and reduce bugs. See Note [Memory Management].
cb status' (dwNumberOfBytesTransferred oe)
- free hs_lpol
-- clear the array so we don't erroneously interpret the output, in
-- certain circumstances like lockFileEx the code could return 1 entry
=====================================
libraries/base/GHC/Event/Windows/FFI.hsc
=====================================
@@ -30,6 +30,11 @@ module GHC.Event.Windows.FFI (
postQueuedCompletionStatus,
getOverlappedResult,
+ -- * Completion Data
+ CompletionData(..),
+ CompletionCallback,
+ withRequest,
+
-- * Overlapped
OVERLAPPED,
LPOVERLAPPED,
@@ -215,6 +220,51 @@ postQueuedCompletionStatus iocp numBytes completionKey lpol =
failIfFalse_ "PostQueuedCompletionStatus" $
c_PostQueuedCompletionStatus iocp numBytes completionKey lpol
+------------------------------------------------------------------------
+-- Completion Data
+
+-- | Called when the completion is delivered.
+type CompletionCallback a = ErrCode -- ^ 0 indicates success
+ -> DWORD -- ^ Number of bytes transferred
+ -> IO a
+
+-- | Callback type that will be called when an I/O operation completes.
+type IOCallback = CompletionCallback ()
+
+-- | Wrap the IOCallback type into a FunPtr.
+foreign import ccall "wrapper"
+ wrapIOCallback :: IOCallback -> IO (FunPtr IOCallback)
+
+-- | Unwrap a FunPtr IOCallback to a normal Haskell function.
+foreign import ccall "dynamic"
+ mkIOCallback :: FunPtr IOCallback -> IOCallback
+
+-- | Structure that the I/O manager uses to associate callbacks with
+-- additional payload such as their OVERLAPPED structure and Win32 handle
+-- etc. *Must* be kept in sync with that in `winio_structs.h` or horrible things
+-- happen.
+--
+-- We keep the handle around for the benefit of ghc-external libraries making
+-- use of the manager.
+data CompletionData = CompletionData { cdHandle :: !HANDLE
+ , cdCallback :: !IOCallback
+ }
+
+instance Storable CompletionData where
+ sizeOf _ = #{size CompletionData}
+ alignment _ = #{alignment CompletionData}
+
+ peek ptr = do
+ cdCallback <- mkIOCallback `fmap` #{peek CompletionData, cdCallback} ptr
+ cdHandle <- #{peek CompletionData, cdHandle} ptr
+ let !cd = CompletionData{..}
+ return cd
+
+ poke ptr CompletionData{..} = do
+ cb <- wrapIOCallback cdCallback
+ #{poke CompletionData, cdCallback} ptr cb
+ #{poke CompletionData, cdHandle} ptr cdHandle
+
------------------------------------------------------------------------
-- Overlapped
@@ -293,6 +343,30 @@ pokeOffsetOverlapped lpol offset = do
#{poke OVERLAPPED, OffsetHigh} lpol offsetHigh
{-# INLINE pokeOffsetOverlapped #-}
+------------------------------------------------------------------------
+-- Request management
+
+withRequest :: Word64 -> CompletionData
+ -> (Ptr HASKELL_OVERLAPPED -> Ptr CompletionData -> IO a)
+ -> IO a
+withRequest offset cbData f =
+ -- Create the completion record and store it.
+ -- We only need the record when we enqueue a request, however if we
+ -- delay creating it then we will run into a race condition where the
+ -- driver may have finished servicing the request before we were ready
+ -- and so the request won't have the book keeping information to know
+ -- what to do. So because of that we always create the payload, If we
+ -- need it ok, if we don't that's no problem. This approach prevents
+ -- expensive lookups in hash-tables.
+ --
+ -- Todo: Use a memory pool for this so we don't have to hit malloc every
+ -- time. This would allow us to scale better.
+ allocaBytes #{size HASKELL_OVERLAPPED} $ \hs_lpol ->
+ with cbData $ \cdData -> do
+ zeroOverlapped hs_lpol
+ pokeOffsetOverlapped (castPtr hs_lpol) offset
+ f hs_lpol cdData
+
------------------------------------------------------------------------
-- Cancel pending I/O
=====================================
rts/RtsStartup.c
=====================================
@@ -68,6 +68,11 @@
static int hs_init_count = 0;
static bool rts_shutdown = false;
+#if defined(mingw32_HOST_OS)
+/* Indicates CodePage to set program to after exit. */
+static int64_t __codePage = 0;
+#endif
+
static void flushStdHandles(void);
/* -----------------------------------------------------------------------------
@@ -128,13 +133,38 @@ void fpreset(void) {
static void
initConsoleCP (void)
{
+ /* Set the initial codepage to automatic. */
+ __codePage = -1;
+
/* Check if the codepage is still the system default ANSI codepage. */
- if (GetConsoleCP () == GetOEMCP ()) {
- if (! SetConsoleCP (CP_UTF8))
+ if (GetConsoleCP () == GetOEMCP ()
+ && GetConsoleOutputCP () == GetOEMCP ()) {
+ if (!SetConsoleCP (CP_UTF8) || !SetConsoleOutputCP (CP_UTF8))
errorBelch ("Unable to set console CodePage, Unicode output may be "
"garbled.\n");
else
IF_DEBUG (scheduler, debugBelch ("Codepage set to UTF-8.\n"));
+
+ /* Assign the codepage so we can restore it on exit. */
+ __codePage = (int64_t)GetOEMCP ();
+ }
+}
+
+/* Restore the CodePage to what it was before we started. If the CodePage was
+ already set then this call is a no-op. */
+void
+hs_restoreConsoleCP (void)
+{
+ /* If we set the CP at startup, we should set it on exit. */
+ if (__codePage == -1)
+ return;
+
+ UINT cp = (UINT)__codePage;
+ __codePage = -1;
+ if (SetConsoleCP (cp) && SetConsoleOutputCP (cp)) {
+ IF_DEBUG (scheduler, debugBelch ("Codepage restored to OEM.\n"));
+ } else {
+ IF_DEBUG (scheduler, debugBelch ("Unable to restore CodePage to OEM.\n"));
}
}
#endif
@@ -533,6 +563,11 @@ hs_exit_(bool wait_foreign)
shutdownAsyncIO(wait_foreign);
#endif
+ /* Restore the console Codepage. */
+#if defined(mingw32_HOST_OS)
+ if (is_io_mng_native_p())
+ hs_restoreConsoleCP();
+#endif
/* free hash table storage */
exitHashTable();
=====================================
rts/win32/veh_excn.c
=====================================
@@ -153,6 +153,7 @@ long WINAPI __hs_exception_handler(struct _EXCEPTION_POINTERS *exception_data)
if (EXCEPTION_CONTINUE_EXECUTION == action)
{
fflush(stderr);
+ hs_restoreConsoleCP ();
generateStack (exception_data);
generateDump (exception_data);
stg_exit(exit_code);
=====================================
testsuite/tests/polykinds/T18451.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeInType #-}
+module Bug where
+
+import Data.Kind
+
+type Const a b = a
+data SameKind :: k -> k -> Type
+
+type T (k :: Const Type a) = forall (b :: k). SameKind a b
=====================================
testsuite/tests/polykinds/T18451.stderr
=====================================
@@ -0,0 +1,9 @@
+
+T18451.hs:10:58: error:
+ • Expected kind ‘k0’, but ‘b’ has kind ‘k’
+ • In the second argument of ‘SameKind’, namely ‘b’
+ In the type ‘forall (b :: k). SameKind a b’
+ In the type declaration for ‘T’
+ • Type variable kinds:
+ a :: k0
+ k :: Const (*) a
=====================================
testsuite/tests/polykinds/T18451a.hs
=====================================
@@ -0,0 +1,11 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeInType #-}
+module Bug where
+
+import Data.Kind
+import Data.Proxy
+
+type Const a b = a
+
+foo :: forall a b (c :: Const Type b). Proxy '[a, c]
+foo = error "ruk"
=====================================
testsuite/tests/polykinds/T18451a.stderr
=====================================
@@ -0,0 +1,7 @@
+
+T18451a.hs:10:8: error:
+ • These kind and type variables: a b (c :: Const Type b)
+ are out of dependency order. Perhaps try this ordering:
+ (b :: k) (a :: Const (*) b) (c :: Const (*) b)
+ • In the type signature:
+ foo :: forall a b (c :: Const Type b). Proxy '[a, c]
=====================================
testsuite/tests/polykinds/T18451b.hs
=====================================
@@ -0,0 +1,11 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeInType #-}
+module Bug where
+
+import Data.Kind
+import Data.Proxy
+
+type Const a b = a
+
+foo :: forall a b (c :: Const Type b). Proxy '[a, c]
+foo = error "ruk"
=====================================
testsuite/tests/polykinds/T18451b.stderr
=====================================
@@ -0,0 +1,7 @@
+
+T18451b.hs:10:8: error:
+ • These kind and type variables: a b (c :: Const Type b)
+ are out of dependency order. Perhaps try this ordering:
+ (b :: k) (a :: Const (*) b) (c :: Const (*) b)
+ • In the type signature:
+ foo :: forall a b (c :: Const Type b). Proxy '[a, c]
=====================================
testsuite/tests/polykinds/all.T
=====================================
@@ -220,3 +220,6 @@ test('CuskFam', normal, compile, [''])
test('T17841', normal, compile_fail, [''])
test('T17963', normal, compile_fail, [''])
test('T18300', normal, compile_fail, [''])
+test('T18451', normal, compile_fail, [''])
+test('T18451a', normal, compile_fail, [''])
+test('T18451b', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6f71d32f7c63e732dd905e8c7643e20101298568...f5c95a237888ab120c25ef7b73d22c108ad3596d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6f71d32f7c63e732dd905e8c7643e20101298568...f5c95a237888ab120c25ef7b73d22c108ad3596d
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200724/25b2eb75/attachment-0001.html>
More information about the ghc-commits
mailing list