[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 14:52:20 UTC 2020



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


Commits:
a4756d27 by Tamar Christina at 2020-07-24T10:52:14-04:00
winio: restore console cp on exit

- - - - -
6541b8c1 by Tamar Christina at 2020-07-24T10:52:15-04:00
winio: change memory allocation strategy and fix double free errors.

- - - - -
0ed58267 by Simon Peyton Jones at 2020-07-24T10:52:16-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/f5c95a237888ab120c25ef7b73d22c108ad3596d...0ed582676566f5d8ef6edff4a0ee5517f5c90d4a

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f5c95a237888ab120c25ef7b73d22c108ad3596d...0ed582676566f5d8ef6edff4a0ee5517f5c90d4a
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/56a15e05/attachment-0001.html>


More information about the ghc-commits mailing list