compiler/GHC/Driver/CodeOutput.hs

@@ -295,7 +295,7 @@ outputForeignStubs logger tmpfs dflags unit_state mod location stubs
 
             -- wrapper code mentions the ffi_arg type, which comes from ffi.h
             ffi_includes
-              | platformMisc_libFFI $ platformMisc dflags = "#include <ffi.h>\n"
+              | platformMisc_libFFI $ platformMisc dflags = "#include \"rts/ghc_ffi.h\"\n"
               | otherwise = ""
 
         stub_h_file_exists

compiler/GHC/Rename/Module.hs

@@ -53,7 +53,7 @@ import GHC.Types.Name.Set
 import GHC.Types.Name.Env
 import GHC.Utils.Outputable
 import GHC.Data.Bag
-import GHC.Types.Basic  ( TypeOrKind(..) )
+import GHC.Types.Basic  ( TypeOrKind(..), TyConFlavour(..), TypeOrData(..) )
 import GHC.Data.FastString
 import GHC.Types.SrcLoc as SrcLoc
 import GHC.Driver.DynFlags
@@ -61,8 +61,9 @@ import GHC.Utils.Misc   ( lengthExceeds, partitionWith )
 import GHC.Utils.Panic
 import GHC.Driver.Env ( HscEnv(..), hsc_home_unit)
 import GHC.Data.List.SetOps ( findDupsEq, removeDupsOn, equivClasses )
-import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..)
-                               , stronglyConnCompFromEdgedVerticesUniq )
+import GHC.Data.Graph.Directed ( SCC, flattenSCC, Node(..)
+                               , stronglyConnCompFromEdgedVerticesUniq
+                               , stronglyConnCompFromEdgedVerticesOrd )
 import GHC.Types.Unique.Set
 import GHC.Data.OrdList
 import qualified GHC.LanguageExtensions as LangExt
@@ -71,9 +72,9 @@ import GHC.Core.DataCon ( isSrcStrict )
 import Control.Monad
 import Control.Arrow ( first )
 import Data.Foldable ( toList )
-import Data.List ( mapAccumL )
-import Data.List.NonEmpty ( NonEmpty(..), head )
-import Data.Maybe ( isNothing, fromMaybe, mapMaybe )
+import Data.List ( sortBy )
+import Data.List.NonEmpty ( NonEmpty(..), head, groupAllWith )
+import Data.Maybe ( isNothing, mapMaybe )
 import qualified Data.Set as Set ( difference, fromList, toList, null )
 import GHC.Types.GREInfo (ConInfo, mkConInfo, conInfoFields)
 
@@ -1423,78 +1424,14 @@ rnTyClDecls tycl_ds
        ; rdr_env <- getGlobalRdrEnv
        ; traceRn "rnTyClDecls SCC analysis" $
            vcat [ text "rdr_env:" <+> ppr rdr_env ]
-       ; let tycl_sccs = depAnalTyClDecls rdr_env kisig_fv_env tycls_w_fvs
-             role_annot_env = mkRoleAnnotEnv role_annots
-             (kisig_env, kisig_fv_env) = mkKindSig_fv_env kisigs_w_fvs
-
-             inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs
-             (init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map
-
-             first_group
-               | null init_inst_ds = []
-               | otherwise = [TyClGroup { group_ext    = noExtField
-                                        , group_tyclds = []
-                                        , group_kisigs = []
-                                        , group_roles  = []
-                                        , group_instds = init_inst_ds }]
-
-             (final_inst_ds, groups)
-                = mapAccumL (mk_group role_annot_env kisig_env) rest_inst_ds tycl_sccs
-
-             all_fvs = foldr (plusFV . snd) emptyFVs tycls_w_fvs  `plusFV`
+       ; let all_fvs = foldr (plusFV . snd) emptyFVs tycls_w_fvs  `plusFV`
                        foldr (plusFV . snd) emptyFVs instds_w_fvs `plusFV`
                        foldr (plusFV . snd) emptyFVs kisigs_w_fvs
 
-             all_groups = first_group ++ groups
-
-       ; massertPpr (null final_inst_ds)
-                    (ppr instds_w_fvs
-                     $$ ppr inst_ds_map
-                     $$ ppr (flattenSCCs tycl_sccs)
-                     $$ ppr final_inst_ds)
+             all_groups = depAnalTyClDecls rdr_env role_annots kisigs_w_fvs tycls_w_fvs instds_w_fvs
 
        ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups)
        ; return (all_groups, all_fvs) }
-  where
-    mk_group :: RoleAnnotEnv
-             -> KindSigEnv
-             -> InstDeclFreeVarsMap
-             -> SCC (LTyClDecl GhcRn)
-             -> (InstDeclFreeVarsMap, TyClGroup GhcRn)
-    mk_group role_env kisig_env inst_map scc
-      = (inst_map', group)
-      where
-        tycl_ds              = flattenSCC scc
-        bndrs                = map (tcdName . unLoc) tycl_ds
-        roles                = getRoleAnnots bndrs role_env
-        kisigs               = getKindSigs   bndrs kisig_env
-        (inst_ds, inst_map') = getInsts      bndrs inst_map
-        group = TyClGroup { group_ext    = noExtField
-                          , group_tyclds = tycl_ds
-                          , group_kisigs = kisigs
-                          , group_roles  = roles
-                          , group_instds = inst_ds }
-
--- | Free variables of standalone kind signatures.
-newtype KindSig_FV_Env = KindSig_FV_Env (NameEnv FreeVars)
-
-lookupKindSig_FV_Env :: KindSig_FV_Env -> Name -> FreeVars
-lookupKindSig_FV_Env (KindSig_FV_Env e) name
-  = fromMaybe emptyFVs (lookupNameEnv e name)
-
--- | Standalone kind signatures.
-type KindSigEnv = NameEnv (LStandaloneKindSig GhcRn)
-
-mkKindSig_fv_env :: [(LStandaloneKindSig GhcRn, FreeVars)] -> (KindSigEnv, KindSig_FV_Env)
-mkKindSig_fv_env kisigs_w_fvs = (kisig_env, kisig_fv_env)
-  where
-    kisig_env = mapNameEnv fst compound_env
-    kisig_fv_env = KindSig_FV_Env (mapNameEnv snd compound_env)
-    compound_env :: NameEnv (LStandaloneKindSig GhcRn, FreeVars)
-      = mkNameEnvWith (standaloneKindSigName . unLoc . fst) kisigs_w_fvs
-
-getKindSigs :: [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn]
-getKindSigs bndrs kisig_env = mapMaybe (lookupNameEnv kisig_env) bndrs
 
 rnStandaloneKindSignatures
   :: NameSet  -- names of types and classes in the current TyClGroup
@@ -1520,27 +1457,6 @@ rnStandaloneKindSignature tc_names (StandaloneKindSig _ v ki)
         ; return (StandaloneKindSig noExtField new_v new_ki, fvs)
         }
 
-depAnalTyClDecls :: GlobalRdrEnv
-                 -> KindSig_FV_Env
-                 -> [(LTyClDecl GhcRn, FreeVars)]
-                 -> [SCC (LTyClDecl GhcRn)]
--- See Note [Dependency analysis of type, class, and instance decls]
-depAnalTyClDecls rdr_env kisig_fv_env ds_w_fvs
-  = stronglyConnCompFromEdgedVerticesUniq edges
-  where
-    edges :: [ Node Name (LTyClDecl GhcRn) ]
-    edges = [ DigraphNode d name (map (getParent rdr_env) (nonDetEltsUniqSet deps))
-            | (d, fvs) <- ds_w_fvs,
-              let { name = tcdName (unLoc d)
-                  ; kisig_fvs = lookupKindSig_FV_Env kisig_fv_env name
-                  ; deps = fvs `plusFV` kisig_fvs
-                  }
-            ]
-            -- It's OK to use nonDetEltsUFM here as
-            -- stronglyConnCompFromEdgedVertices is still deterministic
-            -- even if the edges are in nondeterministic order as explained
-            -- in Note [Deterministic SCC] in GHC.Data.Graph.Directed.
-
 toParents :: GlobalRdrEnv -> NameSet -> NameSet
 toParents rdr_env ns
   = nonDetStrictFoldUniqSet add emptyNameSet ns
@@ -2705,3 +2621,229 @@ add_bind _ (XValBindsLR {})     = panic "GHC.Rename.Module.add_bind"
 add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
 add_sig s (ValBinds x bs sigs) = ValBinds x bs (s:sigs)
 add_sig _ (XValBindsLR {})     = panic "GHC.Rename.Module.add_sig"
+
+
+----------------------------------------------------
+depAnalTyClDecls
+                 :: GlobalRdrEnv
+                 -> [LRoleAnnotDecl GhcRn]
+                 -> [(LStandaloneKindSig GhcRn, FreeVars)]
+                 -> [(LTyClDecl GhcRn, FreeVars)]
+                 -> [(LInstDecl GhcRn, FreeVars)]
+                 -> [TyClGroup GhcRn]
+depAnalTyClDecls rdr_env role_annots kisigs_w_fvs tycls_w_fvs instds_w_fvs =
+  concatMap (nestedDepAnalTyClDecls rdr_env) (stronglyConnCompFromEdgedVerticesOrd nodes)
+  where
+    kisig_fv_env :: NameEnv (LStandaloneKindSig GhcRn, FreeVars)
+    kisig_fv_env = mkNameEnvWith (standaloneKindSigName . unLoc . fst) kisigs_w_fvs
+
+    role_annot_env :: RoleAnnotEnv
+    role_annot_env = mkRoleAnnotEnv role_annots
+
+    insts :: [DepAnalInst]
+    insts = zipWith mk_inst [0..] instds_w_fvs
+      where
+        mk_inst i (inst, fvs) =
+          Inst { inst_index = i
+               , inst_name  = name
+               , inst_inst  = inst
+               , inst_fvs   = fvs }
+          where name = get_inst_name inst
+
+    decls :: [DepAnalDecl]
+    decls = map mk_decl tycls_w_fvs
+      where
+        mk_decl (decl, fvs) =
+          Decl { decl_name  = name
+               , decl_roles = roles
+               , decl_kisig = kisig
+               , decl_decl  = decl
+               , decl_fvs   = fvs `plusFV` kisig_fvs
+               }
+          where name = get_decl_name decl
+                roles = lookupRoleAnnot role_annot_env name
+                (kisig, kisig_fvs) = lookupKiSigFVs kisig_fv_env name
+
+    nodes :: [Node DepAnalKey DepAnalPayload]
+    nodes =
+      map (mk_decl_node get_deps) decls ++
+      map (mk_inst_node get_deps) insts
+
+    get_deps :: FreeVars -> [DepAnalKey]
+    get_deps = concatMap get_dep . mapMaybe (lookupGRE_Name rdr_env) . nonDetEltsUniqSet
+
+    get_dep :: GlobalRdrElt -> [DepAnalKey]
+    get_dep GRE{gre_name = name, gre_info = info, gre_par = par} =
+      case info of
+        IAmTyCon (OpenFamilyFlavour IAmType m_assoc) ->
+          case m_assoc of
+            Nothing -> DeclKey name : instances_of name
+            Just cls -> DeclKey cls : instances_of cls
+        _ ->
+          case par of
+            NoParent -> [DeclKey name]
+            ParentIs p -> [DeclKey p]
+
+    instances_of :: Name -> [DepAnalKey]
+    instances_of name =
+      case lookupNameEnv inst_groups name of
+        Nothing        -> []
+        Just (k :| ks) -> k : ks
+
+    inst_groups :: NameEnv (NonEmpty DepAnalKey)
+    inst_groups = (mkNameEnv . map mk_inst_group . groupAllWith inst_name) insts
+      where
+        mk_inst_group insts = (inst_name (head insts), fmap inst_key insts)
+          where inst_key inst = InstKey (inst_name inst) (inst_index inst)
+
+mk_decl_node :: (FreeVars -> [DepAnalKey]) -> DepAnalDecl -> Node DepAnalKey DepAnalPayload
+mk_decl_node get_deps decl = DigraphNode payload key deps
+  where
+    payload = DeclPayload decl
+    key = DeclKey (decl_name decl)
+    deps = get_deps (decl_fvs decl)
+
+mk_inst_node :: (FreeVars -> [DepAnalKey]) -> DepAnalInst -> Node DepAnalKey DepAnalPayload
+mk_inst_node get_deps inst = DigraphNode payload key deps
+  where
+    payload = InstPayload inst
+    key = InstKey (inst_name inst) (inst_index inst)
+    deps = get_deps (inst_fvs inst)
+
+{- Note [Nested dependency analysis]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The first pass of dependency analysis overapproximates the amount of dependencies,
+producing SCCs that are too big. Now we break them into smaller subgroups.
+
+TODO (int-index): explain why this happens.
+-}
+
+
+-- See [Nested dependency analysis]
+nestedDepAnalTyClDecls :: GlobalRdrEnv -> SCC DepAnalPayload -> [TyClGroup GhcRn]
+nestedDepAnalTyClDecls rdr_env initial_scc = first_groups ++ groups
+  where
+    decl_sccs :: [SCC DepAnalDecl]
+    decl_sccs = nested_dep_anal rdr_env decls
+
+    insts :: [DepAnalInst]
+    insts = [ inst | InstPayload inst <- flattenSCC initial_scc ]
+
+    decls :: [DepAnalDecl]
+    decls = [ decl | DeclPayload decl <- flattenSCC initial_scc ]
+
+    tc_names :: NameSet
+    tc_names = mkNameSet [ name | Decl{decl_name = name} <- decls ]
+
+    instds_w_fvs :: [(LInstDecl GhcRn, FreeVars)]
+    instds_w_fvs = [ (inst, fvs) | Inst{inst_inst = inst, inst_fvs = fvs} <- insts ]
+
+    inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs
+    (init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map
+
+    mk_groups :: InstDeclFreeVarsMap
+              -> [SCC DepAnalDecl]
+              -> [TyClGroup GhcRn]
+    mk_groups final_inst_ds [] =
+      assertPpr
+        (null final_inst_ds)
+        (vcat [ ppr instds_w_fvs
+              , ppr inst_ds_map
+              , ppr final_inst_ds ])
+        []
+    mk_groups inst_map (scc : sccs) =
+        mk_decl_groups ds ++
+        mk_inst_groups inst_ds ++
+        mk_groups inst_map' sccs
+      where
+        ds = flattenSCC scc
+        (inst_ds, inst_map') = getInsts (map decl_name ds) inst_map
+
+    groups = mk_groups rest_inst_ds decl_sccs
+    first_groups = mk_inst_groups init_inst_ds
+
+nested_dep_anal :: GlobalRdrEnv -> [DepAnalDecl] -> [SCC DepAnalDecl]
+nested_dep_anal rdr_env decls =
+  stronglyConnCompFromEdgedVerticesUniq
+    [ DigraphNode decl name (get_deps fvs)
+    | decl@Decl{decl_name = name, decl_fvs = fvs} <- decls ]
+  where
+    get_deps :: FreeVars -> [Name]
+    get_deps = map get_dep . mapMaybe (lookupGRE_Name rdr_env) . nonDetEltsUniqSet
+
+    get_dep :: GlobalRdrElt -> Name
+    get_dep GRE{gre_name = name, gre_par = par} =
+      case par of
+        NoParent -> name
+        ParentIs p -> p
+
+mk_decl_groups :: [DepAnalDecl] -> [TyClGroup GhcRn]
+mk_decl_groups [] = []
+mk_decl_groups ds =
+    [foldr add_decl_payload empty_group ds]
+  where
+    add_decl_payload :: DepAnalDecl -> TyClGroup GhcRn -> TyClGroup GhcRn
+    add_decl_payload decl g =
+      TyClGroup { group_ext    = group_ext g
+                , group_tyclds = decl_decl decl : group_tyclds g
+                , group_kisigs = maybe id (:) (decl_kisig decl) (group_kisigs g)
+                , group_roles  = maybe id (:) (decl_roles decl) (group_roles g)
+                , group_instds = group_instds g }
+    empty_group = TyClGroup noExtField [] [] [] []
+
+mk_inst_groups :: [LInstDecl GhcRn] -> [TyClGroup GhcRn]
+mk_inst_groups inst_ds =
+    [ empty_group { group_instds = [inst] }
+    | inst <- sortBy cmpBufSpanA inst_ds ]
+  where
+    empty_group = TyClGroup noExtField [] [] [] []
+
+lookupKiSigFVs :: NameEnv (LStandaloneKindSig GhcRn, FreeVars) -> Name -> (Maybe (LStandaloneKindSig GhcRn), FreeVars)
+lookupKiSigFVs env name =
+  case lookupNameEnv env name of
+    Nothing -> (Nothing, emptyFVs)
+    Just (kisig, fvs) -> (Just kisig, fvs)
+
+data DepAnalInst =
+  Inst { inst_index :: Int
+       , inst_name  :: Name
+       , inst_inst  :: LInstDecl GhcRn
+       , inst_fvs   :: FreeVars }
+
+data DepAnalDecl =
+  Decl { decl_name  :: Name
+       , decl_roles :: Maybe (LRoleAnnotDecl GhcRn)
+       , decl_kisig :: Maybe (LStandaloneKindSig GhcRn)
+       , decl_decl  :: LTyClDecl GhcRn
+       , decl_fvs   :: FreeVars }
+
+data DepAnalKey =
+    InstKey Name Int
+  | DeclKey Name
+  deriving (Eq, Ord)
+
+data DepAnalPayload = --  TyClGroupBuilder (TyClGroup GhcRn -> TyClGroup GhcRn)
+    InstPayload DepAnalInst
+  | DeclPayload DepAnalDecl
+
+cmpBufSpanA :: GenLocated (SrcSpanAnn' a1) a2 -> GenLocated (SrcSpanAnn' a3) a2 -> Ordering
+cmpBufSpanA (L la a) (L lb b) = cmpBufSpan (L (locA la) a) (L (locA lb) b)
+
+get_decl_name :: LTyClDecl GhcRn -> Name
+get_decl_name = tcdName . unLoc
+
+get_inst_name :: LInstDecl GhcRn -> Name
+get_inst_name (L _ inst) =
+  unLoc $ case inst of
+    ClsInstD { cid_inst = inst } ->
+        go ((unLoc . sig_body . unLoc . cid_poly_ty) inst)
+      where
+        go (HsTyVar _ _ name) = name
+        go (HsOpTy _ _ _ name _) = name
+        go HsQualTy{hst_body = L _ ty} = go ty
+        go (HsAppTy _ (L _ ty) _) = go ty
+        go (HsAppKindTy _ (L _ ty) _ _) = go ty
+        go (HsParTy _ (L _ ty)) = go ty
+        go _ = panic "get_inst_name: unsupported class instance head"
+    DataFamInstD { dfid_inst = inst } -> (feqn_tycon . dfid_eqn) inst
+    TyFamInstD { tfid_inst = inst } -> (feqn_tycon . tfid_eqn) inst

hadrian/src/Flavour.hs

@@ -128,9 +128,13 @@ werror =
         ? notStage0
         ? mconcat
           [ arg "-Werror"
-          , flag CrossCompiling
-              ? package unix
+            -- unix has many unused imports
+          , package unix
               ? mconcat [arg "-Wwarn=unused-imports", arg "-Wwarn=unused-top-binds"]
+            -- semaphore-compat relies on sem_getvalue as provided by unix, which is
+            -- not implemented on Darwin and therefore throws a deprecation warning
+          , package semaphoreCompat
+              ? mconcat [arg "-Wwarn=deprecations"]
           ]
     , builder Ghc
         ? package rts

hadrian/src/Rules/Documentation.hs

@@ -258,6 +258,15 @@ buildPackageDocumentation = do
         need [ takeDirectory file  -/- "haddock-prologue.txt"]
         haddocks <- haddockDependencies context
 
+        -- Build Haddock documentation
+        -- TODO: Pass the correct way from Rules via Context.
+        dynamicPrograms <- dynamicGhcPrograms =<< flavour
+        let haddockWay = if dynamicPrograms then dynamic else vanilla
+
+        -- Build the dependencies of the package we are going to build documentation for
+        dep_pkgs <- sequence [pkgConfFile (context { way = haddockWay, Context.package = p})
+                             | (p, _) <- haddocks]
+
         -- `ghc-prim` has a source file for 'GHC.Prim' which is generated just
         -- for Haddock. We need to 'union' (instead of '++') to avoid passing
         -- 'GHC.PrimopWrappers' (which unfortunately shows up in both
@@ -266,12 +275,8 @@ buildPackageDocumentation = do
         vanillaSrcs <- hsSources context
         let srcs = vanillaSrcs `union` generatedSrcs
 
-        need $ srcs ++ (map snd haddocks)
+        need $ srcs ++ (map snd haddocks) ++ dep_pkgs
 
-        -- Build Haddock documentation
-        -- TODO: Pass the correct way from Rules via Context.
-        dynamicPrograms <- dynamicGhcPrograms =<< flavour
-        let haddockWay = if dynamicPrograms then dynamic else vanilla
         statsFilesDir <- haddockStatsFilesDir
         createDirectory statsFilesDir
         build $ target (context {way = haddockWay}) (Haddock BuildPackage) srcs [file]

libraries/base/include/HsBase.h

@@ -540,7 +540,7 @@ INLINE int __hscore_open(char *file, int how, mode_t mode) {
 }
 #endif
 
-#if darwin_HOST_OS
+#if defined(darwin_HOST_OS)
 // You should not access _environ directly on Darwin in a bundle/shared library.
 // See #2458 and http://developer.apple.com/library/mac/#documentation/Darwin/Reference/ManPages/man7/environ.7.html
 #include <crt_externs.h>

libraries/ghci/GHCi/FFI.hsc

@@ -22,6 +22,14 @@
 -}
 
 #if !defined(javascript_HOST_ARCH)
+-- See Note [FFI_GO_CLOSURES workaround] in ghc_ffi.h
+-- We can't include ghc_ffi.h here as we must build with stage0
+#if defined(darwin_HOST_OS)
+#if !defined(FFI_GO_CLOSURES)
+#define FFI_GO_CLOSURES 0
+#endif
+#endif
+
 #include <ffi.h>
 #endif
 

rts/Interpreter.c

@@ -39,7 +39,7 @@
 #endif
 #endif
 
-#include "ffi.h"
+#include "rts/ghc_ffi.h"
 
 /* --------------------------------------------------------------------------
  * The bytecode interpreter

rts/Schedule.c

@@ -1160,9 +1160,11 @@ scheduleHandleHeapOverflow( Capability *cap, StgTSO *t )
             barf("allocation of %ld bytes too large (GHC should have complained at compile-time)", (long)cap->r.rHpAlloc);
         }
 
+#if defined(DEBUG)
         debugTrace(DEBUG_sched,
                    "--<< thread %ld (%s) stopped: requesting a large block (size %ld)\n",
                    (long)t->id, what_next_strs[t->what_next], blocks);
+#endif
 
         // don't do this if the nursery is (nearly) full, we'll GC first.
         if (cap->r.rCurrentNursery->link != NULL ||
@@ -1231,9 +1233,11 @@ scheduleHandleYield( Capability *cap, StgTSO *t, uint32_t prev_what_next )
     // Shortcut if we're just switching evaluators: just run the thread.  See
     // Note [avoiding threadPaused] in Interpreter.c.
     if (t->what_next != prev_what_next) {
+#if defined(DEBUG)
         debugTrace(DEBUG_sched,
                    "--<< thread %ld (%s) stopped to switch evaluators",
                    (long)t->id, what_next_strs[t->what_next]);
+#endif
         return true;
     }
 
@@ -1806,7 +1810,7 @@ scheduleDoGC (Capability **pcap, Task *task USED_IF_THREADS,
                 }
             }
         }
-        debugTrace(DEBUG_sched, "%d idle caps", n_idle_caps);
+        debugTrace(DEBUG_sched, "%d idle caps, %d failed grabs", n_idle_caps, n_failed_trygrab_idles);
 
         for (i=0; i < n_capabilities; i++) {
             NONATOMIC_ADD(&getCapability(i)->idle, 1);
@@ -2643,7 +2647,6 @@ void
 scheduleWaitThread (StgTSO* tso, /*[out]*/HaskellObj* ret, Capability **pcap)
 {
     Task *task;
-    DEBUG_ONLY( StgThreadID id );
     Capability *cap;
 
     cap = *pcap;
@@ -2662,8 +2665,9 @@ scheduleWaitThread (StgTSO* tso, /*[out]*/HaskellObj* ret, Capability **pcap)
 
     appendToRunQueue(cap,tso);
 
-    DEBUG_ONLY( id = tso->id );
-    debugTrace(DEBUG_sched, "new bound thread (%" FMT_StgThreadID ")", id);
+    DEBUG_ONLY(
+        debugTrace(DEBUG_sched, "new bound thread (%" FMT_StgThreadID ")", (StgThreadID) tso->id);
+    );
 
     // As the TSO is bound and on the run queue, schedule() will run the TSO.
     cap = schedule(cap,task);
@@ -2671,7 +2675,7 @@ scheduleWaitThread (StgTSO* tso, /*[out]*/HaskellObj* ret, Capability **pcap)
     ASSERT(task->incall->rstat != NoStatus);
     ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
 
-    debugTrace(DEBUG_sched, "bound thread (%" FMT_StgThreadID ") finished", id);
+    debugTrace(DEBUG_sched, "bound thread (%" FMT_StgThreadID ") finished", (StgThreadID) tso->id);
     *pcap = cap;
 }
 
@@ -2793,9 +2797,6 @@ exitScheduler (bool wait_foreign USED_IF_THREADS)
 
     shutdownCapabilities(task, wait_foreign);
 
-    // debugBelch("n_failed_trygrab_idles = %d, n_idle_caps = %d\n",
-    //            n_failed_trygrab_idles, n_idle_caps);
-
     exitMyTask();
 }
 

rts/Sparks.c

@@ -119,11 +119,10 @@ pruneSparkQueue (bool nonmovingMarkFinished, Capability *cap)
 {
     SparkPool *pool;
     StgClosurePtr spark, tmp, *elements;
-    uint32_t n, pruned_sparks; // stats only
+    uint32_t pruned_sparks; // stats only
     StgInt botInd,oldBotInd,currInd; // indices in array (always < size)
     const StgInfoTable *info;
 
-    n = 0;
     pruned_sparks = 0;
 
     pool = cap->sparks;
@@ -216,7 +215,6 @@ pruneSparkQueue (bool nonmovingMarkFinished, Capability *cap)
               if (closure_SHOULD_SPARK(tmp)) {
                   elements[botInd] = tmp; // keep entry (new address)
                   botInd++;
-                  n++;
               } else {
                   pruned_sparks++; // discard spark
                   cap->spark_stats.fizzled++;
@@ -246,7 +244,6 @@ pruneSparkQueue (bool nonmovingMarkFinished, Capability *cap)
                   if (closure_SHOULD_SPARK(spark)) {
                       elements[botInd] = spark; // keep entry (new address)
                       botInd++;
-                      n++;
                   } else {
                       pruned_sparks++; // discard spark
                       cap->spark_stats.fizzled++;
@@ -264,7 +261,6 @@ pruneSparkQueue (bool nonmovingMarkFinished, Capability *cap)
                   // isAlive() also ignores static closures (see GCAux.c)
                   elements[botInd] = spark; // keep entry (new address)
                   botInd++;
-                  n++;
               } else {
                   pruned_sparks++; // discard spark
                   cap->spark_stats.fizzled++;

rts/Trace.h

@@ -235,26 +235,25 @@ void traceThreadLabel_(Capability *cap,
                        char       *label,
                        size_t      len);
 
+
+#if defined(DEBUG)
+#define DEBUG_RTS 1
+#else
+#define DEBUG_RTS 0
+#endif
+
 /*
  * Emit a debug message (only when DEBUG is defined)
  */
-#if defined(DEBUG)
 #define debugTrace(class, msg, ...)             \
-    if (RTS_UNLIKELY(class)) {                  \
+    if (DEBUG_RTS && RTS_UNLIKELY(class)) {     \
         trace_(msg, ##__VA_ARGS__);             \
     }
-#else
-#define debugTrace(class, str, ...) /* nothing */
-#endif
 
-#if defined(DEBUG)
-#define debugTraceCap(class, cap, msg, ...)      \
-    if (RTS_UNLIKELY(class)) {                  \
+#define debugTraceCap(class, cap, msg, ...)     \
+    if (DEBUG_RTS && RTS_UNLIKELY(class)) {     \
         traceCap_(cap, msg, ##__VA_ARGS__);     \
     }
-#else
-#define debugTraceCap(class, cap, str, ...) /* nothing */
-#endif
 
 /*
  * Emit a message/event describing the state of a thread

rts/TraverseHeap.c

@@ -48,7 +48,7 @@ static void debug(const char *s, ...)
     va_end(ap);
 }
 #else
-#define debug(...)
+static void debug(const char *s STG_UNUSED, ...) {}
 #endif
 
 // number of blocks allocated for one stack

rts/adjustor/LibffiAdjustor.c

@@ -11,7 +11,7 @@
 #include "Hash.h"
 #include "Adjustor.h"
 
-#include "ffi.h"
+#include "rts/ghc_ffi.h"
 #include <string.h>
 
 // Note that ffi_alloc_prep_closure is a non-standard libffi closure

rts/include/rts/ghc_ffi.h

+/*
+ * <ffi.h> wrapper working around #23586.
+ *
+ * (c) The University of Glasgow 2023
+ *
+ */
+
+#pragma once
+
+/*
+ * Note [FFI_GO_CLOSURES workaround]
+ * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ * Apple ships a broken libffi with Xcode which lacks a definition of
+ * FFI_GO_CLOSURES despite having references to said macro. Work around this
+ * for now to avoid -Wundef warnings.
+ *
+ * We choose the value zero here by following the model of OpenJDK.
+ * See https://github.com/openjdk/jdk17u-dev/pull/741/files.
+ *
+ * See #23568.
+ */
+#if defined(darwin_HOST_OS)
+#if !defined(FFI_GO_CLOSURES)
+#define FFI_GO_CLOSURES 0
+#endif
+#endif
+
+#include "ffi.h"

rts/rts.cabal.in

@@ -237,6 +237,7 @@ library
                         rts/EventLogConstants.h
                         rts/EventTypes.h
                         -- ^ generated
+                        rts/ghc_ffi.h
                         rts/Adjustor.h
                         rts/ExecPage.h
                         rts/BlockSignals.h

rts/sm/GC.c

@@ -691,6 +691,7 @@ GarbageCollect (struct GcConfig config,
         }
         copied +=  mut_list_size;
 
+#if defined(DEBUG)
         debugTrace(DEBUG_gc,
                    "mut_list_size: %lu (%d vars, %d arrays, %d MVARs, %d TVARs, %d TVAR_WATCH_QUEUEs, %d TREC_CHUNKs, %d TREC_HEADERs, %d others)",
                    (unsigned long)(mut_list_size * sizeof(W_)),
@@ -702,6 +703,7 @@ GarbageCollect (struct GcConfig config,
                    mutlist_scav_stats.n_TREC_CHUNK,
                    mutlist_scav_stats.n_TREC_HEADER,
                    mutlist_scav_stats.n_OTHERS);
+#endif
     }
 
     bdescr *next, *prev;

rts/sm/NonMoving.c

@@ -901,14 +901,12 @@ static void nonmovingMark_(MarkQueue *mark_queue, StgWeak **dead_weaks, StgTSO *
     // updated their snapshot pointers and move them to the sweep list.
     for (int alloca_idx = 0; alloca_idx < NONMOVING_ALLOCA_CNT; ++alloca_idx) {
         struct NonmovingSegment *filled = nonmovingHeap.allocators[alloca_idx].saved_filled;
-        uint32_t n_filled = 0;
         if (filled) {
             struct NonmovingSegment *seg = filled;
             while (true) {
                 // Set snapshot
                 nonmovingSegmentInfo(seg)->next_free_snap = seg->next_free;
                 SET_SEGMENT_STATE(seg, FILLED_SWEEPING);
-                n_filled++;
                 if (seg->link) {
                     seg = seg->link;
                 } else {
@@ -1161,24 +1159,20 @@ void assert_in_nonmoving_heap(StgPtr p)
         }
 
         // Search active segments
-        int seg_idx = 0;
         struct NonmovingSegment *seg = alloca->active;
         while (seg) {
             if (p >= (P_)seg && p < (((P_)seg) + NONMOVING_SEGMENT_SIZE_W)) {
                 return;
             }
-            seg_idx++;
             seg = seg->link;
         }
 
         // Search filled segments
-        seg_idx = 0;
         seg = alloca->filled;
         while (seg) {
             if (p >= (P_)seg && p < (((P_)seg) + NONMOVING_SEGMENT_SIZE_W)) {
                 return;
             }
-            seg_idx++;
             seg = seg->link;
         }
     }

rts/sm/NonMovingMark.c

@@ -268,7 +268,7 @@ void nonmovingMarkInit() {
 #endif
 }
 
-#if defined(THREADED_RTS) && defined(DEBUG)
+#if defined(THREADED_RTS)
 static uint32_t markQueueLength(MarkQueue *q);
 #endif
 static void init_mark_queue_(MarkQueue *queue);
@@ -985,7 +985,7 @@ void freeMarkQueue (MarkQueue *queue)
     freeChain_lock(queue->blocks);
 }
 
-#if defined(THREADED_RTS) && defined(DEBUG)
+#if defined(THREADED_RTS)
 static uint32_t
 markQueueLength (MarkQueue *q)
 {

rts/sm/Storage.c

@@ -53,7 +53,7 @@
 
 #include <string.h>
 
-#include "ffi.h"
+#include "rts/ghc_ffi.h"
 
 /*
  * All these globals require sm_mutex to access in THREADED_RTS mode.

testsuite/tests/dependent/should_compile/T12088a.hs

+{-# LANGUAGE DataKinds, TypeFamilies, UndecidableInstances #-}
+
+module T12088a where
+
+import Data.Kind
+import GHC.TypeLits
+
+type family Open a
+type instance Open Bool = Nat
+type instance Open Float = Type
+type instance Open Char = F Float
+
+type F :: forall a -> Open a
+type family F a
+type instance F Bool = 42
+type instance F Float = [Nat]
+type instance F Char = '[0, 1]

testsuite/tests/dependent/should_compile/T12088b.hs

+{-# LANGUAGE DataKinds, TypeFamilies #-}
+
+module T12088b where
+
+import Data.Kind
+
+type family IxKind (m :: Type) :: Type
+type family Value (m :: Type) :: IxKind m -> Type
+data T (k :: Type) (f :: k -> Type) = MkT
+
+type instance IxKind (T k f) = k
+type instance Value (T k f) = f
\ No newline at end of file