[Git][ghc/ghc][wip/romes/12935] 2 commits: Make UDSM oneshot deriving via state
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Fri Jul 5 15:42:31 UTC 2024
Rodrigo Mesquita pushed to branch wip/romes/12935 at Glasgow Haskell Compiler / GHC
Commits:
85339224 by Rodrigo Mesquita at 2024-07-05T16:42:21+01:00
Make UDSM oneshot deriving via state
- - - - -
1ccb91d2 by Rodrigo Mesquita at 2024-07-05T16:42:21+01:00
Put deterministic renaming behind a flag
- - - - -
6 changed files:
- compiler/GHC/Driver/Config/StgToCmm.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/StgToCmm.hs
- compiler/GHC/StgToCmm/Config.hs
- compiler/GHC/Types/Unique/DSM.hs
Changes:
=====================================
compiler/GHC/Driver/Config/StgToCmm.hs
=====================================
@@ -53,6 +53,7 @@ initStgToCmmConfig dflags mod = StgToCmmConfig
, stgToCmmExtDynRefs = gopt Opt_ExternalDynamicRefs dflags
, stgToCmmDoBoundsCheck = gopt Opt_DoBoundsChecking dflags
, stgToCmmDoTagCheck = gopt Opt_DoTagInferenceChecks dflags
+ , stgToCmmDeterministicObjs = gopt Opt_DeterministicObjects dflags
-- backend flags:
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -820,6 +820,9 @@ data GeneralFlag
-- Error message suppression
| Opt_ShowErrorContext
+ -- Object code determinism
+ | Opt_DeterministicObjects
+
-- temporary flags
| Opt_AutoLinkPackages
| Opt_ImplicitImportQualified
@@ -930,6 +933,7 @@ codeGenFlags = EnumSet.fromList
, Opt_ExposeAllUnfoldings
, Opt_ExposeOverloadedUnfoldings
, Opt_NoTypeableBinds
+ , Opt_DeterministicObjects
, Opt_Haddock
-- Flags that affect catching of runtime errors
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -1290,6 +1290,8 @@ dynamic_flags_deps = [
(NoArg (unSetGeneralFlag Opt_KeepOFiles))
------- Miscellaneous ----------------------------------------------
+ , make_ord_flag defGhcFlag "fdeterministic-objects"
+ (NoArg (setGeneralFlag Opt_DeterministicObjects))
, make_ord_flag defGhcFlag "no-auto-link-packages"
(NoArg (unSetGeneralFlag Opt_AutoLinkPackages))
, make_ord_flag defGhcFlag "no-hs-main"
=====================================
compiler/GHC/StgToCmm.hs
=====================================
@@ -103,7 +103,12 @@ codeGen logger tmpfs cfg (InfoTableProvMap (UniqMap denv) _ _) data_tycons
let
((a, cmm), st') = runC cfg fstate st (getCmm fcode)
- (rnm1, cmm_renamed) = detRenameUniques rnm0 cmm -- The yielded cmm will already be renamed.
+ (rnm1, cmm_renamed) =
+ -- Enable deterministic object code generation by
+ -- renaming uniques deterministically.
+ if stgToCmmDeterministicObjs cfg
+ then detRenameUniques rnm0 cmm -- The yielded cmm will already be renamed.
+ else (rnm0, cmm)
-- NB. stub-out cgs_tops and cgs_stmts. This fixes
-- a big space leak. DO NOT REMOVE!
@@ -152,7 +157,6 @@ codeGen logger tmpfs cfg (InfoTableProvMap (UniqMap denv) _ _) data_tycons
| otherwise
= mkNameEnv (Prelude.map extractInfo (nonDetEltsUFM cg_id_infos))
- -- if gopt Opt_DeterministicObjects dflags
; rn_mapping <- liftIO (readIORef uniqRnRef)
; liftIO $ debugTraceMsg logger 3 (text "DetRnM mapping:" <+> ppr rn_mapping)
=====================================
compiler/GHC/StgToCmm/Config.hs
=====================================
@@ -63,6 +63,7 @@ data StgToCmmConfig = StgToCmmConfig
, stgToCmmDoBoundsCheck :: !Bool -- ^ decides whether to check array bounds in StgToCmm.Prim
-- or not
, stgToCmmDoTagCheck :: !Bool -- ^ Verify tag inference predictions.
+ , stgToCmmDeterministicObjs :: !Bool -- ^ Enable deterministic code generation (more precisely, the deterministic unique-renaming pass in StgToCmm)
------------------------------ Backend Flags ----------------------------------
, stgToCmmAllowArith64 :: !Bool -- ^ Allowed to emit 64-bit arithmetic operations
, stgToCmmAllowQuot64 :: !Bool -- ^ Allowed to emit 64-bit division operations
=====================================
compiler/GHC/Types/Unique/DSM.hs
=====================================
@@ -1,10 +1,12 @@
-{-# LANGUAGE UnboxedTuples, PatternSynonyms #-}
+{-# LANGUAGE UnboxedTuples, PatternSynonyms, DerivingVia #-}
module GHC.Types.Unique.DSM where
+import GHC.Exts (oneShot)
import GHC.Prelude
import GHC.Word
import Control.Monad.Fix
import GHC.Types.Unique
+import qualified GHC.Utils.Monad.State.Strict as Strict
import qualified GHC.Types.Unique.Supply as USM
-- todo: Do I need to use the one-shot state monad trick? Probably yes.
@@ -24,29 +26,19 @@ 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 :: DUniqSupply -> DUniqResult result }
- deriving Functor
-
-instance Monad UniqDSM where
- (>>=) (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 (DUniqResult result)
- (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 $ \us0 -> case expr us0 of
- DUniqResult _ us1 -> cont us1
- {-# INLINE pure #-}
- {-# INLINE (*>) #-}
+newtype UniqDSM result = UDSM' { unUDSM :: DUniqSupply -> DUniqResult result }
+ deriving (Functor, Applicative, Monad) via (Strict.State DUniqSupply)
instance MonadFix UniqDSM where
mfix m = UDSM (\us0 -> let (r,us1) = runUniqueDSM us0 (m r) in DUniqResult r us1)
+-- See Note [The one-shot state monad trick] in GHC.Utils.Monad
+pattern UDSM :: (DUniqSupply -> DUniqResult a) -> UniqDSM a
+pattern UDSM m <- UDSM' m
+ where
+ UDSM m = UDSM' (oneShot $ \s -> m s)
+{-# COMPLETE UDSM #-}
+
getUniqueDSM :: UniqDSM Unique
getUniqueDSM = UDSM (\(DUS us0) -> DUniqResult (mkUniqueGrimily us0) (DUS $ us0+1))
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cd0282879ceda8f57f63b40a87b862a9301570ad...1ccb91d2e33d86377ef988c0dd1c8f33b5cfcf50
--
This project does not include diff previews in email notifications.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cd0282879ceda8f57f63b40a87b862a9301570ad...1ccb91d2e33d86377ef988c0dd1c8f33b5cfcf50
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/20240705/643a83bc/attachment-0001.html>
More information about the ghc-commits
mailing list