Merge branch 'Phyx/ghc-gh-18382-fix-heap-corruption' into wip/winio-by-defaultwip/winio-by-default

19 files changed, 159 insertions, 40 deletions

diff --git a/docs/users_guide/9.4.1-notes.rst b/docs/users_guide/9.4.1-notes.rst
index 31f09fa6bc..5cb2736547 100644
--- a/docs/users_guide/9.4.1-notes.rst
+++ b/docs/users_guide/9.4.1-notes.rst
@@ -38,6 +38,33 @@ Compiler
     enabled the :extension:`UnboxedTuples` extension but didn't explicitly
     enable :extension:`UnboxedSums` will continue to work without changes.
 
+- Constructed Product Result analysis (c.f. :ghc-flag:`-fcpr-anal`) has been
+  overhauled and will now unbox nestedly, if termination properties of the
+  function permit. This allows unboxing of constructed results returned by
+  ``IO`` actions. E.g.::
+
+      sumIO :: [Int] -> IO Int
+      sumIO []     = return 0
+      sumIO (x:xs) = do
+        r <- sumIO xs
+        return $! x + r
+
+  Note the use of ``$!``: Without it, GHC would be unable to see that evaluation
+  of ``r`` and ``x`` terminates (and rapidly, at that). An alternative would be to
+  evaluate both with a bang pattern or a ``seq``, but the ``return $! <res>``
+  idiom should work more reliably and needs less thinking.
+
+- Demand analysis (cf. :ghc-flag:`-fstrictness`) now integrates a
+  Boxity Analysis that tracks whether a function needs a parameter boxed. If
+  that is the case, the worker/wrapper transformation (cf.
+  :ghc-flag:`-fworker-wrapper`) will not unbox that parameter, leading to less
+  reboxing in many cases.
+
+  For reasons of backwards-compatible performance, you may find that the new
+  mechanism is too aggressive in a few cases (e.g., still unboxing a parameter
+  that is used boxed in a hot path). Do post a bug report with your example!
+  Then wrap the uses of the parameter in ``GHC.Exts.lazy`` for a short-term fix.
+
 ``base`` library
 ~~~~~~~~~~~~~~~~
 
diff --git a/docs/users_guide/editing-guide.rst b/docs/users_guide/editing-guide.rst
index 737abd3b2e..b4720e1a71 100644
--- a/docs/users_guide/editing-guide.rst
+++ b/docs/users_guide/editing-guide.rst
@@ -6,15 +6,15 @@ for the Glasgow Haskell Compiler. Even more than this, it at times serves (for
 better or for worse) as a de-facto language standard, being the sole
 non-academic reference for many widely used language extensions.
 
-Since GHC 8.0, the User's Guide is authored in `ReStructuredText
-<https://en.wikipedia.org/wiki/ReStructuredText>`__ (or ReST or RST, for short)
+Since GHC 8.0, the User's Guide is authored in `reStructuredText
+<https://en.wikipedia.org/wiki/ReStructuredText>`__ (or reST or RST, for short)
 a rich but light-weight mark-up language aimed at producing documentation. The
-`Sphinx <http://sphinx-doc.org/>`__ tool is used to produce the final PDF and
+`Sphinx <https://www.sphinx-doc.org/>`__ tool is used to produce the final PDF and
 HTML documentation.
 
-This document (also written in ReST) serves as a brief introduction to ReST and to
+This document (also written in reST) serves as a brief introduction to reST and to
 document the conventions used in the User's Guide. This document is *not* intended
-to be a thorough guide to ReST. For this see the resources referenced
+to be a thorough guide to reST. For this see the resources referenced
 `below <#references>`__.
 
 Basics
@@ -91,7 +91,7 @@ The above would be rendered as,
 Headings
 ~~~~~~~~
 
-While ReST can accommodate a wide range of heading styles, we have standardized
+While reST can accommodate a wide range of heading styles, we have standardized
 on this convention in the User's Guide,
 
 .. code-block:: rest
@@ -141,7 +141,7 @@ Other languages
 Double-colon blocks are syntax-highlighted as Haskell by default. To avoid this
 use a
 ``.. code-block`` `directive
-<http://sphinx-doc.org/markup/code.html#directive-code-block>`__ with explicit
+<https://www.sphinx-doc.org/en/master/usage/restructuredtext/directives.html#directive-code-block>`__ with explicit
 language designation,
 
 .. code-block:: rest
@@ -314,7 +314,7 @@ There are a number of admonitions types,
     * warning
 
 
-.. _Admonitions: http://docutils.sourceforge.net/docs/ref/rst/directives.html#admonitions
+.. _Admonitions: https://docutils.sourceforge.io/docs/ref/rst/directives.html#admonitions
 
 Documenting command-line options and GHCi commands
 --------------------------------------------------
@@ -420,16 +420,17 @@ user-substitutable tokens. In this document we use the convention, ``⟨subst⟩
 (note that these are angle brackets, ``U+27E8`` and ``U+27E9``, not
 less-than/greater-than signs).
 
+.. _references:
 
-ReST reference materials
+reST reference materials
 ------------------------
 
-* `Sphinx ReST Primer`_: A great place to start.
-* `Sphinx extensions`_: How Sphinx extends ReST
-* `ReST reference`_: When you really need the details.
+* `Sphinx reST Primer`_: A great place to start.
+* `Sphinx extensions`_: How Sphinx extends reST
+* `reST reference`_: When you really need the details.
 * `Directives reference`_
 
-.. _Sphinx ReST Primer: http://sphinx-doc.org/rest.html
-.. _ReST reference: http://docutils.sourceforge.net/docs/ref/rst/restructuredtext.html
-.. _Sphinx extensions: http://sphinx-doc.org/markup/index.html
-.. _Directives reference: http://docutils.sourceforge.net/docs/ref/rst/directives.html#code
+.. _Sphinx reST Primer: https://www.sphinx-doc.org/en/master/usage/restructuredtext/basics.html
+.. _reST reference: https://docutils.sourceforge.io/docs/ref/rst/restructuredtext.html
+.. _Sphinx extensions: https://www.sphinx-doc.org/en/master/usage/extensions/index.html
+.. _Directives reference: https://docutils.sourceforge.io/docs/ref/rst/directives.html#code
diff --git a/docs/users_guide/using-optimisation.rst b/docs/users_guide/using-optimisation.rst
index 37e4a4aae6..139031ad1c 100644
--- a/docs/users_guide/using-optimisation.rst
+++ b/docs/users_guide/using-optimisation.rst
@@ -247,7 +247,7 @@ by saying ``-fno-wombat``.
     :default: on
 
     Enables some control flow optimisations in the Cmm code
-    generator, merging basic blocks and avoiding jumps right after jumps. 
+    generator, merging basic blocks and avoiding jumps right after jumps.
 
 .. ghc-flag:: -fasm-shortcutting
     :shortdesc: Enable shortcutting on assembly. Implied by :ghc-flag:`-O2`.
@@ -319,14 +319,64 @@ by saying ``-fno-wombat``.
     block layout behaves the same as in 8.6 and earlier.
 
 .. ghc-flag:: -fcpr-anal
-    :shortdesc: Turn on CPR analysis in the demand analyser. Implied by :ghc-flag:`-O`.
+    :shortdesc: Turn on Constructed Product Result analysis. Implied by :ghc-flag:`-O`.
     :type: dynamic
     :reverse: -fno-cpr-anal
     :category:
 
     :default: on
 
-    Turn on CPR analysis in the demand analyser.
+    Turn on CPR analysis, which enables the worker/wrapper transformation (cf.
+    :ghc-flag:`-fworker-wrapper`) to unbox the result of a function, such as ::
+
+         sum :: [Int] -> Int
+         sum []     = 0
+         sum (x:xs) = x + sum xs
+
+    CPR analysis will see that each code path produces a *constructed product*
+    such as ``I# 0#`` in the first branch (where ``GHC.Exts.I#`` is the data
+    constructor of ``Int``, boxing up the the primitive integer literal ``0#``
+    of type ``Int#``) and optimise to ::
+
+         sum xs = I# ($wsum xs)
+         $wsum []        = 0#
+         $wsum (I# x:xs) = x# +# $wsum xs
+
+    and then ``sum`` can inline to potentially cancel away the ``I#`` box.
+
+    Here's an example of the function that *does not* return a constructed product: ::
+
+         f :: [Int] -> (Int -> Int) -> Int
+         f []     g = g 0
+         f (x:xs) g = x + f xs g
+
+    The expression ``g 0`` is not a constructed product, because we don't know
+    anything about ``g``.
+
+    CPR analysis also works *nestedly*, for example ::
+
+        sumIO :: [Int] -> IO Int
+        sumIO []     = return 0
+        sumIO (x:xs) = do
+          r <- sumIO xs
+          return $! x + r
+
+    Note the use of ``$!``: Without it, GHC would be unable to see that evaluation
+    of ``r`` and ``x`` terminates (and rapidly, at that). An alternative would be to
+    evaluate both with a bang pattern or a ``seq``, but the ``return $! <res>``
+    idiom should work more reliably and needs less thinking. The above example
+    will be optimised to ::
+
+        sumIO :: [Int] -> IO Int
+        sumIO xs = IO $ \s -> case $wsum xs s of
+          (# s', r #) -> (# s', I# r #)
+        $wsumIO :: [Int] -> (# RealWorld#, Int# #)
+        $wsumIO []        s = (# s, 0# #)
+        $wsumIO (I# x:xs) s = case $wsumIO xs of
+          (# s', r #) -> (# s', x +# r#)
+
+    And the latter can inline ``sumIO`` and cancel away the ``I#`` constructor.
+    Unboxing the result of a ``State`` action should work similarly.
 
 .. ghc-flag:: -fcse
     :shortdesc: Enable common sub-expression elimination. Implied by :ghc-flag:`-O`.
diff --git a/hadrian/src/Rules/BinaryDist.hs b/hadrian/src/Rules/BinaryDist.hs
index 914039d9e8..7db11dddd0 100644
--- a/hadrian/src/Rules/BinaryDist.hs
+++ b/hadrian/src/Rules/BinaryDist.hs
@@ -234,6 +234,11 @@ bindistRules = do
           -- shipping it
           removeFile (bindistFilesDir -/- mingwStamp)
 
+        -- Include bash-completion script in binary distributions. We don't
+        -- currently install this but merely include it for the user's
+        -- reference. See #20802.
+        copyDirectory ("utils" -/- "completion") bindistFilesDir
+
         -- These scripts are only necessary in the configure/install
         -- workflow which is not supported on windows.
         -- TODO: Instead of guarding against windows, we could offer the
diff --git a/libraries/base/GHC/Event/Windows.hsc b/libraries/base/GHC/Event/Windows.hsc
index dbca116212..973f25722b 100644
--- a/libraries/base/GHC/Event/Windows.hsc
+++ b/libraries/base/GHC/Event/Windows.hsc
@@ -1163,7 +1163,7 @@ io_mngr_loop _event mgr = go False
              exit <-
                case event_id of
                  _ | event_id == io_MANAGER_WAKEUP -> return False
-                 _ | event_id == io_MANAGER_DIE    -> return True
+                 _ | event_id == io_MANAGER_DIE    -> c_ioManagerFinished >> return True
                  0 -> return False -- spurious wakeup
                  _ -> do debugIO $ "handling console event: " ++ show (event_id `shiftR` 1)
                          start_console_handler (event_id `shiftR` 1)
@@ -1204,6 +1204,9 @@ foreign import ccall unsafe "getIOManagerEvent" -- in the RTS (ThrIOManager.c)
 foreign import ccall unsafe "readIOManagerEvent" -- in the RTS (ThrIOManager.c)
   c_readIOManagerEvent :: IO Word32
 
+foreign import ccall unsafe "ioManagerFinished" -- in the RTS (ThrIOManager.c)
+  c_ioManagerFinished :: IO ()
+
 foreign import ccall unsafe "rtsSupportsBoundThreads" threadedIOMgr :: Bool
 
 -- | Sleep for n ms
diff --git a/libraries/base/GHC/IO/Windows/Paths.hs b/libraries/base/GHC/IO/Windows/Paths.hs
index 851dc37508..c755996f22 100644
--- a/libraries/base/GHC/IO/Windows/Paths.hs
+++ b/libraries/base/GHC/IO/Windows/Paths.hs
@@ -30,7 +30,7 @@ import GHC.IO
 import Foreign.C.String
 import Foreign.Marshal.Alloc (free)
 
-foreign import WINDOWS_CCONV safe "__hs_create_device_name"
+foreign import ccall safe "__hs_create_device_name"
     c_GetDevicePath :: CWString -> IO CWString
 
 -- | This function converts Windows paths between namespaces. More specifically
diff --git a/libraries/base/System/IO.hs b/libraries/base/System/IO.hs
index 265507d970..f831df6cb4 100644
--- a/libraries/base/System/IO.hs
+++ b/libraries/base/System/IO.hs
@@ -231,13 +231,13 @@ import Foreign.C.Error
 import Foreign.C.String
 import Foreign.Ptr
 import Foreign.Marshal.Alloc
+import Foreign.Marshal.Utils (with)
 import Foreign.Storable
 import GHC.IO.SubSystem
 import GHC.IO.Windows.Handle (openFileAsTemp)
 import GHC.IO.Handle.Windows (mkHandleFromHANDLE)
 import GHC.IO.Device as IODevice
 import GHC.Real (fromIntegral)
-import Foreign.Marshal.Utils (new)
 #endif
 import Foreign.C.Types
 import System.Posix.Internals
@@ -529,17 +529,17 @@ openTempFile' loc tmp_dir template binary mode
       let label = if null prefix then "ghc" else prefix
       withCWString tmp_dir $ \c_tmp_dir ->
         withCWString label $ \c_template ->
-          withCWString suffix $ \c_suffix -> do
-            c_ptr <- new nullPtr
-            res <- c_createUUIDTempFileErrNo c_tmp_dir c_template c_suffix
-                                             c_ptr
-            if not res
-               then do errno <- getErrno
-                       ioError (errnoToIOError loc errno Nothing (Just tmp_dir))
-               else do c_p <- peek c_ptr
-                       filename <- peekCWString c_p
-                       free c_p
-                       handleResultsWinIO filename ((fromIntegral mode .&. o_EXCL) == o_EXCL)
+          withCWString suffix $ \c_suffix ->
+            with nullPtr $ \c_ptr -> do
+              res <- c_createUUIDTempFileErrNo c_tmp_dir c_template c_suffix c_ptr
+              if not res
+                 then do errno <- getErrno
+                         ioError (errnoToIOError loc errno Nothing (Just tmp_dir))
+                 else do c_p <- peek c_ptr
+                         filename <- peekCWString c_p
+                         free c_p
+                         let flags = fromIntegral mode .&. o_EXCL
+                         handleResultsWinIO filename (flags == o_EXCL)
 
     findTempNamePosix = do
       let label = if null prefix then "ghc" else prefix
diff --git a/libraries/base/cbits/Win32Utils.c b/libraries/base/cbits/Win32Utils.c
index f3dec0d98d..69d30339ba 100644
--- a/libraries/base/cbits/Win32Utils.c
+++ b/libraries/base/cbits/Win32Utils.c
@@ -183,10 +183,9 @@ bool __createUUIDTempFileErrNo (wchar_t* pathName, wchar_t* prefix,
       RPC_WSTR guidStr;
       if (UuidToStringW ((UUID*)&guid, &guidStr) != S_OK)
         goto fail;
-
       /* We can't create a device path here since this path escapes the compiler
          so instead return a normal path and have openFile deal with it.  */
-      wchar_t* devName = malloc (sizeof (wchar_t) * wcslen (pathName));
+      wchar_t* devName = malloc (sizeof (wchar_t) * (wcslen (pathName) + 1));
       wcscpy (devName, pathName);
       int len = wcslen (devName) + wcslen (suffix) + wcslen (prefix)
               + wcslen (guidStr) + 3;
@@ -204,6 +203,7 @@ bool __createUUIDTempFileErrNo (wchar_t* pathName, wchar_t* prefix,
 
       free (devName);
       RpcStringFreeW (&guidStr);
+
       /* This should never happen because GUIDs are unique.  But in case hell
          froze over let's check anyway.  */
       DWORD dwAttrib = GetFileAttributesW (*tempFileName);
diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c
index 86d5b2f2d9..07db7b7998 100644
--- a/rts/RtsStartup.c
+++ b/rts/RtsStartup.c
@@ -578,6 +578,9 @@ hs_exit_(bool wait_foreign)
 #if defined(mingw32_HOST_OS)
    if (is_io_mng_native_p())
       hs_restoreConsoleCP();
+
+   /* Disable console signal handlers, we're going down!.  */
+   finiUserSignals ();
 #endif
 
     /* tear down statistics subsystem */
diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c
index f76573e3ae..ec771c27f2 100644
--- a/rts/RtsSymbols.c
+++ b/rts/RtsSymbols.c
@@ -377,13 +377,14 @@ extern char **environ;
    SymI_HasProto(unblockUserSignals)
 #else
 #define RTS_USER_SIGNALS_SYMBOLS             \
-   SymI_HasProto(registerIOCPHandle)      \
+   SymI_HasProto(registerIOCPHandle)         \
    SymI_HasProto(getOverlappedEntries)       \
    SymI_HasProto(completeSynchronousRequest) \
    SymI_HasProto(registerAlertableWait)      \
    SymI_HasProto(sendIOManagerEvent)         \
    SymI_HasProto(readIOManagerEvent)         \
    SymI_HasProto(getIOManagerEvent)          \
+   SymI_HasProto(ioManagerFinished)          \
    SymI_HasProto(console_handler)
 #endif
 
diff --git a/rts/include/rts/IOInterface.h b/rts/include/rts/IOInterface.h
index 9a646cc5cf..fd625eda70 100644
--- a/rts/include/rts/IOInterface.h
+++ b/rts/include/rts/IOInterface.h
@@ -27,6 +27,7 @@ extern StgInt console_handler;
 void *   getIOManagerEvent  (void);
 HsWord32 readIOManagerEvent (void);
 void     sendIOManagerEvent (HsWord32 event);
+void     ioManagerFinished  (void);
 
 #else
 
diff --git a/rts/win32/AsyncWinIO.c b/rts/win32/AsyncWinIO.c
index cd370296a3..fa397c343d 100644
--- a/rts/win32/AsyncWinIO.c
+++ b/rts/win32/AsyncWinIO.c
@@ -144,7 +144,7 @@
 
   There we initialize IO manager locale variables and.
   * call ioManagerStart()
-  * Creat a thread to execute "runner"
+  * Create a thread to execute "runner"
 
   We never truly shut down the IO Manager. While this means we
   might block forever on the IOPort if the IO Manager is no longer
@@ -271,6 +271,7 @@ void shutdownAsyncWinIO(bool wait_threads)
           WaitForSingleObject (workerThread, INFINITE);
         }
       completionPortHandle = INVALID_HANDLE_VALUE;
+      CloseHandle (workerThread);
       workerThread = NULL;
       workerThreadId = 0;
       free (entries);
diff --git a/rts/win32/ConsoleHandler.c b/rts/win32/ConsoleHandler.c
index 05d15868eb..4af897bc54 100644
--- a/rts/win32/ConsoleHandler.c
+++ b/rts/win32/ConsoleHandler.c
@@ -57,7 +57,7 @@ freeSignalHandlers(void) {
     /* Do nothing */
 }
 
-/* Seems to be a bit of an orphan...where used? */
+/* Called in hs_exit to clean up resources.  */
 void
 finiUserSignals(void)
 {
diff --git a/rts/win32/ConsoleHandler.h b/rts/win32/ConsoleHandler.h
index bb7278abba..d22f10f16a 100644
--- a/rts/win32/ConsoleHandler.h
+++ b/rts/win32/ConsoleHandler.h
@@ -62,3 +62,10 @@ extern void startSignalHandlers(Capability *cap);
 extern int rts_waitConsoleHandlerCompletion(void);
 
 #endif /* THREADED_RTS */
+
+/*
+ * Function: finiUserSignals()
+ *
+ * Tear down and shut down user signal processing.
+ */
+extern void finiUserSignals(void);
diff --git a/rts/win32/ThrIOManager.c b/rts/win32/ThrIOManager.c
index d614d49a0c..6bbf65a45f 100644
--- a/rts/win32/ThrIOManager.c
+++ b/rts/win32/ThrIOManager.c
@@ -161,3 +161,13 @@ ioManagerStart (void)
         rts_unlock(cap);
     }
 }
+
+/*
+ * Called to close the io_manager_event handle when the IO manager thread is
+ * terminating.
+ */
+void
+ioManagerFinished(void)
+{
+    CloseHandle(io_manager_event);
+}
diff --git a/rts/win32/ThrIOManager.h b/rts/win32/ThrIOManager.h
index a67bdde364..c7ecc76e9f 100644
--- a/rts/win32/ThrIOManager.h
+++ b/rts/win32/ThrIOManager.h
@@ -15,4 +15,4 @@
 void ioManagerWakeup (void);
 void ioManagerDie (void);
 void ioManagerStart (void);
-
+void ioManagerFinished (void);
diff --git a/testsuite/tests/profiling/should_compile/T20938.hs b/testsuite/tests/profiling/should_compile/T20938.hs
new file mode 100644
index 0000000000..2937099923
--- /dev/null
+++ b/testsuite/tests/profiling/should_compile/T20938.hs
@@ -0,0 +1,10 @@
+{-# language MagicHash #-}
+
+-- We can't put code ticks between things which are required to be saturated
+-- and their arguments.
+module T20938 where
+
+import GHC.Exts
+
+foo x = ({-# SCC foo #-} tagToEnum#) x :: Bool
+
diff --git a/testsuite/tests/profiling/should_compile/all.T b/testsuite/tests/profiling/should_compile/all.T
index a6a6d50c7c..a19a2fc49a 100644
--- a/testsuite/tests/profiling/should_compile/all.T
+++ b/testsuite/tests/profiling/should_compile/all.T
@@ -10,3 +10,4 @@ test('T14931', [only_ways(['normal']), req_profiling, unless(have_dynamic(), ski
      makefile_test, ['T14931'])
 test('T15108', [only_ways(['normal']), req_profiling], compile, ['-O -prof -fprof-auto'])
 test('T19894', [only_ways(['normal']), req_profiling, extra_files(['T19894'])], multimod_compile, ['Main', '-v0 -O2 -prof -fprof-auto -iT19894'])
+test('T20938', [only_ways(['normal']), req_profiling, expect_broken(20938)], compile, ['-O -prof'])
diff --git a/testsuite/tests/profiling/should_fail/all.T b/testsuite/tests/profiling/should_fail/all.T
index 00a7a16025..fee8454050 100644
--- a/testsuite/tests/profiling/should_fail/all.T
+++ b/testsuite/tests/profiling/should_fail/all.T
@@ -1,4 +1,3 @@
 
 test('proffail001', normal, compile_fail, ['-prof -fprof-cafs'])
 test('T17916', normal, compile_fail, [''])
-