[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: libffi-tarballs: bump libffi-tarballs submodule to libffi 3.4.6
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Mar 26 15:26:02 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
810660b7 by Cheng Shao at 2024-03-25T22:19:16-04:00
libffi-tarballs: bump libffi-tarballs submodule to libffi 3.4.6
This commit bumps the libffi-tarballs submodule to libffi 3.4.6, which
includes numerous upstream libffi fixes, especially
https://github.com/libffi/libffi/issues/760.
- - - - -
d2ba41e8 by Alan Zimmerman at 2024-03-25T22:19:51-04:00
EPA: do not duplicate comments in signature RHS
- - - - -
72b3ec62 by Zubin Duggal at 2024-03-26T11:25:38-04:00
driver: Make `checkHomeUnitsClosed` faster
The implementation of `checkHomeUnitsClosed` was traversing every single path
in the unit dependency graph - this grows exponentially and quickly grows to be
infeasible on larger unit dependency graphs.
Instead we replace this with a faster implementation which follows from the
specificiation of the closure property - there is a closure error if there are
units which are both are both (transitively) depended upon by home units and
(transitively) depend on home units, but are not themselves home units.
To compute the set of units required for closure, we first compute the closure
of the unit dependency graph, then the transpose of this closure, and find all
units that are reachable from the home units in the transpose of the closure.
- - - - -
0fcc5b84 by Rodrigo Mesquita at 2024-03-26T11:25:38-04:00
Revert "NCG: Fix a bug in jump shortcutting."
This reverts commit 5bd8ed53dcefe10b72acb5729789e19ceb22df66.
Fixes #24586
- - - - -
20 changed files:
- compiler/GHC/CmmToAsm/AArch64/Instr.hs
- compiler/GHC/CmmToAsm/BlockLayout.hs
- compiler/GHC/CmmToAsm/Instr.hs
- compiler/GHC/CmmToAsm/PPC/Instr.hs
- compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs
- compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
- compiler/GHC/CmmToAsm/Reg/Liveness.hs
- compiler/GHC/CmmToAsm/X86/Instr.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Hs/Utils.hs
- libffi-tarballs
- − testsuite/tests/codeGen/should_run/T24507.hs
- − testsuite/tests/codeGen/should_run/T24507.stdout
- − testsuite/tests/codeGen/should_run/T24507_cmm.cmm
- testsuite/tests/codeGen/should_run/all.T
- + testsuite/tests/driver/multipleHomeUnits/mhu-perf/Makefile
- + testsuite/tests/driver/multipleHomeUnits/mhu-perf/Setup.hs
- + testsuite/tests/driver/multipleHomeUnits/mhu-perf/all.T
- + testsuite/tests/driver/multipleHomeUnits/mhu-perf/genLargeHMU
- + testsuite/tests/driver/multipleHomeUnits/mhu-perf/mhu-perf.stderr
Changes:
=====================================
compiler/GHC/CmmToAsm/AArch64/Instr.hs
=====================================
@@ -301,20 +301,15 @@ isJumpishInstr instr = case instr of
-- | Checks whether this instruction is a jump/branch instruction.
-- One that can change the flow of control in a way that the
-- register allocator needs to worry about.
-jumpDestsOfInstr :: Instr -> [Maybe BlockId]
+jumpDestsOfInstr :: Instr -> [BlockId]
jumpDestsOfInstr (ANN _ i) = jumpDestsOfInstr i
-jumpDestsOfInstr i = case i of
- (CBZ _ t) -> [ mkDest t ]
- (CBNZ _ t) -> [ mkDest t ]
- (J t) -> [ mkDest t ]
- (B t) -> [ mkDest t ]
- (BL t _ _) -> [ mkDest t ]
- (BCOND _ t) -> [ mkDest t ]
- _ -> []
- where
- mkDest (TBlock id) = Just id
- mkDest TLabel{} = Nothing
- mkDest TReg{} = Nothing
+jumpDestsOfInstr (CBZ _ t) = [ id | TBlock id <- [t]]
+jumpDestsOfInstr (CBNZ _ t) = [ id | TBlock id <- [t]]
+jumpDestsOfInstr (J t) = [id | TBlock id <- [t]]
+jumpDestsOfInstr (B t) = [id | TBlock id <- [t]]
+jumpDestsOfInstr (BL t _ _) = [ id | TBlock id <- [t]]
+jumpDestsOfInstr (BCOND _ t) = [ id | TBlock id <- [t]]
+jumpDestsOfInstr _ = []
-- | Change the destination of this jump instruction.
-- Used in the linear allocator when adding fixup blocks for join
=====================================
compiler/GHC/CmmToAsm/BlockLayout.hs
=====================================
@@ -771,7 +771,7 @@ dropJumps :: forall a i. Instruction i => LabelMap a -> [GenBasicBlock i]
dropJumps _ [] = []
dropJumps info (BasicBlock lbl ins:todo)
| Just ins <- nonEmpty ins --This can happen because of shortcutting
- , [Just dest] <- jumpDestsOfInstr (NE.last ins)
+ , [dest] <- jumpDestsOfInstr (NE.last ins)
, BasicBlock nextLbl _ : _ <- todo
, not (mapMember dest info)
, nextLbl == dest
@@ -870,7 +870,7 @@ mkNode edgeWeights block@(BasicBlock id instrs) =
| length successors > 2 || edgeWeight info <= 0 -> []
| otherwise -> [target]
| Just instr <- lastMaybe instrs
- , [one] <- jumpBlockDestsOfInstr instr
+ , [one] <- jumpDestsOfInstr instr
= [one]
| otherwise = []
=====================================
compiler/GHC/CmmToAsm/Instr.hs
=====================================
@@ -17,8 +17,6 @@ import GHC.Cmm.BlockId
import GHC.CmmToAsm.Config
import GHC.Data.FastString
-import Data.Maybe (catMaybes)
-
-- | Holds a list of source and destination registers used by a
-- particular instruction.
--
@@ -75,17 +73,9 @@ class Instruction instr where
-- | Give the possible destinations of this jump instruction.
-- Must be defined for all jumpish instructions.
- -- Returns Nothing for non BlockId destinations.
jumpDestsOfInstr
- :: instr -> [Maybe BlockId]
-
- -- | Give the possible block destinations of this jump instruction.
- -- Must be defined for all jumpish instructions.
- jumpBlockDestsOfInstr
:: instr -> [BlockId]
- jumpBlockDestsOfInstr = catMaybes . jumpDestsOfInstr
-
-- | Change the destination of this jump instruction.
-- Used in the linear allocator when adding fixup blocks for join
=====================================
compiler/GHC/CmmToAsm/PPC/Instr.hs
=====================================
@@ -513,15 +513,12 @@ isJumpishInstr instr
-- | Checks whether this instruction is a jump/branch instruction.
-- One that can change the flow of control in a way that the
-- register allocator needs to worry about.
-jumpDestsOfInstr :: Instr -> [Maybe BlockId]
+jumpDestsOfInstr :: Instr -> [BlockId]
jumpDestsOfInstr insn
= case insn of
- BCC _ id _ -> [Just id]
- BCCFAR _ id _ -> [Just id]
- BCTR targets _ _ -> targets
- BCTRL{} -> [Nothing]
- BL{} -> [Nothing]
- JMP{} -> [Nothing]
+ BCC _ id _ -> [id]
+ BCCFAR _ id _ -> [id]
+ BCTR targets _ _ -> [id | Just id <- targets]
_ -> []
=====================================
compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs
=====================================
@@ -207,7 +207,7 @@ cleanForward platform blockId assoc acc (li : instrs)
-- Remember the association over a jump.
| LiveInstr instr _ <- li
- , targets <- jumpBlockDestsOfInstr instr
+ , targets <- jumpDestsOfInstr instr
, not $ null targets
= do mapM_ (accJumpValid assoc) targets
cleanForward platform blockId assoc (li : acc) instrs
@@ -386,7 +386,7 @@ cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc (li : instrs)
-- it always does, but if those reloads are cleaned the slot
-- liveness map doesn't get updated.
| LiveInstr instr _ <- li
- , targets <- jumpBlockDestsOfInstr instr
+ , targets <- jumpDestsOfInstr instr
= do
let slotsReloadedByTargets
= IntSet.unions
=====================================
compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
=====================================
@@ -57,7 +57,7 @@ joinToTargets block_live id instr
= return ([], instr)
| otherwise
- = joinToTargets' block_live [] id instr (jumpBlockDestsOfInstr instr)
+ = joinToTargets' block_live [] id instr (jumpDestsOfInstr instr)
-----
joinToTargets'
=====================================
compiler/GHC/CmmToAsm/Reg/Liveness.hs
=====================================
@@ -468,7 +468,7 @@ slurpReloadCoalesce live
-- if we hit a jump, remember the current slotMap
| LiveInstr (Instr instr) _ <- li
- , targets <- jumpBlockDestsOfInstr instr
+ , targets <- jumpDestsOfInstr instr
, not $ null targets
= do mapM_ (accSlotMap slotMap) targets
return (slotMap, Nothing)
@@ -760,7 +760,7 @@ sccBlocks blocks entries mcfg = map (fmap node_payload) sccs
sccs = stronglyConnCompG g2
getOutEdges :: Instruction instr => [instr] -> [BlockId]
- getOutEdges instrs = concatMap jumpBlockDestsOfInstr instrs
+ getOutEdges instrs = concatMap jumpDestsOfInstr instrs
-- This is truly ugly, but I don't see a good alternative.
-- Digraph just has the wrong API. We want to identify nodes
@@ -837,7 +837,7 @@ checkIsReverseDependent sccs'
slurpJumpDestsOfBlock (BasicBlock _ instrs)
= unionManyUniqSets
- $ map (mkUniqSet . jumpBlockDestsOfInstr)
+ $ map (mkUniqSet . jumpDestsOfInstr)
[ i | LiveInstr i _ <- instrs]
@@ -1047,7 +1047,7 @@ liveness1 platform liveregs blockmap (LiveInstr instr _)
-- union in the live regs from all the jump destinations of this
-- instruction.
- targets = jumpBlockDestsOfInstr instr -- where we go from here
+ targets = jumpDestsOfInstr instr -- where we go from here
not_a_branch = null targets
targetLiveRegs target
=====================================
compiler/GHC/CmmToAsm/X86/Instr.hs
=====================================
@@ -672,16 +672,13 @@ isJumpishInstr instr
jumpDestsOfInstr
:: Instr
- -> [Maybe BlockId]
+ -> [BlockId]
jumpDestsOfInstr insn
= case insn of
- JXX _ id -> [Just id]
- JMP_TBL _ ids _ _ -> [(mkDest dest) | Just dest <- ids]
+ JXX _ id -> [id]
+ JMP_TBL _ ids _ _ -> [id | Just (DestBlockId id) <- ids]
_ -> []
- where
- mkDest (DestBlockId id) = Just id
- mkDest _ = Nothing
patchJumpInstr
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -1565,8 +1565,8 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
(root_errs, rootSummariesOk) <- partitionWithM getRootSummary roots -- #17549
let root_map = mkRootMap rootSummariesOk
checkDuplicates root_map
- (deps, pkg_deps, map0) <- loopSummaries rootSummariesOk (M.empty, Set.empty, root_map)
- let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env) (hsc_all_home_unit_ids hsc_env) (Set.toList pkg_deps)
+ (deps, map0) <- loopSummaries rootSummariesOk (M.empty, root_map)
+ let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env)
let unit_env = hsc_unit_env hsc_env
let tmpfs = hsc_tmpfs hsc_env
@@ -1660,19 +1660,19 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
-- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit
loopSummaries :: [ModSummary]
- -> (M.Map NodeKey ModuleGraphNode, Set.Set (UnitId, UnitId),
+ -> (M.Map NodeKey ModuleGraphNode,
DownsweepCache)
- -> IO ((M.Map NodeKey ModuleGraphNode), Set.Set (UnitId, UnitId), DownsweepCache)
+ -> IO ((M.Map NodeKey ModuleGraphNode), DownsweepCache)
loopSummaries [] done = return done
- loopSummaries (ms:next) (done, pkgs, summarised)
+ loopSummaries (ms:next) (done, summarised)
| Just {} <- M.lookup k done
- = loopSummaries next (done, pkgs, summarised)
+ = loopSummaries next (done, summarised)
-- Didn't work out what the imports mean yet, now do that.
| otherwise = do
- (final_deps, pkgs1, done', summarised') <- loopImports (calcDeps ms) done summarised
+ (final_deps, done', summarised') <- loopImports (calcDeps ms) done summarised
-- This has the effect of finding a .hs file if we are looking at the .hs-boot file.
- (_, _, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'
- loopSummaries next (M.insert k (ModuleNode final_deps ms) done'', pkgs1 `Set.union` pkgs, summarised'')
+ (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'
+ loopSummaries next (M.insert k (ModuleNode final_deps ms) done'', summarised'')
where
k = NodeKey_Module (msKey ms)
@@ -1692,18 +1692,17 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
-- Visited set; the range is a list because
-- the roots can have the same module names
-- if allow_dup_roots is True
- -> IO ([NodeKey], Set.Set (UnitId, UnitId),
-
+ -> IO ([NodeKey],
M.Map NodeKey ModuleGraphNode, DownsweepCache)
-- The result is the completed NodeMap
- loopImports [] done summarised = return ([], Set.empty, done, summarised)
+ loopImports [] done summarised = return ([], done, summarised)
loopImports ((home_uid,mb_pkg, gwib) : ss) done summarised
| Just summs <- M.lookup cache_key summarised
= case summs of
[Right ms] -> do
let nk = NodeKey_Module (msKey ms)
- (rest, pkgs, summarised', done') <- loopImports ss done summarised
- return (nk: rest, pkgs, summarised', done')
+ (rest, summarised', done') <- loopImports ss done summarised
+ return (nk: rest, summarised', done')
[Left _err] ->
loopImports ss done summarised
_errs -> do
@@ -1715,69 +1714,77 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
Nothing excl_mods
case mb_s of
NotThere -> loopImports ss done summarised
- External uid -> do
- (other_deps, pkgs, done', summarised') <- loopImports ss done summarised
- return (other_deps, Set.insert (homeUnitId home_unit, uid) pkgs, done', summarised')
+ External _ -> do
+ (other_deps, done', summarised') <- loopImports ss done summarised
+ return (other_deps, done', summarised')
FoundInstantiation iud -> do
- (other_deps, pkgs, done', summarised') <- loopImports ss done summarised
- return (NodeKey_Unit iud : other_deps, pkgs, done', summarised')
+ (other_deps, done', summarised') <- loopImports ss done summarised
+ return (NodeKey_Unit iud : other_deps, done', summarised')
FoundHomeWithError (_uid, e) -> loopImports ss done (Map.insert cache_key [(Left e)] summarised)
FoundHome s -> do
- (done', pkgs1, summarised') <-
- loopSummaries [s] (done, Set.empty, Map.insert cache_key [Right s] summarised)
- (other_deps, pkgs2, final_done, final_summarised) <- loopImports ss done' summarised'
+ (done', summarised') <-
+ loopSummaries [s] (done, Map.insert cache_key [Right s] summarised)
+ (other_deps, final_done, final_summarised) <- loopImports ss done' summarised'
-- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.
- return (NodeKey_Module (msKey s) : other_deps, pkgs1 `Set.union` pkgs2, final_done, final_summarised)
+ return (NodeKey_Module (msKey s) : other_deps, final_done, final_summarised)
where
cache_key = (home_uid, mb_pkg, unLoc <$> gwib)
home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib
wanted_mod = L loc mod
--- This function checks then important property that if both p and q are home units
+-- | This function checks then important property that if both p and q are home units
-- then any dependency of p, which transitively depends on q is also a home unit.
-checkHomeUnitsClosed :: UnitEnv -> Set.Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages]
--- Fast path, trivially closed.
-checkHomeUnitsClosed ue home_id_set home_imp_ids
- | Set.size home_id_set == 1 = []
- | otherwise =
- let res = foldMap loop home_imp_ids
- -- Now check whether everything which transitively depends on a home_unit is actually a home_unit
- -- These units are the ones which we need to load as home packages but failed to do for some reason,
- -- it's a bug in the tool invoking GHC.
- bad_unit_ids = Set.difference res home_id_set
- in if Set.null bad_unit_ids
- then []
- else [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)]
-
+--
+-- See Note [Multiple Home Units], section 'Closure Property'.
+checkHomeUnitsClosed :: UnitEnv -> [DriverMessages]
+checkHomeUnitsClosed ue
+ | Set.null bad_unit_ids = []
+ | otherwise = [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)]
where
+ home_id_set = unitEnv_keys $ ue_home_unit_graph ue
+ bad_unit_ids = upwards_closure Set.\\ home_id_set
rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
- -- TODO: This could repeat quite a bit of work but I struggled to write this function.
- -- Which units transitively depend on a home unit
- loop :: (UnitId, UnitId) -> Set.Set UnitId -- The units which transitively depend on a home unit
- loop (from_uid, uid) =
- let us = ue_findHomeUnitEnv from_uid ue in
- let um = unitInfoMap (homeUnitEnv_units us) in
- case lookupUniqMap um uid of
- Nothing -> pprPanic "uid not found" (ppr uid)
- Just ui ->
- let depends = unitDepends ui
- home_depends = Set.fromList depends `Set.intersection` home_id_set
- other_depends = Set.fromList depends `Set.difference` home_id_set
- in
- -- Case 1: The unit directly depends on a home_id
- if not (null home_depends)
- then
- let res = foldMap (loop . (from_uid,)) other_depends
- in Set.insert uid res
- -- Case 2: Check the rest of the dependencies, and then see if any of them depended on
- else
- let res = foldMap (loop . (from_uid,)) other_depends
- in
- if not (Set.null res)
- then Set.insert uid res
- else res
+
+ graph :: Graph (Node UnitId UnitId)
+ graph = graphFromEdgedVerticesUniq graphNodes
+
+ -- downwards closure of graph
+ downwards_closure
+ = graphFromEdgedVerticesUniq [ DigraphNode uid uid (Set.toList deps)
+ | (uid, deps) <- M.toList (allReachable graph node_key)]
+
+ inverse_closure = transposeG downwards_closure
+
+ upwards_closure = Set.fromList $ map node_key $ reachablesG inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set]
+
+ all_unit_direct_deps :: UniqMap UnitId (Set.Set UnitId)
+ all_unit_direct_deps
+ = unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue
+ where
+ go rest this this_uis =
+ plusUniqMap_C Set.union
+ (addToUniqMap_C Set.union external_depends this (Set.fromList $ this_deps))
+ rest
+ where
+ external_depends = mapUniqMap (Set.fromList . unitDepends) (unitInfoMap this_units)
+ this_units = homeUnitEnv_units this_uis
+ this_deps = [ toUnitId unit | (unit,Just _) <- explicitUnits this_units]
+
+ graphNodes :: [Node UnitId UnitId]
+ graphNodes = go Set.empty home_id_set
+ where
+ go done todo
+ = case Set.minView todo of
+ Nothing -> []
+ Just (uid, todo')
+ | Set.member uid done -> go done todo'
+ | otherwise -> case lookupUniqMap all_unit_direct_deps uid of
+ Nothing -> pprPanic "uid not found" (ppr (uid, all_unit_direct_deps))
+ Just depends ->
+ let todo'' = (depends Set.\\ done) `Set.union` todo'
+ in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo''
-- | Update the every ModSummary that is depended on
-- by a module that needs template haskell. We enable codegen to
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -736,12 +736,12 @@ mkBigLHsPatTup = mkChunkified mkLHsPatTup
-- | Convert an 'LHsType' to an 'LHsSigType'.
hsTypeToHsSigType :: LHsType GhcPs -> LHsSigType GhcPs
-hsTypeToHsSigType lty@(L loc ty) = L loc $ case ty of
+hsTypeToHsSigType lty@(L loc ty) = case ty of
HsForAllTy { hst_tele = HsForAllInvis { hsf_xinvis = an
, hsf_invis_bndrs = bndrs }
, hst_body = body }
- -> mkHsExplicitSigType an bndrs body
- _ -> mkHsImplicitSigType lty
+ -> L loc $ mkHsExplicitSigType an bndrs body
+ _ -> L (l2l loc) $ mkHsImplicitSigType lty -- The annotations are in lty, erase them from loc
-- | Convert an 'LHsType' to an 'LHsSigWcType'.
hsTypeToHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs
=====================================
libffi-tarballs
=====================================
@@ -1 +1 @@
-Subproject commit 5624fd5c8bbce8432cd3c0b0ea92d152a1bba047
+Subproject commit 89a9b01c5647c8f0d3899435b99df690f582e9f1
=====================================
testsuite/tests/codeGen/should_run/T24507.hs deleted
=====================================
@@ -1,15 +0,0 @@
-{-# LANGUAGE MagicHash #-}
-{-# LANGUAGE UnboxedTuples #-}
-{-# LANGUAGE GHCForeignImportPrim #-}
-{-# LANGUAGE UnliftedFFITypes #-}
-
-module Main where
-
-import GHC.Exts
-
-foreign import prim "foo" foo :: Int# -> Int#
-
-main = do
-
- let f x = case x of I# x' -> case foo x' of x -> print (I# x)
- mapM_ f [1..7]
\ No newline at end of file
=====================================
testsuite/tests/codeGen/should_run/T24507.stdout deleted
=====================================
@@ -1,7 +0,0 @@
-1
-2
-2
-2
-2
-2
-2
=====================================
testsuite/tests/codeGen/should_run/T24507_cmm.cmm deleted
=====================================
@@ -1,35 +0,0 @@
-#include "Cmm.h"
-
-bar() {
- return (2);
-}
-
-foo(W_ x) {
-
- switch(x) {
- case 1: goto a;
- case 2: goto b;
- case 3: goto c;
- case 4: goto d;
- case 5: goto e;
- case 6: goto f;
- case 7: goto g;
- }
- return (1);
-
- a:
- return (1);
- b:
- jump bar();
- c:
- jump bar();
- d:
- jump bar();
- e:
- jump bar();
- f:
- jump bar();
- g:
- jump bar();
-
-}
=====================================
testsuite/tests/codeGen/should_run/all.T
=====================================
@@ -243,6 +243,3 @@ test('MulMayOflo_full',
test('T24264run', normal, compile_and_run, [''])
test('T24295a', normal, compile_and_run, ['-O -floopification'])
test('T24295b', normal, compile_and_run, ['-O -floopification -fpedantic-bottoms'])
-
-test('T24507', [req_cmm], multi_compile_and_run,
- ['T24507', [('T24507_cmm.cmm', '')], '-O2'])
=====================================
testsuite/tests/driver/multipleHomeUnits/mhu-perf/Makefile
=====================================
@@ -0,0 +1,23 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+SETUP=../Setup -v0
+
+mhu-perf: clean
+ $(MAKE) -s --no-print-directory clean
+ ./genLargeHMU
+ '$(GHC_PKG)' init tmp.d
+ '$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make Setup
+ for dir in unit-p*; do \
+ cd $$dir && $(SETUP) clean && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --ipid=$$dir-0.1.0.0 --with-ghc='$(TEST_HC)' --with-hc-pkg='$(GHC_PKG)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d && $(SETUP) build && $(SETUP) register --inplace && cd ..; \
+ done;
+
+
+ifeq "$(CLEANUP)" "1"
+ $(MAKE) -s --no-print-directory clean
+endif
+
+clean :
+ $(RM) -r unitTop* unit-p* top*/ tmp*.d inst-* *.o *.hi */*.o */*.hi */Setup$(exeext) */dist Setup$(exeext)
+
=====================================
testsuite/tests/driver/multipleHomeUnits/mhu-perf/Setup.hs
=====================================
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
=====================================
testsuite/tests/driver/multipleHomeUnits/mhu-perf/all.T
=====================================
@@ -0,0 +1,9 @@
+test('mhu-perf',
+ [ collect_compiler_stats('bytes allocated',2),
+ extra_files(['genLargeHMU','Setup.hs']),
+ pre_cmd('$MAKE -s --no-print-directory mhu-perf'),
+ js_broken(22349),
+ compile_timeout_multiplier(5)
+ ],
+ multiunit_compile,
+ [['unitTop1', 'unitTop2'], '-fhide-source-paths'])
=====================================
testsuite/tests/driver/multipleHomeUnits/mhu-perf/genLargeHMU
=====================================
@@ -0,0 +1,54 @@
+#!/usr/bin/env bash
+# Generate $DEPTH layers of packages with $WIDTH modules on each layer
+# Every package on layer N depends on all the packages on layer N-1
+# unitTop imports all the units from the last layer
+DEPTH=8
+WIDTH=8
+for i in $(seq -w 1 $WIDTH); do
+ mkdir unit-p0M$i
+ echo "module DummyLevel0M$i where" > unit-p0M$i/DummyLevel0M$i.hs;
+ cat > unit-p0M$i/unit-p0M$i.cabal <<EOF
+name: unit-p0M$i
+version: 0.1.0.0
+build-type: Simple
+cabal-version: >=1.10
+library
+ default-language: Haskell2010
+ exposed-modules: DummyLevel0M$i
+ build-depends: base
+EOF
+done
+for l in $(seq 1 $DEPTH); do
+ for i in $(seq -w 1 $WIDTH); do
+ mkdir unit-p${l}M$i
+ cat > unit-p${l}M$i/unit-p${l}M$i.cabal <<EOF
+name: unit-p${l}M$i
+version: 0.1.0.0
+build-type: Simple
+cabal-version: >=1.10
+library
+ default-language: Haskell2010
+ exposed-modules: DummyLevel${l}M$i
+ build-depends: base
+EOF
+ echo "module DummyLevel${l}M$i where" > unit-p${l}M$i/DummyLevel${l}M$i.hs;
+ for j in $(seq -w 1 $WIDTH); do
+ echo " , unit-p$((l-1))M$j" >> unit-p${l}M$i/unit-p${l}M$i.cabal
+ echo "import DummyLevel$((l-1))M$j" >> unit-p${l}M$i/DummyLevel${l}M$i.hs;
+ done
+ done
+done
+mkdir top1
+echo "module Top1 where" > top1/Top1.hs
+echo "-package-db ./tmp.d -i -itop1 Top1 -this-unit-id unit-top1 -package base" > unitTop1;
+for j in $(seq -w 1 $WIDTH); do
+ echo "-package unit-p${DEPTH}M$j" >> unitTop1;
+ echo "import DummyLevel${DEPTH}M$j" >> top1/Top1.hs;
+done
+mkdir top2
+echo "module Top2 where" > top2/Top2.hs
+echo "-package-db ./tmp.d -i -itop2 Top2 -this-unit-id unit-top2 -package base" > unitTop2;
+for j in $(seq -w 2 $WIDTH); do
+ echo "-package unit-p${DEPTH}M$j" >> unitTop2;
+ echo "import DummyLevel${DEPTH}M$j" >> top2/Top2.hs;
+done
=====================================
testsuite/tests/driver/multipleHomeUnits/mhu-perf/mhu-perf.stderr
=====================================
@@ -0,0 +1,2 @@
+[1 of 2] Compiling Top1[unit-top1]
+[2 of 2] Compiling Top2[unit-top2]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0a5150feba5dbc75f32aac8b934314d33060df6b...0fcc5b8433fad7b479c21b270e96d9a1cd45c939
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0a5150feba5dbc75f32aac8b934314d33060df6b...0fcc5b8433fad7b479c21b270e96d9a1cd45c939
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240326/5003fea1/attachment-0001.html>
More information about the ghc-commits
mailing list