Hadrian: fix windows cross-build (#20657)

Many small things to fix:

* Hadrian: platform triple is "x86_64-w64-mingw32" and this wasn't recognized by
  Hadrian (note "w64" instead of "unknown")

* Hadrian was using the build platform ("isWindowsHost") to detect
  the use of the Windows toolchain, which was wrong. We now use the
  "targetOs" setting.

* Hadrian was doing the same thing for Darwin so we fixed both at once,
  even if cross-compilation to Darwin is unlikely to happen afaik (cf
  "osxHost" vs "osxTarget" changes)

* Hadrian: libffi name was computed in two different places and one of
  them wasn't taking the different naming on Windows into account.

* Hadrian was passing "-Irts/include" when building the stage1 compiler
  leading to the same error as in #18143 (which is using make).
  stage1's RTS is stage0's one so mustn't do this.

* Hadrian: Windows linker doesn't seem to support "-zorigin" so we
  don't pass it (similarly to Darwin)

* Hadrian: hsc2hs in cross-compilation mode uses a trick (taken from
  autoconf): it defines "static int test_array[SOME_EXPR]" where
  SOME_EXPR is a constant expression. However GCC reports an error
  because SOME_EXPR is supposedly not constant. This is fixed by using
  another method enabled with the `--via-asm` flag of hsc2hs. It has been
  fixed in `make` build system (5f6fcf7808b16d066ad0fb2068225b3f2e8363f7)
  but not in Hadrian.

* Hadrian: some packages are specifically built only on Windows but they
  shouldn't be when building a cross-compiler (`touchy` and
  `ghci-wrapper`). We now correctly detect this case and disable these
  packages.

* Base: we use `iNVALID_HANDLE_VALUE` in a few places. It fixed some
  hsc2hs issues before we switched to `--via-asm` (see above). I've kept
  these changes are they make the code nicer.

* Base: `base`'s configure tries to detect if it is building for Windows
  but for some reason the `$host_alias` value is `x86_64-windows` in my
  case and it wasn't properly detected.

* Base: libraries/base/include/winio_structs.h imported "Windows.h" with
  a leading uppercase. It doesn't work on case-sensitive systems when
  cross-compiling so we have to use "windows.h".

* RTS: rts/win32/ThrIOManager.c was importin "rts\OSThreads.h" but this
  path isn't valid when cross-compiling. We replaced "\" with "/".

* DeriveConstants: this tool derives the constants from the target
  RTS header files. However these header files define `StgAsyncIOResult`
  only when `mingw32_HOST_OS` is set hence it seems we have to set it
  explicitly.
  Note that deriveConstants is called more than once (why? there is
  only one target for now so it shouldn't) and in the second case this
  value is correctly defined (probably coming indirectly from the import
  of "rts/PosixSource.h"). A better fix would probably be to disable the
  unneeded first run of deriveconstants.

16 files changed, 115 insertions, 80 deletions

diff --git a/hadrian/src/Oracles/Flag.hs b/hadrian/src/Oracles/Flag.hs
index 5b41698be1..535a0a0138 100644
--- a/hadrian/src/Oracles/Flag.hs
+++ b/hadrian/src/Oracles/Flag.hs
@@ -60,12 +60,11 @@ getFlag = expr . flag
 
 platformSupportsSharedLibs :: Action Bool
 platformSupportsSharedLibs = do
-    badPlatform   <- anyTargetPlatform [ "powerpc-unknown-linux"
-                                       , "x86_64-unknown-mingw32"
-                                       , "i386-unknown-mingw32" ]
+    windows       <- isWinTarget
+    ppc_linux     <- anyTargetPlatform [ "powerpc-unknown-linux" ]
     solaris       <- anyTargetPlatform [ "i386-unknown-solaris2" ]
     solarisBroken <- flag SolarisBrokenShld
-    return $ not (badPlatform || solaris && solarisBroken)
+    return $ not (windows || ppc_linux || solaris && solarisBroken)
 
 -- | Does the target support the threaded runtime system?
 targetSupportsSMP :: Action Bool
diff --git a/hadrian/src/Oracles/Setting.hs b/hadrian/src/Oracles/Setting.hs
index 73fd1ce273..b1db240f34 100644
--- a/hadrian/src/Oracles/Setting.hs
+++ b/hadrian/src/Oracles/Setting.hs
@@ -11,7 +11,7 @@ module Oracles.Setting (
 
     -- ** Target platform things
     anyTargetPlatform, anyTargetOs, anyTargetArch, anyHostOs,
-    isElfTarget,
+    isElfTarget, isOsxTarget, isWinTarget,
     ArmVersion(..),
     targetArmVersion,
     ghcWithInterpreter
@@ -240,6 +240,12 @@ anyTargetPlatform = matchSetting TargetPlatformFull
 anyTargetOs :: [String] -> Action Bool
 anyTargetOs = matchSetting TargetOs
 
+isWinTarget :: Action Bool
+isWinTarget = anyTargetOs ["mingw32"]
+
+isOsxTarget :: Action Bool
+isOsxTarget = anyTargetOs ["darwin"]
+
 -- | Check whether the target architecture setting matches one of the given
 -- strings.
 anyTargetArch :: [String] -> Action Bool
diff --git a/hadrian/src/Packages.hs b/hadrian/src/Packages.hs
index 1a7fbbe5cd..2616f097fe 100644
--- a/hadrian/src/Packages.hs
+++ b/hadrian/src/Packages.hs
@@ -13,7 +13,7 @@ module Packages (
 
     -- * Package information
     programName, nonHsMainPackage, autogenPath, programPath, timeoutPath,
-    rtsContext, rtsBuildPath, libffiBuildPath, libffiLibraryName,
+    rtsContext, rtsBuildPath, libffiBuildPath,
     ensureConfigured
     ) where
 
@@ -219,16 +219,6 @@ libffiBuildPath stage = buildPath $ Context
     libffi
     (error "libffiBuildPath: way not set.")
 
--- | Name of the 'libffi' library.
-libffiLibraryName :: Action FilePath
-libffiLibraryName = do
-    useSystemFfi <- flag UseSystemFfi
-    return $ case (useSystemFfi, windowsHost) of
-        (True , False) -> "ffi"
-        (False, False) -> "Cffi"
-        (_    , True ) -> "Cffi-6"
-
-
 {-
 Note [Hadrian's ghci-wrapper package]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/hadrian/src/Rules/Libffi.hs b/hadrian/src/Rules/Libffi.hs
index 86238c30a4..27a4a3e9f2 100644
--- a/hadrian/src/Rules/Libffi.hs
+++ b/hadrian/src/Rules/Libffi.hs
@@ -81,16 +81,24 @@ libffiContext stage = do
         then dynamic
         else vanilla
 
--- | The name of the (locally built) library
+-- | The name of the library
 libffiName :: Expr String
 libffiName = do
-    way <- getWay
-    return $ libffiName' (Dynamic `wayUnit` way)
+    useSystemFfi <- expr (flag UseSystemFfi)
+    if useSystemFfi
+      then pure "ffi"
+      else libffiLocalName Nothing
 
 -- | The name of the (locally built) library
-libffiName' :: Bool -> String
-libffiName' dynamic = (if dynamic     then ""      else "C")
-                   ++ (if windowsHost then "ffi-6" else "ffi")
+libffiLocalName :: Maybe Bool -> Expr String
+libffiLocalName force_dynamic = do
+  way <- getWay
+  winTarget <- expr isWinTarget
+  let dynamic = fromMaybe (Dynamic `wayUnit` way) force_dynamic
+  pure $ mconcat
+      [ if dynamic   then ""      else "C"
+      , if winTarget then "ffi-6" else "ffi"
+      ]
 
 libffiLibrary :: FilePath
 libffiLibrary = "inst/lib/libffi.a"
@@ -164,21 +172,24 @@ libffiRules = do
 
         -- Note this build needs the Makefile, triggering the rules bellow.
         build $ target context (Make libffiPath) [] []
+        libffiName' <- interpretInContext context (libffiLocalName (Just True))
 
         -- Produces all install files.
         produces =<< (\\ topLevelTargets)
                  <$> liftIO (getDirectoryFilesIO "." [libffiPath -/- "inst//*"])
 
         -- Find dynamic libraries.
+        osxTarget <- isOsxTarget
+        winTarget <- isWinTarget
+
         dynLibFiles <- do
             let libfilesDir = libffiPath -/-
-                    (if windowsHost then "inst" -/- "bin" else "inst" -/- "lib")
-                libffiName'' = libffiName' True
+                    (if winTarget then "inst" -/- "bin" else "inst" -/- "lib")
                 dynlibext
-                    | windowsHost = "dll"
-                    | osxHost     = "dylib"
-                    | otherwise   = "so"
-                filepat = "lib" ++ libffiName'' ++ "." ++ dynlibext ++ "*"
+                    | winTarget = "dll"
+                    | osxTarget = "dylib"
+                    | otherwise = "so"
+                filepat = "lib" ++ libffiName' ++ "." ++ dynlibext ++ "*"
             liftIO $ getDirectoryFilesIO "." [libfilesDir -/- filepat]
 
         writeFileLines dynLibMan dynLibFiles
diff --git a/hadrian/src/Rules/Rts.hs b/hadrian/src/Rules/Rts.hs
index efcd5f614a..a6abcdeb3e 100644
--- a/hadrian/src/Rules/Rts.hs
+++ b/hadrian/src/Rules/Rts.hs
@@ -1,6 +1,6 @@
 module Rules.Rts (rtsRules, needRtsLibffiTargets, needRtsSymLinks) where
 
-import Packages (rts, rtsBuildPath, libffiBuildPath, libffiLibraryName, rtsContext)
+import Packages (rts, rtsBuildPath, libffiBuildPath, rtsContext)
 import Rules.Libffi
 import Hadrian.Utilities
 import Settings.Builders.Common
@@ -103,7 +103,7 @@ copyLibffiDynamicWin stage target = do
 
 rtsLibffiLibrary :: Stage -> Way -> Action FilePath
 rtsLibffiLibrary stage way = do
-    name    <- libffiLibraryName
+    name    <- interpretInContext (rtsContext stage) libffiName
     suf     <- libsuf stage way
     rtsPath <- rtsBuildPath stage
     return $ rtsPath -/- "lib" ++ name ++ suf
diff --git a/hadrian/src/Settings/Builders/Common.hs b/hadrian/src/Settings/Builders/Common.hs
index 8daa8a1f88..11b6f20ef5 100644
--- a/hadrian/src/Settings/Builders/Common.hs
+++ b/hadrian/src/Settings/Builders/Common.hs
@@ -15,7 +15,6 @@ import Base
 import Expression
 import Oracles.Flag
 import Oracles.Setting
-import Packages
 import Settings
 import UserSettings
 
@@ -31,7 +30,7 @@ cIncludeArgs = do
     ffiIncludeDir   <- getSetting FfiIncludeDir
     libdwIncludeDir   <- getSetting FfiIncludeDir
     libPath <- expr $ stageLibPath stage
-    mconcat [ notStage0 ||^ package compiler ? arg "-Irts/include"
+    mconcat [ notStage0 ? arg "-Irts/include"
             , arg $ "-I" ++ libPath
             , arg $ "-I" ++ path
             , pure . map ("-I"++) . filter (/= "") $ [iconvIncludeDir, gmpIncludeDir]
diff --git a/hadrian/src/Settings/Builders/Ghc.hs b/hadrian/src/Settings/Builders/Ghc.hs
index b4c129562e..1d315e50ea 100644
--- a/hadrian/src/Settings/Builders/Ghc.hs
+++ b/hadrian/src/Settings/Builders/Ghc.hs
@@ -104,6 +104,9 @@ ghcLinkArgs = builder (Ghc LinkHs) ? do
     libffiName' <- libffiName
     debugged <- ghcDebugged <$> expr flavour
 
+    osxTarget <- expr isOsxTarget
+    winTarget <- expr isWinTarget
+
     let
         dynamic = Dynamic `wayUnit` way
         distPath = libPath' -/- distDir
@@ -115,7 +118,7 @@ ghcLinkArgs = builder (Ghc LinkHs) ? do
             -- libraries will all end up in the lib dir, so just use $ORIGIN
             | otherwise     = metaOrigin
             where
-                metaOrigin | osxHost   = "@loader_path"
+                metaOrigin | osxTarget = "@loader_path"
                            | otherwise = "$ORIGIN"
 
         -- TODO: an alternative would be to generalize by linking with extra
@@ -144,8 +147,8 @@ ghcLinkArgs = builder (Ghc LinkHs) ? do
                 , hostSupportsRPaths ? mconcat
                       [ arg ("-optl-Wl,-rpath," ++ rpath)
                       , isProgram pkg ? arg ("-optl-Wl,-rpath," ++ bindistRpath)
-                      -- The darwin linker doesn't support/require the -zorigin option
-                      , not osxHost ? arg "-optl-Wl,-zorigin"
+                      -- The darwin and Windows linkers don't support/require the -zorigin option
+                      , not (osxTarget || winTarget) ? arg "-optl-Wl,-zorigin"
                       -- We set RPATH directly (relative to $ORIGIN). There's
                       -- no reason for GHC to inject further RPATH entries.
                       -- See #19485.
@@ -158,7 +161,7 @@ ghcLinkArgs = builder (Ghc LinkHs) ? do
             , pure [ "-l" ++ lib    | lib    <- libs    ]
             , pure [ "-L" ++ libDir | libDir <- libDirs ]
             , rtsFfiArg
-            , osxHost ? pure (concat [ ["-framework", fmwk] | fmwk <- fmwks ])
+            , osxTarget ? pure (concat [ ["-framework", fmwk] | fmwk <- fmwks ])
             , debugged ? packageOneOf [ghc, iservProxy, iserv, remoteIserv] ?
               arg "-debug"
 
diff --git a/hadrian/src/Settings/Builders/Hsc2Hs.hs b/hadrian/src/Settings/Builders/Hsc2Hs.hs
index 67c32c5ed4..f1a44b5e87 100644
--- a/hadrian/src/Settings/Builders/Hsc2Hs.hs
+++ b/hadrian/src/Settings/Builders/Hsc2Hs.hs
@@ -22,7 +22,7 @@ hsc2hsBuilderArgs = builder Hsc2Hs ? do
     tmpl <- (top -/-) <$> expr (templateHscPath Stage0)
     mconcat [ arg $ "--cc=" ++ ccPath
             , arg $ "--ld=" ++ ccPath
-            , not windowsHost ? notM (flag CrossCompiling) ? arg "--cross-safe"
+            , notM isWinTarget ? notM (flag CrossCompiling) ? arg "--cross-safe"
             , pure $ map ("-I" ++) (words gmpDir)
             , map ("--cflag=" ++) <$> getCFlags
             , map ("--lflag=" ++) <$> getLFlags
@@ -33,6 +33,13 @@ hsc2hsBuilderArgs = builder Hsc2Hs ? do
             , notStage0 ? arg ("--cflag=-D" ++ tOs   ++ "_HOST_OS=1"  )
             , arg $ "--cflag=-D__GLASGOW_HASKELL__=" ++ version
             , arg $ "--template=" ++ tmpl
+              -- We'll assume we compile with gcc or clang, and both support
+              -- `-S` and can as such use the --via-asm flag, which should be
+              -- faster and is required for cross compiling to windows, as the c
+              -- compiler complains about non-constant expressions even though
+              -- they are constant and end up as constants in the assembly.
+              -- See #12849
+            , flag CrossCompiling ? isWinTarget ? arg "--via-asm"
             , arg =<< getInput
             , arg "-o", arg =<< getOutput ]
 
diff --git a/hadrian/src/Settings/Default.hs b/hadrian/src/Settings/Default.hs
index 2da096efdb..a20a1d821d 100644
--- a/hadrian/src/Settings/Default.hs
+++ b/hadrian/src/Settings/Default.hs
@@ -22,6 +22,7 @@ import CommandLine
 import Expression
 import Flavour.Type
 import Oracles.Flag
+import Oracles.Setting
 import Packages
 import Settings.Builders.Alex
 import Settings.Builders.DeriveConstants
@@ -92,42 +93,51 @@ stage1Packages :: Action [Package]
 stage1Packages = do
     libraries0 <- filter isLibrary <$> stage0Packages
     cross      <- flag CrossCompiling
-    return $ libraries0 -- Build all Stage0 libraries in Stage1
-          ++ [ array
-             , base
-             , bytestring
-             , containers
-             , deepseq
-             , directory
-             , exceptions
-             , filepath
-             , ghc
-             , ghcBignum
-             , ghcCompact
-             , ghcPkg
-             , ghcPrim
-             , haskeline
-             , hp2ps
-             , hsc2hs
-             , integerGmp
-             , pretty
-             , process
-             , rts
-             , stm
-             , time
-             , unlit
-             , xhtml
-             ]
-          ++ [ haddock  | not cross                  ]
-          ++ [ hpcBin   | not cross                  ]
-          ++ [ iserv    | not cross ]
-          ++ [ libiserv | not cross ]
-          ++ [ runGhc   | not cross                  ]
-          ++ [ touchy   | windowsHost                ]
-             -- See Note [Hadrian's ghci-wrapper package]
-          ++ [ ghciWrapper | windowsHost             ]
-          ++ [ unix     | not windowsHost            ]
-          ++ [ win32    | windowsHost                ]
+    winTarget  <- isWinTarget
+
+    let when c xs = if c then xs else mempty
+
+    return $ mconcat
+      [ libraries0 -- Build all Stage0 libraries in Stage1
+      , [ array
+        , base
+        , bytestring
+        , containers
+        , deepseq
+        , directory
+        , exceptions
+        , filepath
+        , ghc
+        , ghcBignum
+        , ghcCompact
+        , ghcPkg
+        , ghcPrim
+        , haskeline
+        , hp2ps
+        , hsc2hs
+        , integerGmp
+        , pretty
+        , process
+        , rts
+        , stm
+        , time
+        , unlit
+        , xhtml
+        ]
+      , when (not cross)
+        [ haddock
+        , hpcBin
+        , iserv
+        , libiserv
+        , runGhc
+        ]
+      , if winTarget then [ win32 ] else [ unix ]
+      , when (winTarget && not cross)
+        [ touchy
+         -- See Note [Hadrian's ghci-wrapper package]
+        , ghciWrapper
+        ]
+      ]
 
 -- | Packages built in 'Stage2' by default. You can change this in "UserSettings".
 stage2Packages :: Action [Package]
diff --git a/hadrian/src/Settings/Packages.hs b/hadrian/src/Settings/Packages.hs
index 6099b66055..bcdd62191a 100644
--- a/hadrian/src/Settings/Packages.hs
+++ b/hadrian/src/Settings/Packages.hs
@@ -6,6 +6,7 @@ import Oracles.Setting
 import Oracles.Flag
 import Packages
 import Settings
+import Rules.Libffi
 
 -- | Package-specific command-line arguments.
 packageArgs :: Args
@@ -13,6 +14,7 @@ packageArgs = do
     stage        <- getStage
     path         <- getBuildPath
     compilerPath <- expr $ buildPath (vanillaContext stage compiler)
+
     let -- Do not bind the result to a Boolean: this forces the configure rule
         -- immediately and may lead to cyclic dependencies.
         -- See: https://gitlab.haskell.org/ghc/ghc/issues/16809.
@@ -240,7 +242,7 @@ rtsPackageArgs = package rts ? do
     path           <- getBuildPath
     top            <- expr topDirectory
     useSystemFfi   <- expr $ flag UseSystemFfi
-    libffiName     <- expr libffiLibraryName
+    ffiLibName     <- libffiName
     ffiIncludeDir  <- getSetting FfiIncludeDir
     ffiLibraryDir  <- getSetting FfiLibDir
     libdwIncludeDir   <- getSetting LibdwIncludeDir
@@ -370,7 +372,7 @@ rtsPackageArgs = package rts ? do
           [ "-DTOP="             ++ show top
           , "-DFFI_INCLUDE_DIR=" ++ show ffiIncludeDir
           , "-DFFI_LIB_DIR="     ++ show ffiLibraryDir
-          , "-DFFI_LIB="         ++ show libffiName
+          , "-DFFI_LIB="         ++ show ffiLibName
           , "-DLIBDW_LIB_DIR="   ++ show libdwLibraryDir ]
 
         , builder HsCpp ? flag WithLibdw ? arg "-DUSE_LIBDW"
diff --git a/libraries/base/GHC/Event/Windows.hsc b/libraries/base/GHC/Event/Windows.hsc
index a695df71d2..dd0b2d9db9 100644
--- a/libraries/base/GHC/Event/Windows.hsc
+++ b/libraries/base/GHC/Event/Windows.hsc
@@ -481,7 +481,7 @@ associateHandle' hwnd
 
 -- | A handle value representing an invalid handle.
 invalidHandle :: HANDLE
-invalidHandle = intPtrToPtr (#{const INVALID_HANDLE_VALUE})
+invalidHandle = iNVALID_HANDLE_VALUE
 
 -- | Associate a 'HANDLE' with the I/O manager's completion port.  This must be
 -- done before using the handle with 'withOverlapped'.
diff --git a/libraries/base/System/Environment/ExecutablePath.hsc b/libraries/base/System/Environment/ExecutablePath.hsc
index 6d8eac9b83..5cb49489c5 100644
--- a/libraries/base/System/Environment/ExecutablePath.hsc
+++ b/libraries/base/System/Environment/ExecutablePath.hsc
@@ -56,6 +56,7 @@ import Data.Word
 import Foreign.C
 import Foreign.Marshal.Array
 import Foreign.Ptr
+import GHC.Windows
 #include <windows.h>
 #include <stdint.h>
 #else
@@ -278,7 +279,7 @@ executablePath = Just (Just <$> getExecutablePath)
 getFinalPath :: FilePath -> IO FilePath
 getFinalPath path = withCWString path $ \s ->
   bracket (createFile s) c_closeHandle $ \h -> do
-    let invalid = h == wordPtrToPtr (#const (intptr_t)INVALID_HANDLE_VALUE)
+    let invalid = h == iNVALID_HANDLE_VALUE
     if invalid then pure path else go h bufSize
 
   where go h sz = allocaArray (fromIntegral sz) $ \outPath -> do
diff --git a/libraries/base/configure.ac b/libraries/base/configure.ac
index 68295563af..e034549476 100644
--- a/libraries/base/configure.ac
+++ b/libraries/base/configure.ac
@@ -12,7 +12,7 @@ AC_USE_SYSTEM_EXTENSIONS
 
 AC_MSG_CHECKING(for WINDOWS platform)
 case $host_alias in
-    *mingw32*|*mingw64*|*cygwin*|*msys*)
+    *mingw32*|*mingw64*|*cygwin*|*msys*|*windows*)
         WINDOWS=YES;;
     *)
         WINDOWS=NO;;
diff --git a/libraries/base/include/winio_structs.h b/libraries/base/include/winio_structs.h
index da9dab05b7..a4c7604fd0 100644
--- a/libraries/base/include/winio_structs.h
+++ b/libraries/base/include/winio_structs.h
@@ -4,7 +4,7 @@
  * Structures supporting the IOCP based I/O Manager or Windows.
  */
 
-#include <Windows.h>
+#include <windows.h>
 #include <stdint.h>
 
 #if defined(_WIN64)
diff --git a/rts/win32/ThrIOManager.c b/rts/win32/ThrIOManager.c
index b29bf1072e..d614d49a0c 100644
--- a/rts/win32/ThrIOManager.c
+++ b/rts/win32/ThrIOManager.c
@@ -11,7 +11,7 @@
 #include "Rts.h"
 #include "ThrIOManager.h"
 #include "MIOManager.h"
-#include "rts\OSThreads.h"
+#include "rts/OSThreads.h"
 #include "Prelude.h"
 #include <windows.h>
 
diff --git a/utils/deriveConstants/Main.hs b/utils/deriveConstants/Main.hs
index 8d3a6798c0..f5ccad3641 100644
--- a/utils/deriveConstants/Main.hs
+++ b/utils/deriveConstants/Main.hs
@@ -714,6 +714,13 @@ getWanted verbose os tmpdir gccProgram gccFlags nmProgram mobjdumpProgram
                      "",
                      "#define PROFILING",
                      "#define THREADED_RTS",
+                     -- We need to define this if we want StgAsyncIOResult
+                     -- struct to be present after CPP
+                     --
+                     -- FIXME: rts/PosixSource.h should include ghcplatform.h
+                     -- which should set this. There is a mismatch host/target
+                     -- again...
+                     if os == "mingw32" then "#define mingw32_HOST_OS 1" else "",
                      "",
                      "#include \"rts/PosixSource.h\"",
                      "#include \"Rts.h\"",