Skip to content

Instantly share code, notes, and snippets.

@mpickering

mpickering/gist:dcf6090ec736c76289a07a1880670f2c

Created June 28, 2024 12:16
Show Gist options
  • Save mpickering/dcf6090ec736c76289a07a1880670f2c to your computer and use it in GitHub Desktop.
Save mpickering/dcf6090ec736c76289a07a1880670f2c to your computer and use it in GitHub Desktop.
Download ZIP
Raw
gistfile1.txt
diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs
index aba2a577b98..fb1a32e8511 100644
--- a/compiler/GHC/Cmm/CLabel.hs
+++ b/compiler/GHC/Cmm/CLabel.hs
@@ -156,6 +156,7 @@ import GHC.Core.Ppr ( {- instances -} )
import GHC.Types.SrcLoc
import qualified Data.Semigroup as S
+import GHC.Stack(HasCallStack)
-- -----------------------------------------------------------------------------
-- The CLabel type
@@ -1853,7 +1854,7 @@ returns True.
-- renamed, eg uniques of local symbols or of system names.
-- See Note [....TODO]
-- ROMES:TODO: We can do less work here, like, do we really need to rename AsmTempLabel, SRTLabel, LocalBlockLabel?
-mapInternalNonDetUniques :: Applicative m => (Unique -> m Unique) -> CLabel -> m CLabel
+mapInternalNonDetUniques :: (HasCallStack, Applicative m) => (HasCallStack => Unique -> m Unique) -> CLabel -> m CLabel
mapInternalNonDetUniques f = \case
IdLabel name cafInfo idLabelInfo -> IdLabel . setNameUnique name <$> f (nameUnique name) <*> pure cafInfo <*> pure idLabelInfo
cl@CmmLabel{} -> pure cl
diff --git a/compiler/GHC/Cmm/Info.hs b/compiler/GHC/Cmm/Info.hs
index 05f3d3b6f2a..86addeb8982 100644
--- a/compiler/GHC/Cmm/Info.hs
+++ b/compiler/GHC/Cmm/Info.hs
@@ -68,7 +68,7 @@ mkEmptyContInfoTable info_lbl
cmmToRawCmm :: Logger -> Profile -> Stream IO CmmGroupSRTs a
-> IO (Stream IO RawCmmGroup a)
cmmToRawCmm logger profile cmms
- = do { detUqSupply <- newIORef (DUS 1)
+ = do { detUqSupply <- newIORef (initUniqDSupply 'i' 0)
; let do_one :: [CmmDeclSRTs] -> IO [RawCmmDecl]
do_one cmm = do
-- NB. strictness fixes a space leak. DO NOT REMOVE.
@@ -76,7 +76,7 @@ cmmToRawCmm logger profile cmms
-- We have to store the deterministic unique supply
-- to produce uniques across cmm decls.
nextUq <- readIORef detUqSupply
- let (a, us) = runUniqueDSM 'i' nextUq $ concatMapM (mkInfoTable profile) cmm
+ let (a, us) = runUniqueDSM nextUq $ concatMapM (mkInfoTable profile) cmm
writeIORef detUqSupply us
return a
; return (Stream.mapM do_one cmms)
diff --git a/compiler/GHC/Cmm/UniqueRenamer.hs b/compiler/GHC/Cmm/UniqueRenamer.hs
index ccc8914b7d4..b1c03466593 100644
--- a/compiler/GHC/Cmm/UniqueRenamer.hs
+++ b/compiler/GHC/Cmm/UniqueRenamer.hs
@@ -1,15 +1,14 @@
-{-# LANGUAGE LambdaCase, MagicHash, UnboxedTuples, PatternSynonyms, ExplicitNamespaces #-}
+{-# LANGUAGE LambdaCase, RecordWildCards, MagicHash, UnboxedTuples, PatternSynonyms, ExplicitNamespaces #-}
module GHC.Cmm.UniqueRenamer
( detRenameUniques
, UniqDSM, runUniqueDSM
- , DUniqSupply(..), getUniqueDSM
+ , DUniqSupply(..), getUniqueDSM, takeUniqueFromDSupply, initUniqDSupply
-- Careful! Not for general use!
, DetUniqFM, emptyDetUFM)
where
import Data.Bits
-import Prelude
import Control.Monad.Trans.State
import GHC.Word
import GHC.Cmm
@@ -26,6 +25,8 @@ import Data.Tuple (swap)
import qualified Data.Map as M
import qualified Data.Set as S
import GHC.Types.Id
+import GHC.Stack
+import GHC.Prelude
{-
--------------------------------------------------------------------------------
@@ -65,35 +66,42 @@ emptyDetUFM = DetUniqFM
, supply = 54
}
-renameDetUniq :: Unique -> DetRnM Unique
+renameDetUniq :: HasCallStack => Unique -> DetRnM Unique
renameDetUniq uq = do
m <- gets mapping
case lookupUFM m uq of
Nothing -> do
new_w <- gets supply -- New deterministic unique in this `DetRnM`
let (tag, _) = unpkUnique uq
- det_uniq = mkUnique tag new_w
+ det_uniq = mkUnique 'Q' new_w
modify' (\DetUniqFM{mapping, supply} ->
-- Update supply and mapping
DetUniqFM
{ mapping = addToUFM mapping uq det_uniq
, supply = supply + 1
})
+-- pprTraceM "renaming" (ppr uq <+> text "->" <+> ppr det_uniq <+> disp_stack callStack)
return det_uniq
Just det_uniq ->
return det_uniq
+disp_stack :: CallStack -> SDoc
+disp_stack st =
+ hsep (map (f . snd) (getCallStack st))
+ where
+ f (SrcLoc{..}) = text srcLocModule <> colon <> text (show srcLocStartLine)
+
-- Rename local symbols deterministically (in order of appearance)
-detRenameUniques :: UniqRenamable a => DetUniqFM -> a -> (DetUniqFM, a)
+detRenameUniques :: HasCallStack => UniqRenamable a => DetUniqFM -> a -> (DetUniqFM, a)
detRenameUniques dufm x = swap $ runState (uniqRename x) dufm
-- The most important function here, which does the actual renaming.
-- Arguably, maybe we should rename this to CLabelRenamer
-detRenameCLabel :: CLabel -> DetRnM CLabel
+detRenameCLabel :: HasCallStack => CLabel -> DetRnM CLabel
detRenameCLabel = mapInternalNonDetUniques renameDetUniq
-- | We want to rename uniques in Ids, but ONLY internal ones.
-detRenameId :: Id -> DetRnM Id
+detRenameId :: HasCallStack => Id -> DetRnM Id
detRenameId i = setIdUnique i <$> renameDetUniq (getUnique i)
--------------------------------------------------------------------------------
@@ -103,7 +111,7 @@ detRenameId i = setIdUnique i <$> renameDetUniq (getUnique i)
-- which would be cleaner
class UniqRenamable a where
- uniqRename :: a -> DetRnM a
+ uniqRename :: HasCallStack => a -> DetRnM a
instance UniqRenamable Unique where
uniqRename = renameDetUniq
@@ -296,33 +304,41 @@ pattern DUniqResult x y = (# x, y #)
-- | A monad which just gives the ability to obtain 'Unique's deterministically.
-- There's no splitting.
-newtype UniqDSM result = UDSM { unUDSM :: Word64 {- tag -} -> DUniqSupply -> DUniqResult result }
+newtype UniqDSM result = UDSM { unUDSM :: DUniqSupply -> DUniqResult result }
deriving Functor
instance Monad UniqDSM where
- (>>=) (UDSM f) cont = UDSM $ \tag us0 -> case f tag us0 of
- DUniqResult result us1 -> unUDSM (cont result) tag us1
+ (>>=) (UDSM f) cont = UDSM $ \us0 -> case f us0 of
+ DUniqResult result us1 -> unUDSM (cont result) us1
(>>) = (*>)
{-# INLINE (>>=) #-}
{-# INLINE (>>) #-}
instance Applicative UniqDSM where
- pure result = UDSM (\_tag us -> DUniqResult result us)
- (UDSM f) <*> (UDSM x) = UDSM $ \tag us0 -> case f tag us0 of
- DUniqResult ff us1 -> case x tag us1 of
+ pure result = UDSM (\us -> DUniqResult result us)
+ (UDSM f) <*> (UDSM x) = UDSM $ \us0 -> case f us0 of
+ DUniqResult ff us1 -> case x us1 of
DUniqResult xx us2 -> DUniqResult (ff xx) us2
- (*>) (UDSM expr) (UDSM cont) = UDSM $ \tag us0 -> case expr tag us0 of
- DUniqResult _ us1 -> cont tag us1
+ (*>) (UDSM expr) (UDSM cont) = UDSM $ \us0 -> case expr us0 of
+ DUniqResult _ us1 -> cont us1
{-# INLINE pure #-}
{-# INLINE (*>) #-}
getUniqueDSM :: UniqDSM Unique
-getUniqueDSM = UDSM (\tag (DUS us0) -> DUniqResult (mkUniqueGrimily $ tag .|. us0) (DUS $ us0+1))
+getUniqueDSM = UDSM (\(DUS us0) -> DUniqResult (mkUniqueGrimily $ us0) (DUS $ us0+1))
-runUniqueDSM :: Char {- tag -} -> DUniqSupply {- first unique -}
- -> UniqDSM a -> (a, DUniqSupply)
-runUniqueDSM c firstUniq (UDSM f) =
+takeUniqueFromDSupply :: DUniqSupply -> (Unique, DUniqSupply)
+takeUniqueFromDSupply d = case unUDSM getUniqueDSM d of
+ DUniqResult x y -> (x, y)
+
+initUniqDSupply :: Char -> Word64 -> DUniqSupply
+initUniqDSupply c firstUniq =
let !tag = mkTag c
- in case f tag firstUniq of
+ in DUS (tag .|. firstUniq)
+
+runUniqueDSM :: DUniqSupply {- first unique -}
+ -> UniqDSM a -> (a, DUniqSupply)
+runUniqueDSM ds (UDSM f) =
+ case f ds of
DUniqResult uq us -> (uq, us)
diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs
index 2e4bb29d4b2..e1556aece1d 100644
--- a/compiler/GHC/StgToCmm.hs
+++ b/compiler/GHC/StgToCmm.hs
@@ -62,7 +62,7 @@ import GHC.Data.Stream
import GHC.Data.OrdList
import GHC.Types.Unique.Map
-import Control.Monad (when,void, forM_)
+import Control.Monad (when,void, forM_, zipWithM_)
import GHC.Utils.Misc
import System.IO.Unsafe
import qualified Data.ByteString as BS
@@ -88,11 +88,13 @@ codeGen logger tmpfs cfg (InfoTableProvMap (UniqMap denv) _ _) data_tycons
-- allocations by 0.5-2%.
; cgref <- liftIO $ initC >>= \s -> newIORef s
; uniqRnRef <- liftIO $ newIORef emptyDetUFM
+ ; pprTraceM "here" (ppr (length stg_binds))
; let fstate = initFCodeState $ stgToCmmPlatform cfg
- ; let cg :: FCode a -> Stream IO CmmGroup a
- cg fcode = do
+ ; let cg :: FCode a -> Int -> Stream IO CmmGroup a
+ cg fcode n = do
(a, cmm) <- liftIO . withTimingSilent logger (text "STG -> Cmm") (`seq` ()) $ do
st <- readIORef cgref
+ pprTraceM "start 3" (ppr n <+> text "/" <+> ppr (length stg_binds))
-- To produce deterministic object code, we alpha-rename all Uniques to deterministic uniques before Cmm linting.
-- From here on out, the backend code generation can't use (non-deterministic) Uniques, or risk producing non-deterministic code.
@@ -102,39 +104,54 @@ codeGen logger tmpfs cfg (InfoTableProvMap (UniqMap denv) _ _) data_tycons
rnm0 <- readIORef uniqRnRef
let
- ((a, cmm), st') = runC cfg fstate st (getCmm fcode)
- (rnm1, cmm_renamed) = detRenameUniques rnm0 cmm -- The yielded cmm will already be renamed.
+ ((!a, !cmm), !st') = runC cfg fstate st (getCmm fcode)
+ (rnm1, cmm_renamed) =
+
+ pprTrace "start 5" (ppr n <+> text "/" <+> ppr (length stg_binds))
+ $ detRenameUniques rnm0 cmm -- The yielded cmm will already be renamed.
-- NB. stub-out cgs_tops and cgs_stmts. This fixes
-- a big space leak. DO NOT REMOVE!
-- This is observed by the #3294 test
writeIORef cgref $! (st'{ cgs_tops = nilOL, cgs_stmts = mkNop })
writeIORef uniqRnRef $! rnm1
+ pprTraceM "start 4" (ppr n <+> text "/" <+> ppr (length stg_binds))
return (a, cmm_renamed)
yield cmm
return a
- ; cg (mkModuleInit cost_centre_info (stgToCmmThisModule cfg) hpc_info)
+ ; pprTraceM "here 5" (ppr (length stg_binds))
+ ; cg (mkModuleInit cost_centre_info (stgToCmmThisModule cfg) hpc_info) 0
+
+ ; pprTraceM "here 4" (ppr (length stg_binds))
- ; mapM_ (cg . cgTopBinding logger tmpfs cfg) stg_binds
+ ; zipWithM_ (\b n -> (cg (cgTopBinding logger tmpfs cfg b) n)) stg_binds [0..]
-- Put datatype_stuff after code_stuff, because the
-- datatype closure table (for enumeration types) to
-- (say) PrelBase_True_closure, which is defined in
-- code_stuff
+
+ ; pprTraceM "here 3" (ppr (length stg_binds))
; let do_tycon tycon = do
-- Generate a table of static closures for an
-- enumeration type Note that the closure pointers are
-- tagged.
- when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon)
+ when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon) 0
-- Emit normal info_tables, for data constructors defined in this module.
- mapM_ (cg . cgDataCon DefinitionSite) (tyConDataCons tycon)
+ mapM_ (\b -> cg (cgDataCon DefinitionSite b) 0) (tyConDataCons tycon)
+
+
+ ; pprTraceM "here 2" empty
; mapM_ do_tycon data_tycons
+ ; pprTraceM "here 1" empty
+
-- Emit special info tables for everything used in this module
-- This will only do something if `-fdistinct-info-tables` is turned on.
- ; mapM_ (\(dc, ns) -> forM_ ns $ \(k, _ss) -> cg (cgDataCon (UsageSite (stgToCmmThisModule cfg) k) dc)) (nonDetEltsUFM denv)
+ -- MP: Surely non-deterministic
+ ; mapM_ (\(dc, ns) -> forM_ ns $ \(k, _ss) -> cg (cgDataCon (UsageSite (stgToCmmThisModule cfg) k) dc) 0) (nonDetEltsUFM denv)
; final_state <- liftIO (readIORef cgref)
; let cg_id_infos = cgs_binds final_state
@@ -174,7 +191,7 @@ style, with the increasing static environment being plumbed as a state
variable. -}
cgTopBinding :: Logger -> TmpFs -> StgToCmmConfig -> CgStgTopBinding -> FCode ()
-cgTopBinding logger tmpfs cfg = \case
+cgTopBinding logger tmpfs cfg b = case pprTrace "b" (pprStgTopBinding panicStgPprOpts b) b of
StgTopLifted (StgNonRec id rhs) -> do
let (info, fcode) = cgTopRhs cfg NonRecursive id rhs
fcode
diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs
index e0b2c81702b..0d1119f102e 100644
--- a/compiler/GHC/StgToCmm/Expr.hs
+++ b/compiler/GHC/StgToCmm/Expr.hs
@@ -64,6 +64,7 @@ import GHC.Platform.Profile (profileIsProfiling)
------------------------------------------------------------------------
cgExpr :: CgStgExpr -> FCode ReturnKind
+cgExpr e | pprTrace "cg_Expr" (ppr e) False = undefined
cgExpr (StgApp fun args) = cgIdApp fun args
@@ -998,7 +999,8 @@ cgAltRhss gc_plan bndr alts = do
-- see Note [Post-unarisation invariants] in GHC.Stg.Unarise
; _ <- cgExpr rhs
; return con }
- forkAlts (map cg_alt alts)
+ !res <- forkAlts (map cg_alt alts)
+ return (pprTrace "cg_alt_after" empty res)
maybeAltHeapCheck :: (GcPlan,ReturnKind) -> FCode a -> FCode a
maybeAltHeapCheck (NoGcInAlts,_) code = code
diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs
index 5d7358575fa..3e1942cb05b 100644
--- a/compiler/GHC/StgToCmm/Monad.hs
+++ b/compiler/GHC/StgToCmm/Monad.hs
@@ -94,6 +94,9 @@ import GHC.Exts (oneShot)
import Control.Monad
import Data.List (mapAccumL)
+import GHC.Cmm.UniqueRenamer
+import GHC.Stack
+
--------------------------------------------------------
-- The FCode monad and its types
@@ -165,13 +168,13 @@ instance Monad FCode where
{-# INLINE (>>=) #-}
instance MonadUnique FCode where
- getUniqueSupplyM = cgs_uniqs <$> getState
+ getUniqueSupplyM = error "undefined" --cgs_uniqs <$> getState
getUniqueM = FCode $ \_ _ st ->
- let (u, us') = takeUniqFromSupply (cgs_uniqs st)
+ let (u, us') = takeUniqueFromDSupply (cgs_uniqs st)
in (u, st { cgs_uniqs = us' })
initC :: IO CgState
-initC = do { uniqs <- mkSplitUniqSupply 'c'
+initC = do { let uniqs = initUniqDSupply 'c' 0
; return (initCgState uniqs) }
runC :: StgToCmmConfig -> FCodeState -> CgState -> FCode a -> (a, CgState)
@@ -290,7 +293,7 @@ data CgState
cgs_hp_usg :: HeapUsage,
- cgs_uniqs :: UniqSupply }
+ cgs_uniqs :: DUniqSupply }
-- If you are wondering why you have to be careful forcing CgState then
-- the reason is the knot-tying in 'getHeapUsage'. This problem is tracked
-- in #19245
@@ -348,7 +351,7 @@ Hp register. (Changing virtHp doesn't matter.)
-}
-initCgState :: UniqSupply -> CgState
+initCgState :: DUniqSupply -> CgState
initCgState uniqs
= MkCgState { cgs_stmts = mkNop
, cgs_tops = nilOL
@@ -368,7 +371,8 @@ addCodeBlocksFrom :: CgState -> CgState -> CgState
-- (The cgs_stmts will often be empty, but not always; see codeOnly)
s1 `addCodeBlocksFrom` s2
= s1 { cgs_stmts = cgs_stmts s1 CmmGraph.<*> cgs_stmts s2,
- cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 }
+ cgs_tops = cgs_tops s1 `appOL` cgs_tops s2,
+ cgs_uniqs = cgs_uniqs s2 }
-- The heap high water mark is the larger of virtHp and hwHp. The latter is
-- only records the high water marks of forked-off branches, so to find the
@@ -436,19 +440,17 @@ withCgState (FCode fcode) newstate = FCode $ \cfg fstate state ->
case fcode cfg fstate newstate of
(retval, state2) -> ((retval,state2), state)
+{-
newUniqSupply :: FCode UniqSupply
newUniqSupply = do
state <- getState
let (us1, us2) = splitUniqSupply (cgs_uniqs state)
setState $ state { cgs_uniqs = us1 }
return us2
+ -}
newUnique :: FCode Unique
-newUnique = do
- state <- getState
- let (u,us') = takeUniqFromSupply (cgs_uniqs state)
- setState $ state { cgs_uniqs = us' }
- return u
+newUnique = getUniqueM
newTemp :: MonadUnique m => CmmType -> m LocalReg
newTemp rep = do { uniq <- getUniqueM
@@ -578,13 +580,13 @@ forkClosureBody body_code
= do { platform <- getPlatform
; cfg <- getStgToCmmConfig
; fstate <- getFCodeState
- ; us <- newUniqSupply
; state <- getState
+ ; pprTraceM "forkClosureBody" empty
; let fcs = fstate { fcs_sequel = Return
, fcs_upframeoffset = platformWordSizeInBytes platform
, fcs_selfloop = Nothing
}
- fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
+ fork_state_in = (initCgState (cgs_uniqs state)) { cgs_binds = cgs_binds state }
((),fork_state_out) = doFCode body_code cfg fcs fork_state_in
; setState $ state `addCodeBlocksFrom` fork_state_out }
@@ -597,10 +599,9 @@ forkLneBody :: FCode a -> FCode a
-- code is discarded; it should deal with its own heap consumption.
forkLneBody body_code
= do { cfg <- getStgToCmmConfig
- ; us <- newUniqSupply
; state <- getState
; fstate <- getFCodeState
- ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
+ ; let fork_state_in = (initCgState (cgs_uniqs state)) { cgs_binds = cgs_binds state }
(result, fork_state_out) = doFCode body_code cfg fstate fork_state_in
; setState $ state `addCodeBlocksFrom` fork_state_out
; return result }
@@ -611,15 +612,14 @@ codeOnly :: FCode () -> FCode ()
-- Used in almost-circular code to prevent false loop dependencies
codeOnly body_code
= do { cfg <- getStgToCmmConfig
- ; us <- newUniqSupply
; state <- getState
; fstate <- getFCodeState
- ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state
+ ; let fork_state_in = (initCgState (cgs_uniqs state)) { cgs_binds = cgs_binds state
, cgs_hp_usg = cgs_hp_usg state }
((), fork_state_out) = doFCode body_code cfg fstate fork_state_in
; setState $ state `addCodeBlocksFrom` fork_state_out }
-forkAlts :: [FCode a] -> FCode [a]
+forkAlts :: forall a . HasCallStack => [FCode a] -> FCode [a]
-- (forkAlts' bs d) takes fcodes 'bs' for the branches of a 'case', and
-- an fcode for the default case 'd', and compiles each in the current
-- environment. The current environment is passed on unmodified, except
@@ -627,18 +627,22 @@ forkAlts :: [FCode a] -> FCode [a]
forkAlts branch_fcodes
= do { cfg <- getStgToCmmConfig
- ; us <- newUniqSupply
; state <- getState
; fstate <- getFCodeState
- ; let compile us branch
- = (us2, doFCode branch cfg fstate branch_state)
+ ; pprTraceM "forkAlts" (ppr (length branch_fcodes) $$ callStackDoc)
+ ; let
+ compile :: DUniqSupply -> FCode a -> (DUniqSupply, (a, CgState))
+ compile us branch =
+ case doFCode branch cfg fstate branch_state of
+ (res, state') -> (cgs_uniqs state', (res, state'))
where
- (us1,us2) = splitUniqSupply us
- branch_state = (initCgState us1) {
+ branch_state = (initCgState us) {
cgs_binds = cgs_binds state
, cgs_hp_usg = cgs_hp_usg state }
- (_us, results) = mapAccumL compile us branch_fcodes
+
+ (_us, results ) = mapAccumL compile (cgs_uniqs state) branch_fcodes
(branch_results, branch_out_states) = unzip results
+
; setState $ foldl' stateIncUsage state branch_out_states
-- NB foldl. state is the *left* argument to stateIncUsage
; return branch_results }
@@ -647,6 +651,7 @@ forkAltPair :: FCode a -> FCode a -> FCode (a,a)
-- Most common use of 'forkAlts'; having this helper function avoids
-- accidental use of failible pattern-matches in @do@-notation
forkAltPair x y = do
+ pprTraceM "forkAltPair" empty
xy' <- forkAlts [x,y]
case xy' of
[x',y'] -> return (x',y')
diff --git a/libraries/unix b/libraries/unix
--- a/libraries/unix
+++ b/libraries/unix
@@ -1 +1 @@
-Subproject commit 69552a5267c7dc5c46a8bceec5ec4b40d26b9463
+Subproject commit 69552a5267c7dc5c46a8bceec5ec4b40d26b9463-dirty
diff --git a/testsuite/tests/determinism/object/cabal.project b/testsuite/tests/determinism/object/cabal.project
index 9ec5f00c641..7581762e717 100644
--- a/testsuite/tests/determinism/object/cabal.project
+++ b/testsuite/tests/determinism/object/cabal.project
@@ -1 +1 @@
-packages: Cabal-3.12.0.0
+packages: Cabal-syntax-3.12.0.0
diff --git a/testsuite/tests/determinism/object/check-standalone.sh b/testsuite/tests/determinism/object/check-standalone.sh
index 8af92e064ad..111b3aa9062 100755
--- a/testsuite/tests/determinism/object/check-standalone.sh
+++ b/testsuite/tests/determinism/object/check-standalone.sh
@@ -7,7 +7,7 @@ then
fi
rm -rf objs1 objs2
-cabal get Cabal-3.12.0.0
-cabal build -w $1 --ghc-options="-fforce-recomp -j4" --ghc-options=-odir=out1 Cabal
-cabal build -w $1 --ghc-options="-fforce-recomp -j4" --ghc-options=-odir=out2 Cabal
-./check.sh darwin
+cabal get Cabal-syntax-3.12.0.0
+cabal build -w $1 --disable-executable-dynamic --disable-shared --ghc-options="-fforce-recomp -j1 -ddump-stg-final -ddump-cmm -ddump-asm -dumpdir=out1 -ddump-to-file" --ghc-options=-odir=out1 Cabal-syntax -v2 2>&1 | tee out1/log1
+#cabal build -w $1 --disable-executable-dynamic --disable-shared --ghc-options="-fforce-recomp -j1 -ddump-stg-final -dinitial-unique=4000000000 -dunique-increment=-1 -ddump-cmm -ddump-asm -dumpdir=out2 -ddump-to-file" --ghc-options=-odir=out2 Cabal-syntax 2>&1 | tee out2/log1
+./check.sh linux
diff --git a/testsuite/tests/determinism/object/check.sh b/testsuite/tests/determinism/object/check.sh
index eff1dbefb37..a892a9a399e 100755
--- a/testsuite/tests/determinism/object/check.sh
+++ b/testsuite/tests/determinism/object/check.sh
@@ -18,8 +18,8 @@ fi
# Guarantee object files were written
-S1=`find Cabal-3.12.0.0/out1 -name "*.o" | wc -l`
-S2=`find Cabal-3.12.0.0/out2 -name "*.o" | wc -l`
+S1=`find Cabal-syntax-3.12.0.0/out1 -name "*.o" | wc -l`
+S2=`find Cabal-syntax-3.12.0.0/out2 -name "*.o" | wc -l`
test $S1 > 0
test $S1 == $S2
@@ -32,15 +32,15 @@ compareObjs() {
echo $OBJDUMP $2 $o
echo "--------------------------------------------------------------------------------"
# Compare the object dumps except for the first line which prints the file path
- $OBJDUMP $2 Cabal-3.12.0.0/out1/$o | tail -n+2 > dump1
- $OBJDUMP $2 Cabal-3.12.0.0/out2/$o | tail -n+2 > dump2
+ $OBJDUMP $2 Cabal-syntax-3.12.0.0/out1/$o | tail -n+2 > dump1
+ $OBJDUMP $2 Cabal-syntax-3.12.0.0/out2/$o | tail -n+2 > dump2
diff dump1 dump2 && echo "OK"
echo "--------------------------------------------------------------------------------"
done
}
# Big fast check
-if diff -r Cabal-3.12.0.0/out1 Cabal-3.12.0.0/out2
+if diff -r Cabal-syntax-3.12.0.0/out1 Cabal-syntax-3.12.0.0/out2
then
echo "OK"
else
@@ -49,7 +49,7 @@ else
echo "--------------------------------------------------------------------------------"
- pushd Cabal-3.12.0.0/out1 >/dev/null
+ pushd Cabal-syntax-3.12.0.0/out1 >/dev/null
OBJS=$(find . -type f)
popd >/dev/null
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment