.gitlab-ci.yml

@@ -654,8 +654,6 @@ nightly-i386-windows-hadrian:
 .build-windows-make:
   extends: .build-windows
   stage: full-build
-  # due to #16084
-  allow_failure: true
   variables:
     BUILD_FLAVOUR: "quick"
     GHC_VERSION: "8.6.5"

compiler/basicTypes/MkId.hs

@@ -298,6 +298,24 @@ so the data constructor for T:C had a single argument, namely the
 predicate (C a).  But now we treat that as an ordinary argument, not
 part of the theta-type, so all is well.
 
+Note [Newtype workers]
+~~~~~~~~~~~~~~~~~~~~~~
+A newtype does not really have a worker. Instead, newtype constructors
+just unfold into a cast. But we need *something* for, say, MkAge to refer
+to. So, we do this:
+
+* The Id used as the newtype worker will have a compulsory unfolding to
+  a cast. See Note [Compulsory newtype unfolding]
+
+* This Id is labeled as a DataConWrapId. We don't want to use a DataConWorkId,
+  as those have special treatment in the back end.
+
+* There is no top-level binding, because the compulsory unfolding
+  means that it will be inlined (to a cast) at every call site.
+
+We probably should have a NewtypeWorkId, but these Ids disappear as soon as
+we desugar anyway, so it seems a step too far.
+
 Note [Compulsory newtype unfolding]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Newtype wrappers, just like workers, have compulsory unfoldings.
@@ -447,6 +465,8 @@ mkDataConWorkId :: Name -> DataCon -> Id
 mkDataConWorkId wkr_name data_con
   | isNewTyCon tycon
   = mkGlobalId (DataConWrapId data_con) wkr_name wkr_ty nt_work_info
+      -- See Note [Newtype workers]
+
   | otherwise
   = mkGlobalId (DataConWorkId data_con) wkr_name wkr_ty alg_wkr_info
 

compiler/hsSyn/HsDecls.hs

@@ -302,6 +302,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsGroup p) where
              if isEmptyValBinds val_decls
                 then Nothing
                 else Just (ppr val_decls),
+             ppr_ds (tyClGroupRoleDecls tycl_decls),
              ppr_ds (tyClGroupTyClDecls tycl_decls),
              ppr_ds (tyClGroupInstDecls tycl_decls),
              ppr_ds deriv_decls,

hadrian/src/Rules/Compile.hs

@@ -4,7 +4,7 @@ import Hadrian.BuildPath
 import Hadrian.Oracles.TextFile
 
 import Base
-import Context
+import Context as C
 import Expression
 import Rules.Generate
 import Settings
@@ -30,16 +30,29 @@ compilePackage rs = do
     --
     -- and parse the information we need (stage, package path, ...) from
     -- the path and figure out the suitable way to produce that object file.
-    objectFilesUnder root |%> \path -> do
-        obj <- parsePath (parseBuildObject root) "<object file path parser>" path
-        compileObject rs path obj
+    alternatives $ do
+      -- Language is identified by subdirectory under /build.
+      -- These are non-haskell files so only have a .o or .<way>_o suffix.
+      [ root -/- "**/build/c/**/*." ++ wayPat ++ "o"
+        | wayPat <- wayPats] |%> compileNonHsObject rs C
+
+      [ root -/- "**/build/cmm/**/*." ++ wayPat ++ "o"
+        | wayPat <- wayPats] |%> compileNonHsObject rs Cmm
+
+      [ root -/- "**/build/s/**/*." ++ wayPat ++ "o"
+        | wayPat <- wayPats] |%> compileNonHsObject rs Asm
+
+      -- All else is haskell.
+      -- This comes last as it overlaps with the above rules' file patterns.
+      forM_ ((,) <$> hsExts <*> wayPats) $ \ ((oExt, hiExt), wayPat) ->
+        [ root -/- "**/build/**/*." ++ wayPat ++ oExt
+        , root -/- "**/build/**/*." ++ wayPat ++ hiExt ]
+          &%> \ [o, _hi] -> compileHsObjectAndHi rs o
   where
-    objectFilesUnder r = [ r -/- ("**/build/**/*" ++ pat)
-                         | pat <- extensionPats ]
-
-    exts = [ "o", "hi", "o-boot", "hi-boot" ]
-    patternsFor e = [ "." ++ e, ".*_" ++ e ]
-    extensionPats = concatMap patternsFor exts
+    hsExts = [ ("o", "hi")
+             , ("o-boot", "hi-boot")
+             ]
+    wayPats = [ "", "*_" ]
 
 -- * Object file paths types and parsers
 
@@ -153,67 +166,47 @@ objectContext (BuildPath _ stage pkgPath obj) =
 
 -- * Building an object
 
-compileHsObject
-    :: [(Resource, Int)] -> FilePath -> BuildPath Object -> HsObject -> Action ()
-compileHsObject rs objpath b@(BuildPath _root stage _path _o) hsobj =
-  case hsobj of
-    HsObject _basename (Extension way Hi    ) -> need [objpath -<.> osuf     way]
-    HsObject _basename (Extension way HiBoot) -> need [objpath -<.> obootsuf way]
-    HsObject _basename (Extension way suf) -> do
-        let ctx = objectContext b
-        ctxPath <- contextPath ctx
-        (src, deps) <- lookupDependencies (ctxPath -/- ".dependencies") objpath
-        need (src:deps)
-        needLibrary =<< contextDependencies ctx
-
-        -- The .dependencies files only lists shallow dependencies. ghc will
-        -- generally read more *.hi and *.hi-boot files (deep dependencies).
-        -- Allow such reads (see https://gitlab.haskell.org/ghc/ghc/wikis/Developing-Hadrian#cloud-shared-cache-build)
-        -- Note that this may allow too many *.hi and *.hi-boot files, but
-        -- calculating the exact set of deep dependencies is not feasible.
-        trackAllow [ "//*." ++ hisuf     way
-                   , "//*." ++ hibootsuf way
-                   ]
-
-        buildWithResources rs $ target ctx (Ghc CompileHs stage) [src] [objpath]
-        -- Andrey: It appears that the previous refactoring has broken
-        -- multiple-output build rules. Ideally, we should bring multiple-output
-        -- rules back, see: https://github.com/snowleopard/hadrian/issues/216.
-        -- As a temporary solution, I'm using Shake's new 'produces' feature to
-        -- record that this rule also produces a corresponding interface file.
-        let hi | suf == O     = objpath -<.> hisuf     way
-               | suf == OBoot = objpath -<.> hibootsuf way
-               | otherwise    = error "Internal error: unknown Haskell object extension"
-        produces [hi]
-
-compileNonHsObject
-  :: [(Resource, Int)] -> FilePath -> BuildPath Object -> NonHsObject
-  -> Action ()
-compileNonHsObject rs objpath b@(BuildPath _root stage _path _o) nonhsobj =
-  case nonhsobj of
-    NonHsObject lang _basename _way ->
-      go (builderFor lang) (toSrcFor lang)
-
-  where builderFor C = Ghc CompileCWithGhc
-        builderFor _ = Ghc CompileHs
-
-        toSrcFor Asm = obj2src "S"   (const False)
-        toSrcFor C   = obj2src "c"   (const False)
-        toSrcFor Cmm = obj2src "cmm" isGeneratedCmmFile
-
-        go builder tosrc = do
-            let ctx = objectContext b
-            src <- tosrc ctx objpath
-            need [src]
-            needDependencies ctx src (objpath <.> "d")
-            buildWithResources rs $ target ctx (builder stage) [src] [objpath]
-
-compileObject
-  :: [(Resource, Int)] -> FilePath -> BuildPath Object -> Action ()
-compileObject rs objpath b@(BuildPath _root _stage _path (Hs o)) =
-  compileHsObject rs objpath b o
-compileObject rs objpath b@(BuildPath _root _stage _path (NonHs o)) =
-  compileNonHsObject rs objpath b o
+compileHsObjectAndHi
+    :: [(Resource, Int)] -> FilePath -> Action ()
+compileHsObjectAndHi rs objpath = do
+  root <- buildRoot
+  b@(BuildPath _root stage _path _o)
+    <- parsePath (parseBuildObject root) "<object file path parser>" objpath
+  let ctx = objectContext b
+      way = C.way ctx
+  ctxPath <- contextPath ctx
+  (src, deps) <- lookupDependencies (ctxPath -/- ".dependencies") objpath
+  need (src:deps)
+  needLibrary =<< contextDependencies ctx
+
+  -- The .dependencies file lists indicating inputs. ghc will
+  -- generally read more *.hi and *.hi-boot files (direct inputs).
+  -- Allow such reads (see https://gitlab.haskell.org/ghc/ghc/wikis/Developing-Hadrian#haskell-object-files-and-hi-inputs)
+  -- Note that this may allow too many *.hi and *.hi-boot files, but
+  -- calculating the exact set of direct inputs is not feasible.
+  trackAllow [ "//*." ++ hisuf     way
+             , "//*." ++ hibootsuf way
+             ]
+
+  buildWithResources rs $ target ctx (Ghc CompileHs stage) [src] [objpath]
+
+compileNonHsObject :: [(Resource, Int)] -> SourceLang -> FilePath -> Action ()
+compileNonHsObject rs lang path = do
+  root <- buildRoot
+  b@(BuildPath _root stage _path _o)
+    <- parsePath (parseBuildObject root) "<object file path parser>" path
+  let
+    ctx = objectContext b
+    builder = case lang of
+      C -> Ghc CompileCWithGhc
+      _ -> Ghc CompileHs
+  src <- case lang of
+      Asm -> obj2src "S"   (const False)      ctx path
+      C   -> obj2src "c"   (const False)      ctx path
+      Cmm -> obj2src "cmm" isGeneratedCmmFile ctx path
+  need [src]
+  needDependencies ctx src (path <.> "d")
+  buildWithResources rs $ target ctx (builder stage) [src] [path]
 
 -- * Helpers
 

libraries/base/tests/all.T

@@ -20,7 +20,7 @@ test('tempfiles', normal, compile_and_run, [''])
 test('fixed', normal, compile_and_run, [''])
 test('quotOverflow', normal, compile_and_run, [''])
 test('assert', exit_code(1), compile_and_run, ['-fno-ignore-asserts'])
-test('CPUTime001', normal, compile_and_run, [''])
+test('CPUTime001', fragile(16224), compile_and_run, [''])
 test('readLitChar',   normal, compile_and_run, [''])
 test('unicode001',
      when(platform('i386-unknown-openbsd'), expect_fail),

libraries/ghc-boot/GHC/PackageDb.hs

@@ -387,6 +387,8 @@ decodeFromFile :: FilePath -> DbOpenMode mode t -> Get pkgs ->
                   IO (pkgs, DbOpenMode mode PackageDbLock)
 decodeFromFile file mode decoder = case mode of
   DbOpenReadOnly -> do
+  -- Note [Locking package database on Windows]
+  -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   -- When we open the package db in read only mode, there is no need to acquire
   -- shared lock on non-Windows platform because we update the database with an
   -- atomic rename, so readers will always see the database in a consistent

libraries/ghc-heap/tests/ClosureSizeUtils.hs

+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | Utilities for the @closure_size@ tests
+module ClosureSizeUtils (assertSize, assertSizeUnlifted) where
+
+import Control.Monad
+import GHC.Exts
+import GHC.Exts.Heap.Closures
+import GHC.Stack
+import Type.Reflection
+
+profHeaderSize :: Int
+#if PROFILING
+profHeaderSize = 2
+#else
+profHeaderSize = 0
+#endif
+
+assertSize
+  :: forall a. (HasCallStack, Typeable a)
+  => a     -- ^ closure
+  -> Int   -- ^ expected size in words
+  -> IO ()
+assertSize x =
+  assertSizeBox (asBox x) (typeRep @a)
+
+assertSizeUnlifted
+  :: forall (a :: TYPE 'UnliftedRep). (HasCallStack, Typeable a)
+  => a     -- ^ closure
+  -> Int   -- ^ expected size in words
+  -> IO ()
+assertSizeUnlifted x =
+  assertSizeBox (Box (unsafeCoerce# x)) (typeRep @a)
+
+assertSizeBox
+  :: forall a. (HasCallStack)
+  => Box   -- ^ closure
+  -> TypeRep a
+  -> Int   -- ^ expected size in words
+  -> IO ()
+assertSizeBox x ty expected = do
+  let !size = closureSize x
+  when (size /= expected') $ do
+    putStrLn $ "closureSize ("++show ty++") == "++show size++", expected "++show expected'
+    putStrLn $ prettyCallStack callStack
+  where expected' = expected + profHeaderSize
+{-# NOINLINE assertSize #-}

libraries/ghc-heap/tests/all.T

 test('heap_all',
-     [when(have_profiling(),
-      extra_ways(['prof'])),
+     [when(have_profiling(), extra_ways(['prof'])),
       # These ways produce slightly different heap representations.
       # Currently we don't test them.
       omit_ways(['ghci', 'hpc'])
      ],
      compile_and_run, [''])
+
+# Test everything except FUNs and PAPs in all ways.
 test('closure_size',
-     omit_ways(['ghci', 'hpc', 'prof']),
+     [extra_files(['ClosureSizeUtils.hs']),
+      when(have_profiling(), extra_ways(['prof'])),
+      # These ways produce slightly different heap representations.
+      # Currently we don't test them.
+      omit_ways(['hpc'])
+     ],
+     compile_and_run, [''])
+
+# Test PAPs and FUNs only in normal way (e.g. with -O0)
+# since otherwise the simplifier interferes.
+test('closure_size_noopt',
+     [extra_files(['ClosureSizeUtils.hs']),
+      only_ways(['normal'])
+     ],
      compile_and_run, [''])
+

libraries/ghc-heap/tests/closure_size.hs

-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE TypeInType #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
-import Control.Monad
-import Type.Reflection
-import GHC.Stack
+import GHC.Exts
+import GHC.IO
+import ClosureSizeUtils
 
-import GHC.Exts.Heap.Closures
+data A = A (Array# Int)
+data MA = MA (MutableArray# RealWorld Int)
+data BA = BA ByteArray#
+data MBA = MBA (MutableByteArray# RealWorld)
+data B = B BCO#
+data APC a = APC a
 
-assertSize :: forall a. (HasCallStack, Typeable a)
-           => a -> Int -> IO ()
-assertSize !x expected = do
-  let !size = closureSize (asBox x)
-  when (size /= expected) $ do
-    putStrLn $ "closureSize ("++show (typeRep @a)++") == "++show size++", expected "++show expected
-    putStrLn $ prettyCallStack callStack
-{-# NOINLINE assertSize #-}
-
-pap :: Int -> Char -> Int
-pap x _ = x
-{-# NOINLINE pap #-}
 
 main :: IO ()
 main = do
@@ -28,7 +23,26 @@ main = do
   assertSize (Nothing :: Maybe ()) 2
   assertSize ((1,2) :: (Int,Int)) 3
   assertSize ((1,2,3) :: (Int,Int,Int)) 4
-  assertSize (id :: Int -> Int) 1
-  assertSize (fst :: (Int,Int) -> Int) 1
-  assertSize (pap 1) 2
 
+  MA ma <- IO $ \s ->
+      case newArray# 0# 0 s of
+          (# s1, x #) -> (# s1, MA x #)
+
+  A a <- IO $ \s ->
+      case freezeArray# ma 0# 0# s of
+          (# s1, x #) -> (# s1, A x #)
+
+  MBA mba <- IO $ \s ->
+      case newByteArray# 0# s of
+          (# s1, x #) -> (# s1, MBA x #)
+
+  BA ba <- IO $ \s ->
+      case newByteArray# 0# s of
+          (# s1, x #) ->
+              case unsafeFreezeByteArray# x s1 of
+                  (# s2, y #) -> (# s2, BA y #)
+
+  assertSizeUnlifted ma 3
+  assertSizeUnlifted a 3
+  assertSizeUnlifted mba 2
+  assertSizeUnlifted ba 2

libraries/ghc-heap/tests/closure_size_noopt.hs

+import ClosureSizeUtils
+
+pap :: Int -> Char -> Int
+pap x _ = x
+{-# NOINLINE pap #-}
+
+main :: IO ()
+main = do
+  assertSize (id :: Int -> Int) 1
+  assertSize (fst :: (Int,Int) -> Int) 1
+  assertSize (pap 1) 2
+

testsuite/tests/driver/dynamicToo/dynamicToo006/all.T

-test('dynamicToo006', [normalise_slashes, extra_files(['Main.hs'])],
+test('dynamicToo006',
+     [normalise_slashes, extra_files(['Main.hs']), unless(have_dynamic(), skip)],
      run_command, ['$MAKE -s main --no-print-director'])

testsuite/tests/ffi/should_run/all.T

@@ -169,7 +169,9 @@ test('ffi_parsing_001', [omit_ways(['ghci'])], compile_and_run,
 
 test('capi_value', [omit_ways(['ghci'])], compile_and_run, ['capi_value_c.c'])
 
-test('T7170', exit_code(1), compile_and_run, [''])
+test('T7170',
+     [when(opsys('mingw32'), expect_broken(16801)],
+      exit_code(1)], compile_and_run, [''])
 
 test('T4012', [expect_broken_for(7388, ['ghci'])], multimod_compile_and_run,
      ['T4012', ''])

testsuite/tests/ghc-api/downsweep/all.T

@@ -9,6 +9,7 @@ test('PartialDownsweep',
 
 test('OldModLocation',
      [ extra_run_opts('"' + config.libdir + '"')
+     , when(opsys('mingw32'), expect_broken(16772))
      ],
      compile_and_run,
      ['-package ghc'])

testsuite/tests/ghci/linking/dyn/all.T

@@ -45,5 +45,11 @@ test('big-obj', [extra_files(['big-obj-c.c', 'big-obj.hs']),
                     unless(doing_ghci, skip), unless(opsys('mingw32'), skip)],
      makefile_test, ['big-obj'])
 
-test('T3372', [unless(doing_ghci, skip), extra_run_opts('"' + config.libdir + '"')],
+test('T3372',
+     [unless(doing_ghci, skip),
+      extra_run_opts('"' + config.libdir + '"'),
+      # Concurrent GHC sessions is fragile on Windows since we must lock the
+      # package database even for read-only access.
+      # See Note [Locking package database on Windows] in GHC.PackageDb
+      when(opsys('mingw32'), fragile(16773))],
      compile_and_run, ['-package ghc'])

testsuite/tests/roles/should_compile/T16718.hs

+{-# LANGUAGE RoleAnnotations, TemplateHaskell #-}
+
+module T16718 where
+
+$([d| type role P phantom
+      data P a
+    |])

testsuite/tests/roles/should_compile/T16718.stderr

+T16718.hs:(5,3)-(7,6): Splicing declarations
+    [d| type role P phantom
+        
+        data P a |]
+  ======>
+    type role P phantom
+    data P a

testsuite/tests/roles/should_compile/all.T

@@ -10,3 +10,4 @@ test('T8958', [normalise_fun(normalise_errmsg), only_ways('normal')], compile, [
 test('T10263', normal, compile, [''])
 test('T9204b', [], multimod_compile, ['T9204b', '-v0'])
 test('T14101', normal, compile, [''])
+test('T16718', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])

testsuite/tests/safeHaskell/safeInfered/UnsafeInfered02.stderr-mingw32

+[1 of 2] Compiling UnsafeInfered02_A ( UnsafeInfered02_A.hs, UnsafeInfered02_A.o )
+[2 of 2] Compiling UnsafeInfered02  ( UnsafeInfered02.hs, UnsafeInfered02.o )
+
+UnsafeInfered02.hs:4:1: error:
+    UnsafeInfered02_A: Can't be safely imported!
+    The module itself isn't safe.
+

testsuite/tests/simplCore/should_compile/all.T

@@ -144,6 +144,7 @@ test('T7702',
       # a large effect on allocation which is hard to separate from the
       # allocation done by the plugin... but a regression allocates > 90mb
       collect_compiler_stats('peak_megabytes_allocated',70),
+      when(opsys('mingw'), expect_broken_for(16799, ['normal']))
      ],
      compile,
      ['-v0 -package-db T7702plugin/pkg.T7702/local.package.conf -fplugin T7702Plugin -package T7702plugin ' + config.plugin_way_flags])

testsuite/tests/th/T15365.stderr

@@ -4,6 +4,8 @@ T15365.hs:(9,3)-(31,6): Splicing declarations
         pattern (:!!!) :: Bool
         pattern (:!!!) = True
         
+        type role (***)
+        
         type (|||) = Either
         data (***)
         class (???)