compiler/main/GhcMake.hs

@@ -2185,7 +2185,7 @@ enableCodeGenForUnboxedTuplesOrSums =
   where
     condition ms =
       unboxed_tuples_or_sums (ms_hspp_opts ms) &&
-      not (gopt Opt_ByteCode (ms_hspp_opts ms)) &&
+      not (gopt Opt_ByteCodeIfUnboxed (ms_hspp_opts ms)) &&
       not (isBootSummary ms)
     unboxed_tuples_or_sums d =
       xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d

compiler/main/HscMain.hs

@@ -164,7 +164,7 @@ import Stream (Stream)
 
 import Util
 
-import Data.List
+import Data.List        ( nub, isPrefixOf, partition )
 import Control.Monad
 import Data.IORef
 import System.FilePath as FilePath

compiler/main/Plugins.hs

@@ -60,7 +60,7 @@ import GhcMonad
 import DriverPhases
 import Module ( ModuleName, Module(moduleName))
 import Fingerprint
-import Data.List
+import Data.List (sort)
 import Outputable (Outputable(..), text, (<+>))
 
 --Qualified import so we can define a Semigroup instance

compiler/main/Settings.hs

@@ -19,11 +19,14 @@ module Settings
   , sPgm_c
   , sPgm_a
   , sPgm_l
+  , sPgm_lm
   , sPgm_dll
   , sPgm_T
   , sPgm_windres
   , sPgm_libtool
   , sPgm_ar
+  , sPgm_otool
+  , sPgm_install_name_tool
   , sPgm_ranlib
   , sPgm_lo
   , sPgm_lc
@@ -37,6 +40,7 @@ module Settings
   , sOpt_cxx
   , sOpt_a
   , sOpt_l
+  , sOpt_lm
   , sOpt_windres
   , sOpt_lo
   , sOpt_lc
@@ -125,6 +129,8 @@ sPgm_a :: Settings -> (String, [Option])
 sPgm_a = toolSettings_pgm_a . sToolSettings
 sPgm_l :: Settings -> (String, [Option])
 sPgm_l = toolSettings_pgm_l . sToolSettings
+sPgm_lm :: Settings -> (String, [Option])
+sPgm_lm = toolSettings_pgm_lm . sToolSettings
 sPgm_dll :: Settings -> (String, [Option])
 sPgm_dll = toolSettings_pgm_dll . sToolSettings
 sPgm_T :: Settings -> String
@@ -135,6 +141,10 @@ sPgm_libtool :: Settings -> String
 sPgm_libtool = toolSettings_pgm_libtool . sToolSettings
 sPgm_ar :: Settings -> String
 sPgm_ar = toolSettings_pgm_ar . sToolSettings
+sPgm_otool :: Settings -> String
+sPgm_otool = toolSettings_pgm_otool . sToolSettings
+sPgm_install_name_tool :: Settings -> String
+sPgm_install_name_tool = toolSettings_pgm_install_name_tool . sToolSettings
 sPgm_ranlib :: Settings -> String
 sPgm_ranlib = toolSettings_pgm_ranlib . sToolSettings
 sPgm_lo :: Settings -> (String, [Option])
@@ -161,6 +171,8 @@ sOpt_a :: Settings -> [String]
 sOpt_a = toolSettings_opt_a . sToolSettings
 sOpt_l :: Settings -> [String]
 sOpt_l = toolSettings_opt_l . sToolSettings
+sOpt_lm :: Settings -> [String]
+sOpt_lm = toolSettings_opt_lm . sToolSettings
 sOpt_windres :: Settings -> [String]
 sOpt_windres = toolSettings_opt_windres . sToolSettings
 sOpt_lo :: Settings -> [String]

compiler/main/SysTools.hs

@@ -254,7 +254,10 @@ linkDynLib dflags0 o_files dep_packages
          | ( osElfTarget (platformOS (targetPlatform dflags)) ||
              osMachOTarget (platformOS (targetPlatform dflags)) ) &&
            dynLibLoader dflags == SystemDependent &&
-           WayDyn `elem` ways dflags
+           -- Only if we want dynamic libraries
+           WayDyn `elem` ways dflags &&
+           -- Only use RPath if we explicitly asked for it
+           gopt Opt_RPath dflags
             = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l]
               -- See Note [-Xlinker -rpath vs -Wl,-rpath]
          | otherwise = ["-L" ++ l]
@@ -377,8 +380,15 @@ linkDynLib dflags0 o_files dep_packages
                  ++ map Option pkg_lib_path_opts
                  ++ map Option pkg_link_opts
                  ++ map Option pkg_framework_opts
-                 ++ [ Option "-Wl,-dead_strip_dylibs" ]
+                 -- dead_strip_dylibs, will remove unused dylibs, and thus save
+                 -- space in the load commands. The -headerpad is necessary so
+                 -- that we can inject more @rpath's later for the leftover
+                 -- libraries in the runInjectRpaths phase below.
+                 --
+                 -- See Note [Dynamic linking on macOS]
+                 ++ [ Option "-Wl,-dead_strip_dylibs", Option "-Wl,-headerpad,8000" ]
               )
+            runInjectRPaths dflags pkg_lib_paths output_fn
         _ -> do
             -------------------------------------------------------------------
             -- Making a DSO

compiler/main/SysTools/Info.hs

@@ -231,13 +231,13 @@ getCompilerInfo' dflags = do
         -- FreeBSD clang
         | any ("FreeBSD clang version" `isInfixOf`) stde =
           return Clang
-        -- XCode 5.1 clang
+        -- Xcode 5.1 clang
         | any ("Apple LLVM version 5.1" `isPrefixOf`) stde =
           return AppleClang51
-        -- XCode 5 clang
+        -- Xcode 5 clang
         | any ("Apple LLVM version" `isPrefixOf`) stde =
           return AppleClang
-        -- XCode 4.1 clang
+        -- Xcode 4.1 clang
         | any ("Apple clang version" `isPrefixOf`) stde =
           return AppleClang
          -- Unknown linker.

compiler/main/SysTools/Settings.hs

@@ -119,6 +119,8 @@ initSettings top_dir = do
   windres_path <- getToolSetting "windres command"
   libtool_path <- getToolSetting "libtool command"
   ar_path <- getToolSetting "ar command"
+  otool_path <- getToolSetting "otool command"
+  install_name_tool_path <- getToolSetting "install_name_tool command"
   ranlib_path <- getToolSetting "ranlib command"
 
   -- TODO this side-effect doesn't belong here. Reading and parsing the settings
@@ -141,6 +143,8 @@ initSettings top_dir = do
         as_args  = map Option cc_args
         ld_prog  = cc_prog
         ld_args  = map Option (cc_args ++ words cc_link_args_str)
+  ld_r_prog <- getToolSetting "Merge objects command"
+  ld_r_args <- getSetting "Merge objects flags"
 
   llvmTarget <- getSetting "LLVM target"
 
@@ -202,11 +206,14 @@ initSettings top_dir = do
       , toolSettings_pgm_c   = cc_prog
       , toolSettings_pgm_a   = (as_prog, as_args)
       , toolSettings_pgm_l   = (ld_prog, ld_args)
+      , toolSettings_pgm_lm  = (ld_r_prog, map Option $ words ld_r_args)
       , toolSettings_pgm_dll = (mkdll_prog,mkdll_args)
       , toolSettings_pgm_T   = touch_path
       , toolSettings_pgm_windres = windres_path
       , toolSettings_pgm_libtool = libtool_path
       , toolSettings_pgm_ar = ar_path
+      , toolSettings_pgm_otool = otool_path
+      , toolSettings_pgm_install_name_tool = install_name_tool_path
       , toolSettings_pgm_ranlib = ranlib_path
       , toolSettings_pgm_lo  = (lo_prog,[])
       , toolSettings_pgm_lc  = (lc_prog,[])
@@ -220,6 +227,7 @@ initSettings top_dir = do
       , toolSettings_opt_cxx     = cxx_args
       , toolSettings_opt_a       = []
       , toolSettings_opt_l       = []
+      , toolSettings_opt_lm      = []
       , toolSettings_opt_windres = []
       , toolSettings_opt_lcc     = []
       , toolSettings_opt_lo      = []

compiler/main/SysTools/Tasks.hs

 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
 -----------------------------------------------------------------------------
 --
 -- Tasks running external programs for SysTools
@@ -27,6 +28,10 @@ import LlvmCodeGen.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersion, pars
 import SysTools.Process
 import SysTools.Info
 
+import Control.Monad (join, forM, filterM)
+import System.Directory (doesFileExist)
+import System.FilePath ((</>))
+
 {-
 ************************************************************************
 *                                                                      *
@@ -127,10 +132,9 @@ runCc mLanguage dflags args = traceToolCommand dflags "cc" $ do
     Nothing -> ([], userOpts_c)
     Just language -> ([Option "-x", Option languageName], opts)
       where
-        s = settings dflags
         (languageName, opts) = case language of
-          LangC      -> ("c",             sOpt_c s ++ userOpts_c)
-          LangCxx    -> ("c++",           sOpt_cxx s ++ userOpts_cxx)
+          LangC      -> ("c",             userOpts_c)
+          LangCxx    -> ("c++",           userOpts_cxx)
           LangObjc   -> ("objective-c",   userOpts_c)
           LangObjcxx -> ("objective-c++", userOpts_cxx)
           LangAsm    -> ("assembler",     [])
@@ -237,6 +241,41 @@ figureLlvmVersion dflags = traceToolCommand dflags "llc" $ do
                 return Nothing)
 
 
+-- | On macOS we rely on the linkers @-dead_strip_dylibs@ flag to remove unused
+-- libraries from the dynamic library.  We do this to reduce the number of load
+-- commands that end up in the dylib, and has been limited to 32K (32768) since
+-- macOS Sierra (10.14).
+--
+-- @-dead_strip_dylibs@ does not dead strip @-rpath@ entries, as such passing
+-- @-l@ and @-rpath@ to the linker will result in the unnecesasry libraries not
+-- being included in the load commands, however the @-rpath@ entries are all
+-- forced to be included.  This can lead to 100s of @-rpath@ entries being
+-- included when only a handful of libraries end up being truely linked.
+--
+-- Thus after building the library, we run a fixup phase where we inject the
+-- @-rpath@ for each found library (in the given library search paths) into the
+-- dynamic library through @-add_rpath@.
+--
+-- See Note [Dynamic linking on macOS]
+runInjectRPaths :: DynFlags -> [FilePath] -> FilePath -> IO ()
+runInjectRPaths dflags lib_paths dylib = do
+  info <- lines <$> askOtool dflags Nothing [Option "-L", Option dylib]
+  -- filter the output for only the libraries. And then drop the @rpath prefix.
+  let libs = fmap (drop 7) $ filter (isPrefixOf "@rpath") $ fmap (head.words) $ info
+  -- find any pre-existing LC_PATH items
+  info <- fmap words.lines <$> askOtool dflags Nothing [Option "-l", Option dylib]
+  let paths = concatMap f info
+        where f ("path":p:_) = [p]
+              f _            = []
+      lib_paths' = [ p | p <- lib_paths, not (p `elem` paths) ]
+  -- only find those rpaths, that aren't already in the library.
+  rpaths <- nub.sort.join <$> forM libs (\f -> filterM (\l -> doesFileExist (l </> f)) lib_paths')
+  -- inject the rpaths
+  case rpaths of
+    [] -> return ()
+    _  -> runInstallNameTool dflags $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib]
+
+
 runLink :: DynFlags -> [Option] -> IO ()
 runLink dflags args = traceToolCommand dflags "linker" $ do
   -- See Note [Run-time linker info]
@@ -300,6 +339,20 @@ ld: warning: symbol referencing errors
     ld_postfix = tail . snd . ld_warn_break
     ld_warning_found = not . null . snd . ld_warn_break
 
+-- See Note [Merging object files for GHCi] in GHC.Driver.Pipeline.
+runMergeObjects :: DynFlags -> [Option] -> IO ()
+runMergeObjects dflags args = traceToolCommand dflags "merge-objects" $ do
+  let (p,args0) = pgm_lm dflags
+      optl_args = map Option (getOpts dflags opt_lm)
+      args2     = args0 ++ args ++ optl_args
+  -- N.B. Darwin's ld64 doesn't support response files. Consequently we only
+  -- use them on Windows where they are truly necessary.
+#if defined(mingw32_HOST_OS)
+  mb_env <- getGccEnv args2
+  runSomethingResponseFile dflags id "Merge objects" p args2 mb_env
+#else
+  runSomething dflags "Merge objects" p args2
+#endif
 
 runLibtool :: DynFlags -> [Option] -> IO ()
 runLibtool dflags args = traceToolCommand dflags "libtool" $ do
@@ -321,6 +374,17 @@ askAr dflags mb_cwd args = traceToolCommand dflags "ar" $ do
   runSomethingWith dflags "Ar" ar args $ \real_args ->
     readCreateProcessWithExitCode' (proc ar real_args){ cwd = mb_cwd }
 
+askOtool :: DynFlags -> Maybe FilePath -> [Option] -> IO String
+askOtool dflags mb_cwd args = do
+  let otool = pgm_otool dflags
+  runSomethingWith dflags "otool" otool args $ \real_args ->
+    readCreateProcessWithExitCode' (proc otool real_args){ cwd = mb_cwd }
+
+runInstallNameTool :: DynFlags -> [Option] -> IO ()
+runInstallNameTool dflags args = do
+  let tool = pgm_install_name_tool dflags
+  runSomethingFiltered dflags id "Install Name Tool" tool args Nothing Nothing
+
 runRanlib :: DynFlags -> [Option] -> IO ()
 runRanlib dflags args = traceToolCommand dflags "ranlib" $ do
   let ranlib = pgm_ranlib dflags

compiler/main/ToolSettings.hs

@@ -25,11 +25,14 @@ data ToolSettings = ToolSettings
   , toolSettings_pgm_c       :: String
   , toolSettings_pgm_a       :: (String, [Option])
   , toolSettings_pgm_l       :: (String, [Option])
+  , toolSettings_pgm_lm      :: (String, [Option])
   , toolSettings_pgm_dll     :: (String, [Option])
   , toolSettings_pgm_T       :: String
   , toolSettings_pgm_windres :: String
   , toolSettings_pgm_libtool :: String
   , toolSettings_pgm_ar      :: String
+  , toolSettings_pgm_otool   :: String
+  , toolSettings_pgm_install_name_tool :: String
   , toolSettings_pgm_ranlib  :: String
   , -- | LLVM: opt llvm optimiser
     toolSettings_pgm_lo      :: (String, [Option])
@@ -50,6 +53,7 @@ data ToolSettings = ToolSettings
   , toolSettings_opt_cxx           :: [String]
   , toolSettings_opt_a             :: [String]
   , toolSettings_opt_l             :: [String]
+  , toolSettings_opt_lm            :: [String]
   , toolSettings_opt_windres       :: [String]
   , -- | LLVM: llvm optimiser
     toolSettings_opt_lo            :: [String]

compiler/nativeGen/CFG.hs

@@ -81,7 +81,7 @@ import Outputable
 import PprCmm () -- For Outputable instances
 import qualified DynFlags as D
 
-import Data.List
+import Data.List (sort, nub, partition)
 import Data.STRef.Strict
 import Control.Monad.ST
 

compiler/nativeGen/Reg.hs

@@ -31,7 +31,7 @@ import GhcPrelude
 import Outputable
 import Unique
 import RegClass
-import Data.List
+import Data.List (intersect)
 
 -- | An identifier for a primitive real machine register.
 type RegNo

compiler/nativeGen/X86/CodeGen.hs

@@ -292,11 +292,11 @@ we construct as a separate data type and the actual control flow graph in the co
 Instead we now return the new basic block if a statement causes a change
 in the current block and use the block for all following statements.
 
-For this reason genCCall is also split into two parts.
-One for calls which *won't* change the basic blocks in
-which successive instructions will be placed.
-A different one for calls which *are* known to change the
-basic block.
+For this reason genCCall is also split into two parts.  One for calls which
+*won't* change the basic blocks in which successive instructions will be
+placed (since they only evaluate CmmExpr, which can only contain MachOps, which
+cannot introduce basic blocks in their lowerings).  A different one for calls
+which *are* known to change the basic block.
 
 -}
 
@@ -1037,6 +1037,9 @@ getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps
           tmp.  This is likely to be better, because the reg alloc can
           eliminate this reg->reg move here (it won't eliminate the other one,
           because the move is into the fixed %ecx).
+      * in the case of C calls the use of ecx here can interfere with arguments.
+        We avoid this with the hack described in Note [Evaluate C-call
+        arguments before placing in destination registers]
     -}
     shift_code width instr x y{-amount-} = do
         x_code <- getAnyReg x
@@ -1801,6 +1804,35 @@ I386: First, we have to ensure that the condition
 codes are set according to the supplied comparison operation.
 -}
 
+{-  Note [64-bit integer comparisons on 32-bit]
+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+    When doing these comparisons there are 2 kinds of
+    comparisons.
+
+    * Comparison for equality (or lack thereof)
+
+    We use xor to check if high/low bits are
+    equal. Then combine the results using or and
+    perform a single conditional jump based on the
+    result.
+
+    * Other comparisons:
+
+    We map all other comparisons to the >= operation.
+    Why? Because it's easy to encode it with a single
+    conditional jump.
+
+    We do this by first computing [r1_lo - r2_lo]
+    and use the carry flag to compute
+    [r1_high - r2_high - CF].
+
+    At which point if r1 >= r2 then the result will be
+    positive. Otherwise negative so we can branch on this
+    condition.
+
+-}
+
 
 genCondBranch
     :: BlockId      -- the source of the jump
@@ -1818,22 +1850,63 @@ genCondBranch' :: Bool -> BlockId -> BlockId -> BlockId -> CmmExpr
                -> NatM InstrBlock
 
 -- 64-bit integer comparisons on 32-bit
+-- See Note [64-bit integer comparisons on 32-bit]
 genCondBranch' is32Bit _bid true false (CmmMachOp mop [e1,e2])
   | is32Bit, Just W64 <- maybeIntComparison mop = do
-  ChildCode64 code1 r1_lo <- iselExpr64 e1
-  ChildCode64 code2 r2_lo <- iselExpr64 e2
-  let r1_hi = getHiVRegFromLo r1_lo
-      r2_hi = getHiVRegFromLo r2_lo
-      cond = machOpToCond mop
-      Just cond' = maybeFlipCond cond
-  --TODO: Update CFG for x86
-  let code = code1 `appOL` code2 `appOL` toOL [
-        CMP II32 (OpReg r2_hi) (OpReg r1_hi),
-        JXX cond true,
-        JXX cond' false,
-        CMP II32 (OpReg r2_lo) (OpReg r1_lo),
-        JXX cond true] `appOL` genBranch false
-  return code
+
+  -- The resulting registers here are both the lower part of
+  -- the register as well as a way to get at the higher part.
+  ChildCode64 code1 r1 <- iselExpr64 e1
+  ChildCode64 code2 r2 <- iselExpr64 e2
+  let cond = machOpToCond mop :: Cond
+
+  let cmpCode = intComparison cond true false r1 r2
+  return $ code1 `appOL` code2 `appOL` cmpCode
+
+  where
+    intComparison :: Cond -> BlockId -> BlockId -> Reg -> Reg -> InstrBlock
+    intComparison cond true false r1_lo r2_lo =
+      case cond of
+        -- Impossible results of machOpToCond
+        ALWAYS  -> panic "impossible"
+        NEG     -> panic "impossible"
+        POS     -> panic "impossible"
+        CARRY   -> panic "impossible"
+        OFLO    -> panic "impossible"
+        PARITY  -> panic "impossible"
+        NOTPARITY -> panic "impossible"
+        -- Special case #1 x == y and x != y
+        EQQ -> cmpExact
+        NE  -> cmpExact
+        -- [x >= y]
+        GE  -> cmpGE
+        GEU -> cmpGE
+        -- [x >  y] <==> ![y >= x]
+        GTT -> intComparison GE  false true r2_lo r1_lo
+        GU  -> intComparison GEU false true r2_lo r1_lo
+        -- [x <= y] <==> [y >= x]
+        LE  -> intComparison GE  true false r2_lo r1_lo
+        LEU -> intComparison GEU true false r2_lo r1_lo
+        -- [x <  y] <==> ![x >= x]
+        LTT -> intComparison GE  false true r1_lo r2_lo
+        LU  -> intComparison GEU false true r1_lo r2_lo
+      where
+        r1_hi = getHiVRegFromLo r1_lo
+        r2_hi = getHiVRegFromLo r2_lo
+        cmpExact :: OrdList Instr
+        cmpExact =
+          toOL
+            [ XOR II32 (OpReg r2_hi) (OpReg r1_hi)
+            , XOR II32 (OpReg r2_lo) (OpReg r1_lo)
+            , OR  II32 (OpReg r1_hi)  (OpReg r1_lo)
+            , JXX cond true
+            , JXX ALWAYS false
+            ]
+        cmpGE = toOL
+            [ CMP II32 (OpReg r2_lo) (OpReg r1_lo)
+            , SBB II32 (OpReg r2_hi) (OpReg r1_hi)
+            , JXX cond true
+            , JXX ALWAYS false ]
 
 genCondBranch' _ bid id false bool = do
   CondCode is_float cond cond_code <- getCondCode bool
@@ -2614,9 +2687,12 @@ genCCall' _ is32Bit target dest_regs args bid = do
                return code
         _ -> panic "genCCall: Wrong number of arguments/results for mul2"
 
-    _ -> if is32Bit
-         then genCCall32' dflags target dest_regs args
-         else genCCall64' dflags target dest_regs args
+    _ -> do
+        (instrs0, args') <- evalArgs bid args
+        instrs1 <- if is32Bit
+          then genCCall32' dflags target dest_regs args'
+          else genCCall64' dflags target dest_regs args'
+        return (instrs0 `appOL` instrs1)
 
   where divOp1 platform signed width results [arg_x, arg_y]
             = divOp platform signed width results Nothing arg_x arg_y
@@ -2679,6 +2755,83 @@ genCCall' _ is32Bit target dest_regs args bid = do
         addSubIntC _ _ _ _ _ _ _ _
             = panic "genCCall: Wrong number of arguments/results for addSubIntC"
 
+{-
+Note [Evaluate C-call arguments before placing in destination registers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When producing code for C calls we must take care when placing arguments
+in their final registers. Specifically, we must ensure that temporary register
+usage due to evaluation of one argument does not clobber a register in which we
+already placed a previous argument (e.g. as the code generation logic for
+MO_Shl can clobber %rcx due to x86 instruction limitations).
+
+This is precisely what happened in #18527. Consider this C--:
+
+    (result::I64) = call "ccall" doSomething(_s2hp::I64, 2244, _s2hq::I64, _s2hw::I64 | (1 << _s2hz::I64));
+
+Here we are calling the C function `doSomething` with three arguments, the last
+involving a non-trivial expression involving MO_Shl. In this case the NCG could
+naively generate the following assembly (where $tmp denotes some temporary
+register and $argN denotes the register for argument N, as dictated by the
+platform's calling convention):
+
+    mov _s2hp, $arg1   # place first argument
+    mov _s2hq, $arg2   # place second argument
+
+    # Compute 1 << _s2hz
+    mov _s2hz, %rcx
+    shl %cl, $tmp
+
+    # Compute (_s2hw | (1 << _s2hz))
+    mov _s2hw, $arg3
+    or $tmp, $arg3
+
+    # Perform the call
+    call func
+
+This code is outright broken on Windows which assigns $arg1 to %rcx. This means
+that the evaluation of the last argument clobbers the first argument.
+
+To avoid this we use a rather awful hack: when producing code for a C call with
+at least one non-trivial argument, we first evaluate all of the arguments into
+local registers before moving them into their final calling-convention-defined
+homes.  This is performed by 'evalArgs'. Here we define "non-trivial" to be an
+expression which might contain a MachOp since these are the only cases which
+might clobber registers. Furthermore, we use a conservative approximation of
+this condition (only looking at the top-level of CmmExprs) to avoid spending
+too much effort trying to decide whether we want to take the fast path.
+
+Note that this hack *also* applies to calls to out-of-line PrimTargets (which
+are lowered via a C call) since outOfLineCmmOp produces the call via
+(stmtToInstrs (CmmUnsafeForeignCall ...)), which will ultimately end up
+back in genCCall{32,64}.
+-}
+
+-- | See Note [Evaluate C-call arguments before placing in destination registers]
+evalArgs :: BlockId -> [CmmActual] -> NatM (InstrBlock, [CmmActual])
+evalArgs bid actuals
+  | any mightContainMachOp actuals = do
+      regs_blks <- mapM evalArg actuals
+      return (concatOL $ map fst regs_blks, map snd regs_blks)
+  | otherwise = return (nilOL, actuals)
+  where
+    mightContainMachOp (CmmReg _)      = False
+    mightContainMachOp (CmmRegOff _ _) = False
+    mightContainMachOp (CmmLit _)      = False
+    mightContainMachOp _               = True
+
+    evalArg :: CmmActual -> NatM (InstrBlock, CmmExpr)
+    evalArg actual = do
+        dflags <- getDynFlags
+        lreg <- newLocalReg $ cmmExprType dflags actual
+        (instrs, bid1) <- stmtToInstrs bid $ CmmAssign (CmmLocal lreg) actual
+        -- The above assignment shouldn't change the current block
+        MASSERT(isNothing bid1)
+        return (instrs, CmmReg $ CmmLocal lreg)
+
+    newLocalReg :: CmmType -> NatM LocalReg
+    newLocalReg ty = LocalReg <$> getUniqueM <*> pure ty
+
 -- Note [DIV/IDIV for bytes]
 --
 -- IDIV reminder:

compiler/nativeGen/X86/Cond.hs

@@ -13,22 +13,22 @@ import GhcPrelude
 
 data Cond
         = ALWAYS        -- What's really used? ToDo
-        | EQQ
-        | GE
-        | GEU
-        | GTT
-        | GU
-        | LE
-        | LEU
-        | LTT
-        | LU
-        | NE
-        | NEG
-        | POS
-        | CARRY
-        | OFLO
-        | PARITY
-        | NOTPARITY
+        | EQQ           -- je/jz -> zf = 1
+        | GE            -- jge
+        | GEU           -- ae
+        | GTT           -- jg
+        | GU            -- ja
+        | LE            -- jle
+        | LEU           -- jbe
+        | LTT           -- jl
+        | LU            -- jb
+        | NE            -- jne
+        | NEG           -- js
+        | POS           -- jns
+        | CARRY         -- jc
+        | OFLO          -- jo
+        | PARITY        -- jp
+        | NOTPARITY     -- jnp
         deriving Eq
 
 condUnsigned :: Cond -> Bool

compiler/nativeGen/X86/Instr.hs

@@ -819,13 +819,14 @@ x86_mkJumpInstr id
 --   In essense each allocation larger than a page size needs to be chunked and
 --   a probe emitted after each page allocation.  You have to hit the guard
 --   page so the kernel can map in the next page, otherwise you'll segfault.
+--   See Note [Windows stack allocations].
 --
 needs_probe_call :: Platform -> Int -> Bool
 needs_probe_call platform amount
   = case platformOS platform of
      OSMinGW32 -> case platformArch platform of
                     ArchX86    -> amount > (4 * 1024)
-                    ArchX86_64 -> amount > (8 * 1024)
+                    ArchX86_64 -> amount > (4 * 1024)
                     _          -> False
      _         -> False
 
@@ -849,7 +850,7 @@ x86_mkStackAllocInstr platform amount
         --
         -- We emit a call because the stack probes are quite involved and
         -- would bloat code size a lot.  GHC doesn't really have an -Os.
-        -- __chkstk is guaranteed to leave all nonvolatile registers and AX
+        -- ___chkstk is guaranteed to leave all nonvolatile registers and AX
         -- untouched.  It's part of the standard prologue code for any Windows
         -- function dropping the stack more than a page.
         -- See Note [Windows stack layout]

compiler/parser/Parser.y

@@ -42,6 +42,7 @@ import Data.Char
 import Data.Maybe       ( maybeToList )
 import Control.Monad    ( mplus )
 import Control.Applicative ((<$))
+import qualified Prelude -- for happy-generated code
 
 -- compiler/hsSyn
 import GHC.Hs
@@ -647,6 +648,8 @@ identifier :: { Located RdrName }
         | qconop                        { $1 }
     | '(' '->' ')'      {% ams (sLL $1 $> $ getRdrName funTyCon)
                                [mop $1,mu AnnRarrow $2,mcp $3] }
+    | '->'              {% ams (sLL $1 $> $ getRdrName funTyCon)
+                               [mu AnnRarrow $1] }
     | '(' '~' ')'       {% ams (sLL $1 $> $ eqTyCon_RDR)
                                [mop $1,mj AnnTilde $2,mcp $3] }
 
@@ -1872,7 +1875,7 @@ unpackedness :: { Located ([AddAnn], SourceText, SrcUnpackedness) }
 
 forall_vis_flag :: { (AddAnn, ForallVisFlag) }
         : '.'  { (mj AnnDot $1,    ForallInvis) }
-        | '->' { (mj AnnRarrow $1, ForallVis)   }
+        | '->' { (mu AnnRarrow $1, ForallVis)   }
 
 -- A ktype/ktypedoc is a ctype/ctypedoc, possibly with a kind annotation
 ktype :: { LHsType GhcPs }

compiler/parser/RdrHsSyn.hs

@@ -2103,7 +2103,7 @@ patSynErr l e explanation =
      ; return (cL l hsHoleExpr) }
 
 hsHoleExpr :: HsExpr (GhcPass id)
-hsHoleExpr = HsUnboundVar noExtField (mkVarOcc "_")
+hsHoleExpr = HsUnboundVar noExtField (TrueExprHole (mkVarOcc "_"))
 
 -- | See Note [Ambiguous syntactic categories] and Note [PatBuilder]
 data PatBuilder p

compiler/prelude/PrelInfo.hs

@@ -58,6 +58,7 @@ import PrelRules
 import Avail
 import PrimOp
 import DataCon
+import BasicTypes
 import Id
 import Name
 import NameEnv
@@ -121,14 +122,17 @@ knownKeyNames
   = all_names
   where
     all_names =
+      -- We exclude most tuples from this list—see
+      -- Note [Infinite families of known-key names] in GHC.Builtin.Names.
+      -- We make an exception for Unit (i.e., the boxed 1-tuple), since it does
+      -- not use special syntax like other tuples.
+      -- See Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys)
+      -- in GHC.Builtin.Types.
+      tupleTyConName BoxedTuple 1 : tupleDataConName Boxed 1 :
       concat [ wired_tycon_kk_names funTyCon
              , concatMap wired_tycon_kk_names primTyCons
-
              , concatMap wired_tycon_kk_names wiredInTyCons
-               -- Does not include tuples
-
              , concatMap wired_tycon_kk_names typeNatTyCons
-
              , map idName wiredInIds
              , map (idName . primOpId) allThePrimOps
              , map (idName . primOpWrapperId) allThePrimOps

compiler/prelude/PrelNames.hs

@@ -111,6 +111,10 @@ by the user. For those things that *can* appear in source programs,
 
      See also Note [Built-in syntax and the OrigNameCache]
 
+Note that one-tuples are an exception to the rule, as they do get assigned
+known keys. See
+Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys)
+in GHC.Builtin.Types.
 
 Note [The integer library]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -420,10 +424,6 @@ basicKnownKeyNames
         -- Annotation type checking
         toAnnotationWrapperName
 
-        -- The Ordering type
-        , orderingTyConName
-        , ordLTDataConName, ordEQDataConName, ordGTDataConName
-
         -- The SPEC type for SpecConstr
         , specTyConName
 
@@ -501,7 +501,7 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
     gHC_CLASSES, gHC_PRIMOPWRAPPERS, gHC_BASE, gHC_ENUM,
     gHC_GHCI, gHC_GHCI_HELPERS, gHC_CSTRING,
     gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE, gHC_INTEGER_TYPE, gHC_NATURAL,
-    gHC_LIST, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING,
+    gHC_LIST, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_LIST, dATA_STRING,
     dATA_FOLDABLE, dATA_TRAVERSABLE,
     gHC_CONC, gHC_IO, gHC_IO_Exception,
     gHC_ST, gHC_IX, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,
@@ -533,6 +533,7 @@ gHC_LIST        = mkBaseModule (fsLit "GHC.List")
 gHC_TUPLE       = mkPrimModule (fsLit "GHC.Tuple")
 dATA_TUPLE      = mkBaseModule (fsLit "Data.Tuple")
 dATA_EITHER     = mkBaseModule (fsLit "Data.Either")
+dATA_LIST       = mkBaseModule (fsLit "Data.List")
 dATA_STRING     = mkBaseModule (fsLit "Data.String")
 dATA_FOLDABLE   = mkBaseModule (fsLit "Data.Foldable")
 dATA_TRAVERSABLE= mkBaseModule (fsLit "Data.Traversable")

compiler/prelude/TysWiredIn.hs

@@ -69,7 +69,7 @@ module TysWiredIn (
 
         -- * Tuples
         mkTupleTy, mkTupleTy1, mkBoxedTupleTy, mkTupleStr,
-        tupleTyCon, tupleDataCon, tupleTyConName,
+        tupleTyCon, tupleDataCon, tupleTyConName, tupleDataConName,
         promotedTupleDataCon,
         unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey,
         pairTyCon,
@@ -202,8 +202,11 @@ names in PrelNames, so they use wTcQual, wDataQual, etc
 -- that occurs in this list that name will be assigned the wired-in key we
 -- define here.
 --
--- Because of their infinite nature, this list excludes tuples, Any and implicit
--- parameter TyCons (see Note [Built-in syntax and the OrigNameCache]).
+-- Because of their infinite nature, this list excludes
+--   * tuples, including boxed, unboxed and constraint tuples
+---       (mkTupleTyCon, unitTyCon, pairTyCon)
+--   * unboxed sums (sumTyCon)
+-- See Note [Infinite families of known-key names] in GHC.Builtin.Names
 --
 -- See also Note [Known-key names]
 wiredInTyCons :: [TyCon]
@@ -224,6 +227,7 @@ wiredInTyCons = [ -- Units are not treated like other tuples, because they
                 , wordTyCon
                 , word8TyCon
                 , listTyCon
+                , orderingTyCon
                 , maybeTyCon
                 , heqTyCon
                 , eqTyCon
@@ -696,18 +700,45 @@ for one-tuples.  So in ghc-prim:GHC.Tuple we see the declarations:
   data Unit a = Unit a
   data (a,b)  = (a,b)
 
-There is no way to write a boxed one-tuple in Haskell, but it can be
-created in Template Haskell or in, e.g., `deriving` code. There is
-nothing special about one-tuples in Core; in particular, they have no
+There is no way to write a boxed one-tuple in Haskell using tuple syntax.
+They can, however, be written using other methods:
+
+1. They can be written directly by importing them from GHC.Tuple.
+2. They can be generated by way of Template Haskell or in `deriving` code.
+
+There is nothing special about one-tuples in Core; in particular, they have no
 custom pretty-printing, just using `Unit`.
 
-NB (Feb 16): for /constraint/ one-tuples I have 'Unit%' but no class
-decl in GHC.Classes, so I think this part may not work properly. But
-it's unused I think.
+Note that there is *not* a unary constraint tuple, unlike for other forms of
+tuples. See [Ignore unary constraint tuples] in TcHsType for more
+details.
 
 See also Note [Flattening one-tuples] in MkCore and
 Note [Don't flatten tuples from HsSyn] in MkCore.
 
+-----
+-- Wrinkle: Make boxed one-tuple names have known keys
+-----
+
+We make boxed one-tuple names have known keys so that `data Unit a = Unit a`,
+defined in GHC.Tuple, will be used when one-tuples are spliced in through
+Template Haskell. This program (from #18097) crucially relies on this:
+
+  case $( tupE [ [| "ok" |] ] ) of Unit x -> putStrLn x
+
+Unless Unit has a known key, the type of `$( tupE [ [| "ok" |] ] )` (an
+ExplicitTuple of length 1) will not match the type of Unit (an ordinary
+data constructor used in a pattern). Making Unit known-key allows GHC to make
+this connection.
+
+Unlike Unit, every other tuple is /not/ known-key
+(see Note [Infinite families of known-key names] in GHC.Builtin.Names). The
+main reason for this exception is that other tuples are written with special
+syntax, and as a result, they are renamed using a special `isBuiltInOcc_maybe`
+function (see Note [Built-in syntax and the OrigNameCache] in GHC.Types.Name.Cache).
+In contrast, Unit is just an ordinary data type with no special syntax, so it
+doesn't really make sense to handle it in `isBuiltInOcc_maybe`. Making Unit
+known-key is the next-best way to teach the internals of the compiler about it.
 -}
 
 -- | Built-in syntax isn't "in scope" so these OccNames map to wired-in Names
@@ -731,6 +762,8 @@ isBuiltInOcc_maybe occ =
       "->"   -> Just funTyConName
 
       -- boxed tuple data/tycon
+      -- We deliberately exclude Unit (the boxed 1-tuple).
+      -- See Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys)
       "()"    -> Just $ tup_name Boxed 0
       _ | Just rest <- "(" `BS.stripPrefix` name
         , (commas, rest') <- BS.span (==',') rest
@@ -860,6 +893,9 @@ tupleDataCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i)    -- Build one
 tupleDataCon Boxed   i = snd (boxedTupleArr   ! i)
 tupleDataCon Unboxed i = snd (unboxedTupleArr ! i)
 
+tupleDataConName :: Boxity -> Arity -> Name
+tupleDataConName sort i = dataConName (tupleDataCon sort i)
+
 boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon)
 boxedTupleArr   = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed   i | i <- [0..mAX_TUPLE_SIZE]]
 unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]]

compiler/rename/RnEnv.hs

@@ -1056,6 +1056,9 @@ lookupInfoOccRn :: RdrName -> RnM [Name]
 -- It finds all the GREs that RdrName could mean, not complaining
 -- about ambiguity, but rather returning them all
 -- C.f. #9881
+-- lookupInfoOccRn is also used in situations where we check for
+-- at least one definition of the RdrName, not complaining about
+-- multiple definitions. (See #17832)
 lookupInfoOccRn rdr_name =
   lookupExactOrOrig rdr_name (:[]) $
     do { rdr_env <- getGlobalRdrEnv
@@ -1475,9 +1478,16 @@ lookupBindGroupOcc ctxt what rdr_name
     lookup_top keep_me
       = do { env <- getGlobalRdrEnv
            ; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)
-           ; let candidates_msg = candidates $ map gre_name
-                                             $ filter isLocalGRE
-                                             $ globalRdrEnvElts env
+                 names_in_scope = -- If rdr_name lacks a binding, only
+                                  -- recommend alternatives from related
+                                  -- namespaces. See #17593.
+                                  filter (\n -> nameSpacesRelated
+                                                  (rdrNameSpace rdr_name)
+                                                  (nameNameSpace n))
+                                $ map gre_name
+                                $ filter isLocalGRE
+                                $ globalRdrEnvElts env
+                 candidates_msg = candidates names_in_scope
            ; case filter (keep_me . gre_name) all_gres of
                [] | null all_gres -> bale_out_with candidates_msg
                   | otherwise     -> bale_out_with local_msg