compiler/ghci/Linker.hs

@@ -115,7 +115,7 @@ readPLS dl =
 
 modifyMbPLS_
   :: DynLinker -> (Maybe PersistentLinkerState -> IO (Maybe PersistentLinkerState)) -> IO ()
-modifyMbPLS_ dl f = modifyMVar_ (dl_mpls dl) f 
+modifyMbPLS_ dl f = modifyMVar_ (dl_mpls dl) f
 
 emptyPLS :: DynFlags -> PersistentLinkerState
 emptyPLS _ = PersistentLinkerState {
@@ -881,8 +881,8 @@ dynLinkObjs hsc_env pls objs = do
 
 dynLoadObjs :: HscEnv -> PersistentLinkerState -> [FilePath]
             -> IO PersistentLinkerState
-dynLoadObjs _       pls []   = return pls
-dynLoadObjs hsc_env pls objs = do
+dynLoadObjs _       pls                           []   = return pls
+dynLoadObjs hsc_env pls@PersistentLinkerState{..} objs = do
     let dflags = hsc_dflags hsc_env
     let platform = targetPlatform dflags
     let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ]
@@ -899,13 +899,13 @@ dynLoadObjs hsc_env pls objs = do
                       -- library.
                       ldInputs =
                            concatMap (\l -> [ Option ("-l" ++ l) ])
-                                     (nub $ snd <$> temp_sos pls)
+                                     (nub $ snd <$> temp_sos)
                         ++ concatMap (\lp -> [ Option ("-L" ++ lp)
                                                     , Option "-Xlinker"
                                                     , Option "-rpath"
                                                     , Option "-Xlinker"
                                                     , Option lp ])
-                                     (nub $ fst <$> temp_sos pls)
+                                     (nub $ fst <$> temp_sos)
                         ++ concatMap
                              (\lp ->
                                  [ Option ("-L" ++ lp)
@@ -933,13 +933,13 @@ dynLoadObjs hsc_env pls objs = do
     -- link all "loaded packages" so symbols in those can be resolved
     -- Note: We are loading packages with local scope, so to see the
     -- symbols in this link we must link all loaded packages again.
-    linkDynLib dflags2 objs (pkgs_loaded pls)
+    linkDynLib dflags2 objs pkgs_loaded
 
     -- if we got this far, extend the lifetime of the library file
     changeTempFilesLifetime dflags TFL_GhcSession [soFile]
     m <- loadDLL hsc_env soFile
     case m of
-        Nothing -> return pls { temp_sos = (libPath, libName) : temp_sos pls }
+        Nothing -> return $! pls { temp_sos = (libPath, libName) : temp_sos }
         Just err -> panic ("Loading temp shared object failed: " ++ err)
 
 rmDupLinkables :: [Linkable]    -- Already loaded

compiler/prelude/PrelRules.hs

@@ -467,13 +467,16 @@ shiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr
 -- Used for shift primops
 --    ISllOp, ISraOp, ISrlOp :: Word# -> Int# -> Word#
 --    SllOp, SrlOp           :: Word# -> Int# -> Word#
--- See Note [Guarding against silly shifts]
 shiftRule shift_op
   = do { dflags <- getDynFlags
        ; [e1, Lit (LitNumber LitNumInt shift_len _)] <- getArgs
        ; case e1 of
            _ | shift_len == 0
              -> return e1
+             -- See Note [Guarding against silly shifts]
+             | shift_len < 0 || shift_len > wordSizeInBits dflags
+             -> return $ mkRuntimeErrorApp rUNTIME_ERROR_ID wordPrimTy
+                           ("Bad shift length " ++ show shift_len)
 
            -- Do the shift at type Integer, but shift length is Int
            Lit (LitNumber nt x t)

compiler/typecheck/TcForeign.hs

@@ -64,7 +64,6 @@ import Hooks
 import qualified GHC.LanguageExtensions as LangExt
 
 import Control.Monad
-import Data.Maybe
 
 -- Defines a binding
 isForeignImport :: LForeignDecl name -> Bool
@@ -251,8 +250,7 @@ tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty
        ; let
            -- Drop the foralls before inspecting the
            -- structure of the foreign type.
-             (bndrs, res_ty)   = tcSplitPiTys norm_sig_ty
-             arg_tys           = mapMaybe binderRelevantType_maybe bndrs
+             (arg_tys, res_ty) = tcSplitFunTys (dropForAlls norm_sig_ty)
              id                = mkLocalId nm sig_ty
                  -- Use a LocalId to obey the invariant that locally-defined
                  -- things are LocalIds.  However, it does not need zonking,
@@ -424,10 +422,9 @@ tcCheckFEType sig_ty (CExport (L l (CExportStatic esrc str cconv)) src) = do
     checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty
     return (CExport (L l (CExportStatic esrc str cconv')) src)
   where
-      -- Drop the foralls before inspecting n
+      -- Drop the foralls before inspecting
       -- the structure of the foreign type.
-    (bndrs, res_ty) = tcSplitPiTys sig_ty
-    arg_tys         = mapMaybe binderRelevantType_maybe bndrs
+    (arg_tys, res_ty) = tcSplitFunTys (dropForAlls sig_ty)
 
 {-
 ************************************************************************
@@ -458,6 +455,11 @@ checkForeignRes non_io_result_ok check_safe pred_res_ty ty
   =     -- Got an IO result type, that's always fine!
      check (pred_res_ty res_ty) (illegalForeignTyErr result)
 
+  -- We disallow nested foralls in foreign types
+  -- (at least, for the time being). See #16702.
+  | tcIsForAllTy ty
+  = addErrTc $ illegalForeignTyErr result (text "Unexpected nested forall")
+
   -- Case for non-IO result type with FFI Import
   | not non_io_result_ok
   = addErrTc $ illegalForeignTyErr result (text "IO result type expected")

docs/users_guide/ffi-chap.rst

@@ -14,9 +14,10 @@ Foreign function interface (FFI)
 
     Allow use of the Haskell foreign function interface.
 
-GHC (mostly) conforms to the Haskell Foreign Function Interface, whose
-definition is part of the Haskell Report on
-`http://www.haskell.org/ <http://www.haskell.org/>`__.
+GHC (mostly) conforms to the Haskell Foreign Function Interface as specified
+in the Haskell Report. Refer to the `relevant chapter
+<https://www.haskell.org/onlinereport/haskell2010/haskellch8.html>_`
+of the Haskell Report for more details.
 
 FFI support is enabled by default, but can be enabled or disabled
 explicitly with the :extension:`ForeignFunctionInterface` flag.
@@ -102,6 +103,25 @@ OK: ::
        foreign import foo :: Int -> MyIO Int
        foreign import "dynamic" baz :: (Int -> MyIO Int) -> CInt -> MyIO Int
 
+.. _ffi-foralls:
+
+Explicit ``forall``s in foreign types
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The type variables in the type of a foreign declaration may be quantified with
+an explicit ``forall`` by using the :extension:`ExplicitForAll` language
+extension, as in the following example: ::
+
+    {-# LANGUAGE ExplicitForAll #-}
+    foreign import ccall "mmap" c_mmap :: forall a. CSize -> IO (Ptr a)
+
+Note that an explicit ``forall`` must appear at the front of the type signature
+and is not permitted to appear nested within the type, as in the following
+(erroneous) examples: ::
+
+    foreign import ccall "mmap" c_mmap' :: CSize -> forall a. IO (Ptr a)
+    foreign import ccall quux :: (forall a. Ptr a) -> IO ()
+
 .. _ffi-prim:
 
 Primitive imports

libraries/base/GHC/Conc/Sync.hs

@@ -113,7 +113,7 @@ import GHC.IORef
 import GHC.MVar
 import GHC.Ptr
 import GHC.Real         ( fromIntegral )
-import GHC.Show         ( Show(..), showString )
+import GHC.Show         ( Show(..), showParen, showString )
 import GHC.Stable       ( StablePtr(..) )
 import GHC.Weak
 
@@ -145,7 +145,7 @@ This misfeature will hopefully be corrected at a later date.
 
 -- | @since 4.2.0.0
 instance Show ThreadId where
-   showsPrec d t =
+   showsPrec d t = showParen (d >= 11) $
         showString "ThreadId " .
         showsPrec d (getThreadId (id2TSO t))
 

rts/sm/CNF.h

@@ -15,9 +15,6 @@
 
 #include "BeginPrivate.h"
 
-void              initCompact  (void);
-void              exitCompact  (void);
-
 StgCompactNFData *compactNew   (Capability      *cap,
                                 StgWord          size);
 void              compactResize(Capability       *cap,

testsuite/tests/codeGen/should_compile/T16449_1.hs

+module T16449_1 where
+
+import Data.Bits (setBit)
+
+f :: Int
+f = foldl setter 0 $ zip [0..] [()]
+  where
+    setter v (ix, _) = setBit v ix

testsuite/tests/codeGen/should_compile/all.T

@@ -59,3 +59,5 @@ test('T15155',
 
 test('T15155l', when(unregisterised(), skip),
      makefile_test, [])
+
+test('T16449_1', normal, compile, [''])

testsuite/tests/codeGen/should_run/T16449_2.hs

+{-# LANGUAGE MagicHash #-}
+
+module Main where
+
+import GHC.Prim
+import GHC.Int
+
+-- Shift should be larger than the word size (e.g. 64 on 64-bit) for this test.
+main = print (I# (uncheckedIShiftL# 1# 1000#))

testsuite/tests/codeGen/should_run/T16449_2.stderr

+T16449_2: Bad shift length 1000

testsuite/tests/codeGen/should_run/all.T

@@ -195,3 +195,4 @@ test('T15892',
         extra_run_opts('+RTS -G1 -A32k -RTS') ],
      compile_and_run, ['-O'])
 test('T16617', normal, compile_and_run, [''])
+test('T16449_2', exit_code(1), compile_and_run, [''])

testsuite/tests/ffi/should_fail/T16702.hs

+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE RankNTypes #-}
+
+module T16702 where
+
+import Foreign.C.Types
+import Foreign.Ptr
+import Data.Kind (Type)
+
+foreign import ccall "math.h pow"
+  c_pow :: CDouble
+        -> forall (a :: Type). CDouble
+        -> forall (b :: Type). CDouble
+
+foreign import ccall "malloc"
+  malloc1 :: CSize -> forall a. IO (Ptr a)
+
+foreign import ccall "malloc"
+  malloc2 :: Show a => CSize -> IO (Ptr a)
+
+foreign import ccall "malloc"
+  malloc3 :: CSize -> Show a => IO (Ptr a)

testsuite/tests/ffi/should_fail/T16702.stderr

+
+T16702.hs:12:1: error:
+    • Unacceptable result type in foreign declaration:
+        Unexpected nested forall
+    • When checking declaration:
+        foreign import ccall safe "math.h pow" c_pow
+          :: CDouble
+             -> forall (a :: Type). CDouble -> forall (b :: Type). CDouble
+
+T16702.hs:17:1: error:
+    • Unacceptable result type in foreign declaration:
+        Unexpected nested forall
+    • When checking declaration:
+        foreign import ccall safe "malloc" malloc1
+          :: CSize -> forall a. IO (Ptr a)
+
+T16702.hs:20:1: error:
+    • Unacceptable argument type in foreign declaration:
+        ‘Show a’ cannot be marshalled in a foreign call
+    • When checking declaration:
+        foreign import ccall safe "malloc" malloc2
+          :: Show a => CSize -> IO (Ptr a)
+
+T16702.hs:23:1: error:
+    • Unacceptable argument type in foreign declaration:
+        ‘Show a’ cannot be marshalled in a foreign call
+    • When checking declaration:
+        foreign import ccall safe "malloc" malloc3
+          :: CSize -> Show a => IO (Ptr a)

testsuite/tests/ffi/should_fail/all.T

@@ -14,6 +14,7 @@ test('T5664', normal, compile_fail, ['-v0'])
 test('T7506', normal, compile_fail, [''])
 test('T7243', normal, compile_fail, [''])
 test('T10461', normal, compile_fail, [''])
+test('T16702', normal, compile_fail, [''])
 
 # UnsafeReenter tests implementation of an undefined behavior (calling Haskell
 # from an unsafe foreign function) and only makes sense in non-threaded way