From 55618dc5b01f95f3ade673c21b97ae87d00d95d0 Mon Sep 17 00:00:00 2001 From: Pascal Ellinger Date: Mon, 1 Aug 2022 15:49:48 +0200 Subject: [PATCH 01/17] Add primitive and haskell-transients libraries --- .gitmodules | 8 ++++++++ compiler/ghc.cabal.in | 3 ++- hadrian/src/Packages.hs | 11 +++++++---- hadrian/src/Settings/Default.hs | 2 ++ libraries/haskell-transients | 1 + libraries/primitive | 1 + packages | 2 ++ 7 files changed, 23 insertions(+), 5 deletions(-) create mode 160000 libraries/haskell-transients create mode 160000 libraries/primitive diff --git a/.gitmodules b/.gitmodules index c44e7335e59e..a3b365fb3c0e 100644 --- a/.gitmodules +++ b/.gitmodules @@ -110,3 +110,11 @@ [submodule "libraries/exceptions"] path = libraries/exceptions url = https://gitlab.haskell.org/ghc/packages/exceptions.git +[submodule "libraries/primitive"] + path = libraries/primitive + url = https://github.com/haskell/primitive.git + ignore = untracked +[submodule "libraries/haskell-transients"] + path = libraries/haskell-transients + url = https://github.com/PascEll/haskell-transients.git + ignore = untracked diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index dc6de716f785..c188d3384c94 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -93,7 +93,8 @@ Library stm, ghc-boot == @ProjectVersionMunged@, ghc-heap == @ProjectVersionMunged@, - ghci == @ProjectVersionMunged@ + ghci == @ProjectVersionMunged@, + haskell-transients if os(windows) Build-Depends: Win32 >= 2.3 && < 2.13 diff --git a/hadrian/src/Packages.hs b/hadrian/src/Packages.hs index d1b49c35b178..d2dab0db9efa 100644 --- a/hadrian/src/Packages.hs +++ b/hadrian/src/Packages.hs @@ -6,7 +6,7 @@ module Packages ( compareSizes, compiler, containers, deepseq, deriveConstants, directory, exceptions, filepath, genapply, genprimopcode, ghc, ghcBignum, ghcBoot, ghcBootTh, ghcCompact, ghcConfig, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline, - hsc2hs, hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, iservProxy, + haskellTransients, hsc2hs, hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, iservProxy, libffi, libiserv, mtl, parsec, pretty, primitive, process, remoteIserv, rts, runGhc, stm, templateHaskell, terminfo, text, time, timeout, touchy, transformers, unlit, unix, win32, xhtml, @@ -37,9 +37,10 @@ ghcPackages = [ array, base, binary, bytestring, cabalSyntax, cabal, checkPpr, checkExact, countDeps , compareSizes, compiler, containers, deepseq, deriveConstants, directory , exceptions, filepath, genapply, genprimopcode, ghc, ghcBignum, ghcBoot, ghcBootTh - , ghcCompact, ghcConfig, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline, hsc2hs + , ghcCompact, ghcConfig, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline + , haskellTransients, hsc2hs , hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, libffi, libiserv, mtl - , parsec, pretty, process, rts, runGhc, stm, templateHaskell + , parsec, pretty, primitive, process, rts, runGhc, stm, templateHaskell , terminfo, text, time, touchy, transformers, unlit, unix, win32, xhtml , timeout , lintersCommon @@ -53,7 +54,8 @@ isGhcPackage = (`elem` ghcPackages) array, base, binary, bytestring, cabalSyntax, cabal, checkPpr, checkExact, countDeps, compareSizes, compiler, containers, deepseq, deriveConstants, directory, exceptions, filepath, genapply, genprimopcode, ghc, ghcBignum, ghcBoot, ghcBootTh, - ghcCompact, ghcConfig, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline, hsc2hs, + ghcCompact, ghcConfig, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline, + haskellTransients, hsc2hs, hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, iservProxy, remoteIserv, libffi, libiserv, mtl, parsec, pretty, primitive, process, rts, runGhc, stm, templateHaskell, terminfo, text, time, touchy, transformers, unlit, unix, win32, xhtml, @@ -93,6 +95,7 @@ ghcPkg = util "ghc-pkg" ghcPrim = lib "ghc-prim" haddock = util "haddock" haskeline = lib "haskeline" +haskellTransients = lib "haskell-transients" hsc2hs = util "hsc2hs" hp2ps = util "hp2ps" hpc = lib "hpc" diff --git a/hadrian/src/Settings/Default.hs b/hadrian/src/Settings/Default.hs index ae9ea2ce81bc..360ae2e1442d 100644 --- a/hadrian/src/Settings/Default.hs +++ b/hadrian/src/Settings/Default.hs @@ -88,11 +88,13 @@ stage0Packages = do , ghci , ghcPkg , haddock + , haskellTransients , hsc2hs , hpc , hpcBin , mtl , parsec + , primitive , time , templateHaskell , text diff --git a/libraries/haskell-transients b/libraries/haskell-transients new file mode 160000 index 000000000000..02c1df15c6ec --- /dev/null +++ b/libraries/haskell-transients @@ -0,0 +1 @@ +Subproject commit 02c1df15c6ec13c23c1619dc131972f63889ed69 diff --git a/libraries/primitive b/libraries/primitive new file mode 160000 index 000000000000..c44216fb2fc9 --- /dev/null +++ b/libraries/primitive @@ -0,0 +1 @@ +Subproject commit c44216fb2fc9d889a80ea16f913f8c78b5501278 diff --git a/packages b/packages index ad4f529c0340..78f30beb37d9 100644 --- a/packages +++ b/packages @@ -67,4 +67,6 @@ libraries/xhtml - - https:/ libraries/exceptions - - https://github.com/ekmett/exceptions.git nofib nofib - - libraries/stm - - ssh://git@github.com/haskell/stm.git +libraries/primitive - - https://github.com/haskell/primitive.git +libraries/haskell-transients - - - . - ghc.git - From 54e66de2212aa9209f5b16830d6a74585f96db3b Mon Sep 17 00:00:00 2001 From: Pascal Ellinger Date: Tue, 2 Aug 2022 08:45:38 +0200 Subject: [PATCH 02/17] Replace the VarSet in InScopeSet with a WordMap --- compiler/GHC/Types/Unique/FM.hs | 4 ++ compiler/GHC/Types/Unique/Set.hs | 4 ++ compiler/GHC/Types/Var/Env.hs | 105 ++++++++++++++++++++++++------- 3 files changed, 89 insertions(+), 24 deletions(-) diff --git a/compiler/GHC/Types/Unique/FM.hs b/compiler/GHC/Types/Unique/FM.hs index 8f9673159901..82073224375b 100644 --- a/compiler/GHC/Types/Unique/FM.hs +++ b/compiler/GHC/Types/Unique/FM.hs @@ -40,6 +40,7 @@ module GHC.Types.Unique.FM ( listToUFM_Directly, listToUFM_C, listToIdentityUFM, + ascListToUFM, addToUFM,addToUFM_C,addToUFM_Acc, addListToUFM,addListToUFM_C, addToUFM_Directly, @@ -151,6 +152,9 @@ listToUFM_C -> UniqFM key elt listToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v) emptyUFM +ascListToUFM :: Uniquable key => [(key, elt)] -> UniqFM key elt +ascListToUFM l = UFM (M.fromAscList (map (\(k, v) -> (getKey $ getUnique k, v)) l)) + addToUFM :: Uniquable key => UniqFM key elt -> key -> elt -> UniqFM key elt addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m) diff --git a/compiler/GHC/Types/Unique/Set.hs b/compiler/GHC/Types/Unique/Set.hs index 88e56f9e44a8..7485998fe8ff 100644 --- a/compiler/GHC/Types/Unique/Set.hs +++ b/compiler/GHC/Types/Unique/Set.hs @@ -21,6 +21,7 @@ module GHC.Types.Unique.Set ( emptyUniqSet, unitUniqSet, mkUniqSet, + mkUniqSetFromAscList, addOneToUniqSet, addListToUniqSet, delOneFromUniqSet, delOneFromUniqSet_Directly, delListFromUniqSet, delListFromUniqSet_Directly, @@ -75,6 +76,9 @@ unitUniqSet x = UniqSet $ unitUFM x x mkUniqSet :: Uniquable a => [a] -> UniqSet a mkUniqSet = foldl' addOneToUniqSet emptyUniqSet +mkUniqSetFromAscList :: Uniquable a => [a] -> UniqSet a +mkUniqSetFromAscList l = UniqSet (ascListToUFM (map (\x -> (x, x)) l)) + addOneToUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a addOneToUniqSet (UniqSet set) x = UniqSet (addToUFM set x x) diff --git a/compiler/GHC/Types/Var/Env.hs b/compiler/GHC/Types/Var/Env.hs index 02d3fa2ad54f..86c10997c38f 100644 --- a/compiler/GHC/Types/Var/Env.hs +++ b/compiler/GHC/Types/Var/Env.hs @@ -91,6 +91,65 @@ import GHC.Utils.Panic import GHC.Data.Maybe import GHC.Utils.Outputable +import Control.Monad +import Control.Monad.ST +import Data.Word +import WordMap + +newtype FastVarSet = FastVarSet (WordMap Var) + +varToKey :: Var -> Word64 +varToKey = fromIntegral . getKey . getUnique + +varSetToAscList :: VarSet -> [(Int, Var)] +varSetToAscList = IntMap.toAscList . ufmToIntMap . getUniqSet + +emptyFastVarSet :: FastVarSet +emptyFastVarSet = FastVarSet WordMap.empty + +extendFastVarSet :: FastVarSet -> Var -> FastVarSet +extendFastVarSet (FastVarSet set) var = FastVarSet (insert (varToKey var) var set) + +extendFastVarSetList :: Foldable f => FastVarSet -> f Var -> FastVarSet +extendFastVarSetList (FastVarSet set) vars = FastVarSet $ runST $ do + tmap <- foldM (\map var -> insertT (varToKey var) var map) (transient set) vars + persistent tmap + +extendFastVarSetSet :: FastVarSet -> VarSet -> FastVarSet +extendFastVarSetSet (FastVarSet set1) set2 + = FastVarSet (extendFromAscList (map intKeyToWordKey $ varSetToAscList set2) set1) + where + intKeyToWordKey (k, v) = (fromIntegral k, v) + +delFastVarSet :: FastVarSet -> Var -> FastVarSet +delFastVarSet (FastVarSet set) var = FastVarSet (delete (varToKey var) set) + +elemFastVarSet :: Var -> FastVarSet -> Bool +elemFastVarSet var (FastVarSet set) = isJust (WordMap.lookup (varToKey var) set) + +lookupFastVarSet :: FastVarSet -> Var -> Maybe Var +lookupFastVarSet (FastVarSet set) var = WordMap.lookup (varToKey var) set + +lookupFastVarSet_Directly :: FastVarSet -> Unique -> Maybe Var +lookupFastVarSet_Directly (FastVarSet set) uniq = WordMap.lookup (fromIntegral $ getKey uniq) set + +unionFastVarSet :: FastVarSet -> FastVarSet -> FastVarSet +-- WordMap.union is left-biased, unionFastVarSet should be right-biased. +unionFastVarSet (FastVarSet set1) (FastVarSet set2) = FastVarSet (union set2 set1) + +subFastVarSet :: VarSet -> FastVarSet -> Bool +subFastVarSet set1 (FastVarSet set2) + = let keys1 = map (fromIntegral . fst) $ varSetToAscList set1 + keys2 = map fst $ WordMap.toList set2 + in go keys1 keys2 + where + go [] _ = True + go _ [] = False + go (k1 : ks1) (k2 : ks2) + | k1 < k2 = False + | k1 == k2 = go ks1 ks2 + | otherwise = go (k1 : ks1) ks2 + {- ************************************************************************ * * @@ -106,7 +165,7 @@ import GHC.Utils.Outputable -- -- "Secrets of the Glasgow Haskell Compiler inliner" Section 3.2 provides -- the motivation for this abstraction. -newtype InScopeSet = InScope VarSet +newtype InScopeSet = InScope FastVarSet -- Note [Lookups in in-scope set] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- We store a VarSet here, but we use this for lookups rather than just @@ -129,58 +188,56 @@ newtype InScopeSet = InScope VarSet -- See "Secrets of the Glasgow Haskell Compiler inliner" Section 3.2 -- for more detailed motivation. #20419 has further discussion. - instance Outputable InScopeSet where - ppr (InScope s) = + ppr (InScope (FastVarSet s)) = text "InScope" <+> - braces (fsep (map (ppr . Var.varName) (nonDetEltsUniqSet s))) - -- It's OK to use nonDetEltsUniqSet here because it's - -- only for pretty printing - -- In-scope sets get big, and with -dppr-debug - -- the output is overwhelming + braces (fsep (map (ppr . Var.varName . snd) (toList s))) emptyInScopeSet :: InScopeSet -emptyInScopeSet = InScope emptyVarSet +emptyInScopeSet = InScope emptyFastVarSet -getInScopeVars :: InScopeSet -> VarSet -getInScopeVars (InScope vs) = vs +getInScopeVars :: InScopeSet -> VarSet +getInScopeVars (InScope (FastVarSet vs)) = mkUniqSetFromAscList (map snd $ WordMap.toList vs) mkInScopeSet :: VarSet -> InScopeSet -mkInScopeSet in_scope = InScope in_scope +mkInScopeSet in_scope + = InScope (FastVarSet (WordMap.fromAscList $ map intKeyToWordKey $ varSetToAscList in_scope)) + where + intKeyToWordKey (k, v) = (fromIntegral k, v) extendInScopeSet :: InScopeSet -> Var -> InScopeSet extendInScopeSet (InScope in_scope) v - = InScope (extendVarSet in_scope v) + = InScope (extendFastVarSet in_scope v) extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet extendInScopeSetList (InScope in_scope) vs - = InScope $ foldl' extendVarSet in_scope vs + = InScope (extendFastVarSetList in_scope vs) extendInScopeSetSet :: InScopeSet -> VarSet -> InScopeSet extendInScopeSetSet (InScope in_scope) vs - = InScope (in_scope `unionVarSet` vs) + = InScope (extendFastVarSetSet in_scope vs) delInScopeSet :: InScopeSet -> Var -> InScopeSet -delInScopeSet (InScope in_scope) v = InScope (in_scope `delVarSet` v) +delInScopeSet (InScope in_scope) v = InScope (in_scope `delFastVarSet` v) elemInScopeSet :: Var -> InScopeSet -> Bool -elemInScopeSet v (InScope in_scope) = v `elemVarSet` in_scope +elemInScopeSet v (InScope in_scope) = v `elemFastVarSet` in_scope -- | Look up a variable the 'InScopeSet'. This lets you map from -- the variable's identity (unique) to its full value. lookupInScope :: InScopeSet -> Var -> Maybe Var -lookupInScope (InScope in_scope) v = lookupVarSet in_scope v +lookupInScope (InScope in_scope) v = lookupFastVarSet in_scope v lookupInScope_Directly :: InScopeSet -> Unique -> Maybe Var lookupInScope_Directly (InScope in_scope) uniq - = lookupVarSet_Directly in_scope uniq + = lookupFastVarSet_Directly in_scope uniq unionInScope :: InScopeSet -> InScopeSet -> InScopeSet unionInScope (InScope s1) (InScope s2) - = InScope (s1 `unionVarSet` s2) + = InScope (s1 `unionFastVarSet` s2) varSetInScope :: VarSet -> InScopeSet -> Bool -varSetInScope vars (InScope s1) = vars `subVarSet` s1 +varSetInScope vars (InScope s1) = vars `subFastVarSet` s1 {- Note [Local uniques] @@ -221,9 +278,9 @@ uniqAway' in_scope var -- given 'InScopeSet'. This must be used very carefully since one can very easily -- introduce non-unique 'Unique's this way. See Note [Local uniques]. unsafeGetFreshLocalUnique :: InScopeSet -> Unique -unsafeGetFreshLocalUnique (InScope set) - | Just (uniq,_) <- IntMap.lookupLT (getKey maxLocalUnique) (ufmToIntMap $ getUniqSet set) - , let uniq' = mkLocalUnique uniq +unsafeGetFreshLocalUnique (InScope (FastVarSet set)) + | Just (uniq,_) <- WordMap.lookupLT (fromIntegral $ getKey maxLocalUnique) set + , let uniq' = mkLocalUnique (fromIntegral uniq) , not $ uniq' `ltUnique` minLocalUnique = incrUnique uniq' From 8eb6431bcfa9e690db1821a63506d292ee340fd3 Mon Sep 17 00:00:00 2001 From: Pascal Ellinger Date: Tue, 23 Aug 2022 21:33:13 +0200 Subject: [PATCH 03/17] Add a transient version of the InScopeSet --- compiler/GHC/Types/Var/Env.hs | 118 ++++++++++++++++++++++++++++++++++ libraries/haskell-transients | 2 +- 2 files changed, 119 insertions(+), 1 deletion(-) diff --git a/compiler/GHC/Types/Var/Env.hs b/compiler/GHC/Types/Var/Env.hs index 86c10997c38f..183025845f40 100644 --- a/compiler/GHC/Types/Var/Env.hs +++ b/compiler/GHC/Types/Var/Env.hs @@ -56,6 +56,17 @@ module GHC.Types.Var.Env ( unionInScope, elemInScopeSet, uniqAway, varSetInScope, unsafeGetFreshLocalUnique, + transientInScopeSet, + + -- * The transient TInScopeSet type + TInScopeSet, + + -- ** Operations on InScopeSets + emptyTInScopeSet, mkTInScopeSet, delTInScopeSet, + extendTInScopeSet, extendTInScopeSetList, extendTInScopeSetSet, + lookupTInScope, + unionTInScope, elemTInScopeSet, uniqAwayT, + persistentInScopeSet, -- * The RnEnv2 type RnEnv2, @@ -150,6 +161,38 @@ subFastVarSet set1 (FastVarSet set2) | k1 == k2 = go ks1 ks2 | otherwise = go (k1 : ks1) ks2 + +newtype TFastVarSet s = TFastVarSet (TWordMap s Var) + +emptyTFastVarSet :: TFastVarSet s +emptyTFastVarSet = TFastVarSet WordMap.emptyT + +extendTFastVarSet :: TFastVarSet s -> Var -> ST s (TFastVarSet s) +extendTFastVarSet (TFastVarSet set) var = TFastVarSet <$> insertT (varToKey var) var set + +extendTFastVarSetList :: Foldable f => TFastVarSet s -> f Var -> ST s (TFastVarSet s) +extendTFastVarSetList (TFastVarSet set) vars + = TFastVarSet <$> foldM (\map var -> insertT (varToKey var) var map) set vars + +extendTFastVarSetSet :: TFastVarSet s -> VarSet -> ST s (TFastVarSet s) +extendTFastVarSetSet (TFastVarSet set1) set2 + = TFastVarSet <$> extendFromAscListT (map intKeyToWordKey $ varSetToAscList set2) set1 + where + intKeyToWordKey (k, v) = (fromIntegral k, v) + +delTFastVarSet :: TFastVarSet s -> Var -> ST s (TFastVarSet s) +delTFastVarSet (TFastVarSet set) var = TFastVarSet <$> deleteT (varToKey var) set + +elemTFastVarSet :: Var -> TFastVarSet s -> ST s Bool +elemTFastVarSet var (TFastVarSet set) = isJust <$> (WordMap.lookupT (varToKey var) set) + +lookupTFastVarSet :: TFastVarSet s -> Var -> ST s (Maybe Var) +lookupTFastVarSet (TFastVarSet set) var = WordMap.lookupT (varToKey var) set + +unionTFastVarSet :: TFastVarSet s -> TFastVarSet s -> ST s (TFastVarSet s) +-- WordMap.unionT is left-biased, unionTFastVarSet should be right-biased. +unionTFastVarSet (TFastVarSet set1) (TFastVarSet set2) = TFastVarSet <$> unionT set2 set1 + {- ************************************************************************ * * @@ -239,6 +282,53 @@ unionInScope (InScope s1) (InScope s2) varSetInScope :: VarSet -> InScopeSet -> Bool varSetInScope vars (InScope s1) = vars `subFastVarSet` s1 + +newtype TInScopeSet s = TInScope (TFastVarSet s) + +emptyTInScopeSet :: TInScopeSet s +emptyTInScopeSet = TInScope emptyTFastVarSet + +mkTInScopeSet :: VarSet -> ST s (TInScopeSet s) +mkTInScopeSet in_scope = do + tmap <- WordMap.fromAscListT $ map intKeyToWordKey $ varSetToAscList in_scope + return $ TInScope (TFastVarSet tmap) + where + intKeyToWordKey (k, v) = (fromIntegral k, v) + +extendTInScopeSet :: TInScopeSet s -> Var -> ST s (TInScopeSet s) +extendTInScopeSet (TInScope in_scope) v + = TInScope <$> (extendTFastVarSet in_scope v) + +extendTInScopeSetList :: TInScopeSet s -> [Var] -> ST s (TInScopeSet s) +extendTInScopeSetList (TInScope in_scope) vs + = TInScope <$> (extendTFastVarSetList in_scope vs) + +extendTInScopeSetSet :: TInScopeSet s -> VarSet -> ST s (TInScopeSet s) +extendTInScopeSetSet (TInScope in_scope) vs + = TInScope <$> (extendTFastVarSetSet in_scope vs) + +delTInScopeSet :: TInScopeSet s -> Var -> ST s (TInScopeSet s) +delTInScopeSet (TInScope in_scope) v = TInScope <$> (in_scope `delTFastVarSet` v) + +elemTInScopeSet :: Var -> TInScopeSet s -> ST s Bool +elemTInScopeSet v (TInScope in_scope) = v `elemTFastVarSet` in_scope + +lookupTInScope :: TInScopeSet s -> Var -> ST s (Maybe Var) +lookupTInScope (TInScope in_scope) v = lookupTFastVarSet in_scope v + +unionTInScope :: TInScopeSet s -> TInScopeSet s -> ST s (TInScopeSet s) +unionTInScope (TInScope s1) (TInScope s2) + = TInScope <$> (s1 `unionTFastVarSet` s2) + + +transientInScopeSet :: InScopeSet -> TInScopeSet s +transientInScopeSet (InScope (FastVarSet in_scope)) + = TInScope (TFastVarSet (transient in_scope)) + +persistentInScopeSet :: TInScopeSet s -> ST s (InScopeSet) +persistentInScopeSet (TInScope (TFastVarSet in_scope)) + = InScope . FastVarSet <$> persistent in_scope + {- Note [Local uniques] ~~~~~~~~~~~~~~~~~~~~ @@ -287,6 +377,34 @@ unsafeGetFreshLocalUnique (InScope (FastVarSet set)) | otherwise = minLocalUnique +-- | @uniqAwayT in_scope v@ finds a unique that is not used in the +-- in-scope set, and gives that to v. See Note [Local uniques] and +-- Note [The InScopeSet invariant]. +uniqAwayT :: TInScopeSet s -> Var -> ST s Var +uniqAwayT in_scope var = do + elemInScope <- var `elemTInScopeSet` in_scope + if elemInScope + then uniqAwayT' in_scope var -- Make a new one + else return var -- Nothing to do + +uniqAwayT' :: TInScopeSet s -> Var -> ST s Var +-- This one *always* makes up a new variable +uniqAwayT' in_scope var + = setVarUnique var <$> unsafeGetFreshLocalUniqueT in_scope + +-- | @unsafeGetFreshUniqueT in_scope@ finds a unique that is not in-scope in the +-- given 'InScopeSet'. This must be used very carefully since one can very easily +-- introduce non-unique 'Unique's this way. See Note [Local uniques]. +unsafeGetFreshLocalUniqueT :: TInScopeSet s -> ST s Unique +unsafeGetFreshLocalUniqueT (TInScope (TFastVarSet set)) = do + mb_uniq <- WordMap.lookupLTT (fromIntegral $ getKey maxLocalUnique) set + case mb_uniq of + Just (uniq,_) + | let uniq' = mkLocalUnique (fromIntegral uniq) + , not $ uniq' `ltUnique` minLocalUnique + -> return $! incrUnique uniq' + _ -> return minLocalUnique + {- ************************************************************************ * * diff --git a/libraries/haskell-transients b/libraries/haskell-transients index 02c1df15c6ec..0a6e94757399 160000 --- a/libraries/haskell-transients +++ b/libraries/haskell-transients @@ -1 +1 @@ -Subproject commit 02c1df15c6ec13c23c1619dc131972f63889ed69 +Subproject commit 0a6e947573993d79833f6f9027513c91b94a8823 From 06373854414c17cd8b52b2752ab9cb55be33e785 Mon Sep 17 00:00:00 2001 From: Pascal Ellinger Date: Tue, 23 Aug 2022 22:35:06 +0200 Subject: [PATCH 04/17] Use the TInScopeSet in substTyVarBndrs and substVarBndrs --- compiler/GHC/Core/TyCo/Subst.hs | 94 +++++++++++++++++++++++++++++++-- 1 file changed, 91 insertions(+), 3 deletions(-) diff --git a/compiler/GHC/Core/TyCo/Subst.hs b/compiler/GHC/Core/TyCo/Subst.hs index 7322ff5e0373..b1ff5849b0a5 100644 --- a/compiler/GHC/Core/TyCo/Subst.hs +++ b/compiler/GHC/Core/TyCo/Subst.hs @@ -76,6 +76,7 @@ import GHC.Types.Var.Env import GHC.Data.Pair import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc +import GHC.Utils.Monad import GHC.Types.Unique.Supply import GHC.Types.Unique import GHC.Types.Unique.FM @@ -84,7 +85,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import Data.List (mapAccumL) +import Control.Monad.ST {- %************************************************************************ @@ -117,6 +118,11 @@ data TCvSubst -- and Note [Substituting types and coercions] -- and Note [The substitution invariant] +data TTCvSubst s + = TTCvSubst (TInScopeSet s) + TvSubstEnv + CvSubstEnv + -- | A substitution of 'Type's for 'TyVar's -- and 'Kind's for 'KindVar's type TvSubstEnv = TyVarEnv Type @@ -467,6 +473,15 @@ zipCoEnv cvs cos | otherwise = mkVarEnv (zipEqual "zipCoEnv" cvs cos) +transientTCvSubst :: TCvSubst -> TTCvSubst s +transientTCvSubst (TCvSubst in_scope tenv cenv) + = TTCvSubst (transientInScopeSet in_scope) tenv cenv + +persistentTCvSubst :: TTCvSubst s -> ST s TCvSubst +persistentTCvSubst (TTCvSubst in_scope tenv cenv) = do + persistent_in_scope <- persistentInScopeSet in_scope + return (TCvSubst persistent_in_scope tenv cenv) + instance Outputable TCvSubst where ppr (TCvSubst ins tenv cenv) = brackets $ sep[ text "TCvSubst", @@ -950,14 +965,32 @@ lookupCoVar (TCvSubst _ _ cenv) v = lookupVarEnv cenv v substTyVarBndr :: HasDebugCallStack => TCvSubst -> TyVar -> (TCvSubst, TyVar) substTyVarBndr = substTyVarBndrUsing substTy +substTyVarBndrT :: HasDebugCallStack => TTCvSubst s -> TyVar -> ST s (TTCvSubst s, TyVar) +substTyVarBndrT = substTyVarBndrUsingT substTy + substTyVarBndrs :: HasDebugCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar]) -substTyVarBndrs = mapAccumL substTyVarBndr +substTyVarBndrs subst tvs = runST $ do + (subst', tvs') <- substTyVarBndrsT (transientTCvSubst subst) tvs + persistent_subst <- persistentTCvSubst subst' + return (persistent_subst, tvs') + +substTyVarBndrsT :: HasDebugCallStack => TTCvSubst s -> [TyVar] -> ST s (TTCvSubst s, [TyVar]) +substTyVarBndrsT = mapAccumLM substTyVarBndrT substVarBndr :: HasDebugCallStack => TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) substVarBndr = substVarBndrUsing substTy +substVarBndrT :: HasDebugCallStack => TTCvSubst s -> TyCoVar -> ST s (TTCvSubst s, TyCoVar) +substVarBndrT = substVarBndrUsingT substTy + substVarBndrs :: HasDebugCallStack => TCvSubst -> [TyCoVar] -> (TCvSubst, [TyCoVar]) -substVarBndrs = mapAccumL substVarBndr +substVarBndrs subst vs = runST $ do + (subst', vs') <- substVarBndrsT (transientTCvSubst subst) vs + persistent_subst <- persistentTCvSubst subst' + return (persistent_subst, vs') + +substVarBndrsT :: HasDebugCallStack => TTCvSubst s -> [TyCoVar] -> ST s (TTCvSubst s, [TyCoVar]) +substVarBndrsT = mapAccumLM substVarBndrT substCoVarBndr :: HasDebugCallStack => TCvSubst -> CoVar -> (TCvSubst, CoVar) substCoVarBndr = substCoVarBndrUsing substTy @@ -976,6 +1009,15 @@ substVarBndrUsing subst_fn subst v | isTyVar v = substTyVarBndrUsing subst_fn subst v | otherwise = substCoVarBndrUsing subst_fn subst v +substVarBndrUsingT :: (TCvSubst -> Type -> Type) + -> TTCvSubst s -> TyCoVar -> ST s (TTCvSubst s, TyCoVar) +substVarBndrUsingT subst_fn subst v + | isTyVar v = substTyVarBndrUsingT subst_fn subst v + | otherwise = do + persistent_subst <- persistentTCvSubst subst + let (subst', v') = substCoVarBndrUsing subst_fn persistent_subst v + return (transientTCvSubst subst', v') + -- | Substitute a tyvar in a binding position, returning an -- extended subst and a new tyvar. -- Use the supplied function to substitute in the kind @@ -1011,6 +1053,52 @@ substTyVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var setTyVarKind old_var (subst_fn subst old_ki) -- The uniqAway part makes sure the new variable is not already in scope +-- | Substitute a tyvar in a binding position, returning an +-- extended subst and a new tyvar. +-- Use the supplied function to substitute in the kind +substTyVarBndrUsingT + :: (TCvSubst -> Type -> Type) -- ^ Use this to substitute in the kind + -> TTCvSubst s -> TyVar -> ST s (TTCvSubst s, TyVar) +substTyVarBndrUsingT subst_fn (TTCvSubst in_scope tenv cenv) old_var + = assert (isTyVar old_var ) $ do + (in_scope', new_var) <- + if no_kind_change + then do + new_var <- uniqAwayT in_scope old_var + pure (in_scope, new_var) + else do + persistent_in_scope <- persistentInScopeSet in_scope + let subst = TCvSubst persistent_in_scope tenv cenv + let new_var = uniqAway persistent_in_scope $ + setTyVarKind old_var (subst_fn subst old_ki) + pure (transientInScopeSet persistent_in_scope, new_var) + -- The uniqAway part makes sure the new variable is not already in scope + + let new_env | no_change = delVarEnv tenv old_var + | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) + + _no_capture = not (new_var `elemVarSet` shallowTyCoVarsOfTyVarEnv tenv) + -- Assertion check that we are not capturing something in the substitution + + no_change = no_kind_change && (new_var == old_var) + -- no_change means that the new_var is identical in + -- all respects to the old_var (same unique, same kind) + -- See Note [Extending the TCvSubstEnv] + -- + -- In that case we don't need to extend the substitution + -- to map old to new. But instead we must zap any + -- current substitution for the variable. For example: + -- (\x.e) with id_subst = [x |-> e'] + -- Here we must simply zap the substitution for x + + massertPpr _no_capture (pprTyVar old_var $$ pprTyVar new_var) + + new_in_scope <- in_scope' `extendTInScopeSet` new_var + return (TTCvSubst new_in_scope new_env cenv, new_var) + where + old_ki = tyVarKind old_var + no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed + -- | Substitute a covar in a binding position, returning an -- extended subst and a new covar. -- Use the supplied function to substitute in the kind From 4670a43567fa666235e07d538652c917bcaf48e9 Mon Sep 17 00:00:00 2001 From: Pascal Ellinger Date: Tue, 23 Aug 2022 23:10:16 +0200 Subject: [PATCH 05/17] Use the TInScopeSet in substBndrs and substRecBndrs --- compiler/GHC/Core/Subst.hs | 233 +++++++++++++++++++++++++++++++- compiler/GHC/Core/TyCo/Subst.hs | 62 +++++++++ compiler/GHC/Core/Type.hs | 3 + 3 files changed, 292 insertions(+), 6 deletions(-) diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs index 9f4f20591eaf..53a79071ec6a 100644 --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -46,7 +46,7 @@ import qualified GHC.Core.Coercion as Coercion -- We are defining local versions import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList - , isInScope, substTyVarBndr, cloneTyVarBndr ) + , isInScope, substTyVarBndr, cloneTyVarBndr, substTyVarBndrT ) import GHC.Core.Coercion hiding ( substCo, substCoVarBndr ) import GHC.Types.Var.Set @@ -62,10 +62,12 @@ import GHC.Builtin.Names import GHC.Data.Maybe import GHC.Utils.Misc +import GHC.Utils.Monad import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain +import Control.Monad.ST import Data.List (mapAccumL) @@ -102,6 +104,12 @@ data Subst -- -- INVARIANT 3: See Note [Extending the Subst] +data TSubst s + = TSubst (TInScopeSet s) + IdSubstEnv + TvSubstEnv + CvSubstEnv + {- Note [Extending the Subst] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -259,6 +267,20 @@ lookupIdSubst (Subst in_scope ids _ _) v -- it's a bad bug and we reallly want to know | otherwise = pprPanic "lookupIdSubst" (ppr v $$ ppr in_scope) +-- | Find the substitution for an 'Id' in the 'Subst' +lookupIdSubstT :: HasDebugCallStack => TSubst s -> Id -> ST s CoreExpr +lookupIdSubstT (TSubst in_scope ids _ _) v + | not (isLocalId v) = return $ Var v + | Just e <- lookupVarEnv ids v = return e + | otherwise = do + mb_v <- lookupTInScope in_scope v + return $! case mb_v of + Just v -> Var v + -- Vital! See Note [Extending the Subst] + -- If v isn't in the InScopeSet, we panic, because + -- it's a bad bug and we reallly want to know + Nothing -> pprPanic "lookupIdSubst" (ppr v) + delBndr :: Subst -> Var -> Subst delBndr (Subst in_scope ids tvs cvs) v | isCoVar v = Subst in_scope ids tvs (delVarEnv cvs v) @@ -280,6 +302,14 @@ mkOpenSubst in_scope pairs = Subst in_scope (mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs]) (mkVarEnv [(v,co) | (v, Coercion co) <- pairs]) +transientSubst :: Subst -> TSubst s +transientSubst (Subst in_scope id_env tv_env cv_env) + = TSubst (transientInScopeSet in_scope) id_env tv_env cv_env + +persistentSubst :: TSubst s -> ST s Subst +persistentSubst (TSubst in_scope id_env tv_env cv_env) = do + persistent_in_scope <- persistentInScopeSet in_scope + return (Subst persistent_in_scope id_env tv_env cv_env) ------------------------------ isInScope :: Var -> Subst -> Bool isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope @@ -441,16 +471,39 @@ substBndr subst bndr | isCoVar bndr = substCoVarBndr subst bndr | otherwise = substIdBndr (text "var-bndr") subst subst bndr +-- | Substitutes a 'Var' for another one according to the 'TSubst' given, returning +-- the result and an updated 'TSubst' that should be used by subsequent substitutions. +-- 'IdInfo' is preserved by this process, although it is substituted into appropriately. +substBndrT :: TSubst s -> Var -> ST s (TSubst s, Var) +substBndrT subst bndr + | isTyVar bndr = substTyVarBndrT subst bndr + | isCoVar bndr = do + persistent_subst <- persistentSubst subst + -- TODO: Make a substCoVarBndrT version of substCoVarBndr + let (subst', bndr') = substCoVarBndr persistent_subst bndr + return (transientSubst subst', bndr') + | otherwise = substIdBndrT (text "var-bndr") subst bndr + -- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right substBndrs :: Subst -> [Var] -> (Subst, [Var]) -substBndrs subst bndrs = mapAccumL substBndr subst bndrs +substBndrs subst bndrs = runST $ do + (subst', bndrs') <- substBndrsT (transientSubst subst) bndrs + persistent_subst <- persistentSubst subst' + return (persistent_subst, bndrs') + +-- | Applies 'substBndrT' to a number of 'Var's, accumulating a new 'TSubst' left-to-right +substBndrsT :: TSubst s -> [Var] -> ST s (TSubst s, [Var]) +substBndrsT subst bndrs = mapAccumLM substBndrT subst bndrs -- | Substitute in a mutually recursive group of 'Id's substRecBndrs :: Subst -> [Id] -> (Subst, [Id]) -substRecBndrs subst bndrs - = (new_subst, new_bndrs) - where -- Here's the reason we need to pass rec_subst to subst_id - (new_subst, new_bndrs) = mapAccumL (substIdBndr (text "rec-bndr") new_subst) subst bndrs +substRecBndrs subst bndrs = runST $ fixST $ \(~(new_subst, _new_bndrs)) -> do + (new_subst', new_bndrs) <- + mapAccumLM (substIdBndrWithRecSubstT (text "rec-bndr") new_subst) + (transientSubst subst) + bndrs + persistent_new_subst <- persistentSubst new_subst' + return (persistent_new_subst, new_bndrs) substIdBndr :: SDoc -> Subst -- ^ Substitution to use for the IdInfo @@ -487,6 +540,74 @@ substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id -- See Note [Extending the Subst] -- it's /not/ necessary to check mb_new_info and no_type_change +substIdBndrWithRecSubstT :: SDoc + -> Subst -- ^ Substitution to use for the IdInfo + -> (TSubst s) -> Id -- ^ Substitution and Id to transform + -> ST s (TSubst s, Id) -- ^ Transformed pair + -- NB: unfolding may be zapped +substIdBndrWithRecSubstT _doc rec_subst subst@(TSubst in_scope env tvs cvs) old_id = do + id1 <- uniqAwayT in_scope old_id + id2 <- + if no_type_change + then pure id1 + else updateIdTypeAndMultM (substTyT subst) id1 + + -- new_id has the right IdInfo + -- The lazy-set is because we're in a loop here, with + -- rec_subst, when dealing with a mutually-recursive group + let new_id = maybeModifyIdInfo mb_new_info id2 + mb_new_info = substIdInfo rec_subst id2 (idInfo id2) + -- NB: unfolding info may be zapped + + -- Extend the substitution if the unique has changed + -- See the notes with substTyVarBndr for the delVarEnv + new_env | no_change = delVarEnv env old_id + | otherwise = extendVarEnv env old_id (Var new_id) + + no_change = id1 == old_id + -- See Note [Extending the Subst] + -- it's /not/ necessary to check mb_new_info and no_type_change + + new_in_scope <- in_scope `InScopeSet.extendTInScopeSet` new_id + return (TSubst new_in_scope new_env tvs cvs, new_id) + where + old_ty = idType old_id + old_w = idMult old_id + no_type_change = (isEmptyVarEnv tvs && isEmptyVarEnv cvs) || + (noFreeVarsOfType old_ty && noFreeVarsOfType old_w) + +substIdBndrT :: SDoc + -> (TSubst s) -> Id -- ^ Substitution and Id to transform + -> ST s (TSubst s, Id) -- ^ Transformed pair + -- NB: unfolding may be zapped +substIdBndrT _doc subst@(TSubst in_scope env tvs cvs) old_id = do + id1 <- uniqAwayT in_scope old_id + id2 <- + if no_type_change + then pure id1 + else updateIdTypeAndMultM (substTyT subst) id1 + + mb_new_info <- substIdInfoT subst id2 (idInfo id2) + let new_id = maybeModifyIdInfo mb_new_info id2 + -- NB: unfolding info may be zapped + + -- Extend the substitution if the unique has changed + -- See the notes with substTyVarBndr for the delVarEnv + new_env | no_change = delVarEnv env old_id + | otherwise = extendVarEnv env old_id (Var new_id) + + no_change = id1 == old_id + -- See Note [Extending the Subst] + -- it's /not/ necessary to check mb_new_info and no_type_change + + new_in_scope <- in_scope `InScopeSet.extendTInScopeSet` new_id + return (TSubst new_in_scope new_env tvs cvs, new_id) + where + old_ty = idType old_id + old_w = idMult old_id + no_type_change = (isEmptyVarEnv tvs && isEmptyVarEnv cvs) || + (noFreeVarsOfType old_ty && noFreeVarsOfType old_w) + {- Now a variant that unconditionally allocates a new unique. It also unconditionally zaps the OccInfo. @@ -556,6 +677,12 @@ substTyVarBndr (Subst in_scope id_env tv_env cv_env) tv (TCvSubst in_scope' tv_env' cv_env', tv') -> (Subst in_scope' id_env tv_env' cv_env', tv') +substTyVarBndrT :: TSubst s -> TyVar -> ST s (TSubst s, TyVar) +substTyVarBndrT (TSubst in_scope id_env tv_env cv_env) tv = do + (TTCvSubst in_scope' tv_env' cv_env', tv') <- + Type.substTyVarBndrT (TTCvSubst in_scope tv_env cv_env) tv + return (TSubst in_scope' id_env tv_env' cv_env', tv') + cloneTyVarBndr :: Subst -> TyVar -> Unique -> (Subst, TyVar) cloneTyVarBndr (Subst in_scope id_env tv_env cv_env) tv uniq = case Type.cloneTyVarBndr (TCvSubst in_scope tv_env cv_env) tv uniq of @@ -572,9 +699,16 @@ substCoVarBndr (Subst in_scope id_env tv_env cv_env) cv substTy :: Subst -> Type -> Type substTy subst ty = Type.substTyUnchecked (getTCvSubst subst) ty +-- | Persists 'subst' before it is modified. +substTyT :: TSubst s -> Type -> ST s Type +substTyT subst ty = Type.substTyUncheckedT (getTTCvSubst subst) ty + getTCvSubst :: Subst -> TCvSubst getTCvSubst (Subst in_scope _ tenv cenv) = TCvSubst in_scope tenv cenv +getTTCvSubst :: TSubst s -> TTCvSubst s +getTTCvSubst (TSubst in_scope _ tenv cenv) = TTCvSubst in_scope tenv cenv + -- | See 'Coercion.substCo' substCo :: HasCallStack => Subst -> Coercion -> Coercion substCo subst co = Coercion.substCo (getTCvSubst subst) co @@ -612,6 +746,20 @@ substIdInfo subst new_id info old_unf = realUnfoldingInfo info nothing_to_do = isEmptyRuleInfo old_rules && not (hasCoreUnfolding old_unf) +-- | Substitute into some 'IdInfo' with regard to the supplied new 'Id'. +-- Persists 'subst' before it is modified. +substIdInfoT :: TSubst s -> Id -> IdInfo -> ST s (Maybe IdInfo) +substIdInfoT subst new_id info + | nothing_to_do = return Nothing + | otherwise = do + new_rules <- substRuleInfoT subst new_id old_rules + new_unf <- substUnfoldingT subst old_unf + return $ Just (info `setRuleInfo` new_rules `setUnfoldingInfo` new_unf) + where + old_rules = ruleInfo info + old_unf = realUnfoldingInfo info + nothing_to_do = isEmptyRuleInfo old_rules && not (hasCoreUnfolding old_unf) + ------------------ -- | Substitutes for the 'Id's within an unfolding -- NB: substUnfolding /discards/ any unfolding without @@ -643,6 +791,27 @@ substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src }) substUnfolding _ unf = unf -- NoUnfolding, OtherCon +-- | Persists 'subst' before it is modified. +substUnfoldingT :: TSubst s -> Unfolding -> ST s Unfolding +substUnfoldingT subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) = do + persistent_subst <- persistentSubst subst + -- TODO: Use substBndrsT and make a substExprT version of substExpr + let (subst',bndrs') = substBndrs persistent_subst bndrs + args' = map (substExpr subst') args + return df { df_bndrs = bndrs', df_args = args' } + +substUnfoldingT subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src }) + -- Retain an InlineRule! + | not (isStableSource src) -- Zap an unstable unfolding, to save substitution work + = return NoUnfolding + | otherwise -- But keep a stable one! + = do + persistent_subst <- persistentSubst subst + let new_tmpl = substExpr persistent_subst tmpl + seqExpr new_tmpl `seq` return unf { uf_tmpl = new_tmpl } + +substUnfoldingT _ unf = return unf -- NoUnfolding, OtherCon + ------------------ substIdOcc :: Subst -> Id -> Id -- These Ids should not be substituted to non-Ids @@ -659,6 +828,16 @@ substRuleInfo subst new_id (RuleInfo rules rhs_fvs) where subst_ru_fn = const (idName new_id) +-- | Substitutes for the 'Id's within the 'RuleInfo' given the new function 'Id' +-- Persists 'subst' before it is modified. +substRuleInfoT :: TSubst s -> Id -> RuleInfo -> ST s RuleInfo +substRuleInfoT subst new_id (RuleInfo rules rhs_fvs) = do + rules' <- mapM (substRuleT subst subst_ru_fn) rules + rhs_fvs' <- substDVarSetT subst rhs_fvs + return $ RuleInfo rules' rhs_fvs' + where + subst_ru_fn = const (idName new_id) + ------------------ substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule] substRulesForImportedIds subst rules @@ -690,6 +869,31 @@ substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args where (subst', bndrs') = substBndrs subst bndrs +-- | Persists 'subst' before it is modified. +substRuleT :: TSubst s -> (Name -> Name) -> CoreRule -> ST s CoreRule + +-- The subst_ru_fn argument is applied to substitute the ru_fn field +-- of the rule: +-- - Rules for *imported* Ids never change ru_fn +-- - Rules for *local* Ids are in the IdInfo for that Id, +-- and the ru_fn field is simply replaced by the new name +-- of the Id +substRuleT _ _ rule@(BuiltinRule {}) = return rule +substRuleT subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args + , ru_fn = fn_name, ru_rhs = rhs + , ru_local = is_local }) + = do + persistent_subst <- persistentSubst subst + let (subst', bndrs') = substBndrs persistent_subst bndrs + return rule { ru_bndrs = bndrs' + , ru_fn = if is_local + then subst_ru_fn fn_name + else fn_name + , ru_args = map (substExpr subst') args + , ru_rhs = substExpr subst' rhs } + -- Do NOT optimise the RHS (previously we did simplOptExpr here) + -- See Note [Substitute lazily] + ------------------ substDVarSet :: HasDebugCallStack => Subst -> DVarSet -> DVarSet substDVarSet subst@(Subst _ _ tv_env cv_env) fvs @@ -707,6 +911,23 @@ substDVarSet subst@(Subst _ _ tv_env cv_env) fvs , let fv_expr = lookupIdSubst subst fv = expr_fvs fv_expr isLocalVar emptyVarSet $! acc +-- Does not modify subst. +substDVarSetT :: HasDebugCallStack => TSubst s -> DVarSet -> ST s DVarSet +substDVarSetT subst@(TSubst _ _ tv_env cv_env) fvs + = mkDVarSet . fst <$> (foldrM subst_fv ([], emptyVarSet) $ dVarSetElems fvs) + where + subst_fv fv acc + | isTyVar fv + , let fv_ty = lookupVarEnv tv_env fv `orElse` mkTyVarTy fv + = return $! tyCoFVsOfType fv_ty (const True) emptyVarSet $! acc + | isCoVar fv + , let fv_co = lookupVarEnv cv_env fv `orElse` mkCoVarCo fv + = return $! tyCoFVsOfCo fv_co (const True) emptyVarSet $! acc + | otherwise + = do + fv_expr <- lookupIdSubstT subst fv + return $! expr_fvs fv_expr isLocalVar emptyVarSet $! acc + ------------------ substTickish :: Subst -> CoreTickish -> CoreTickish substTickish subst (Breakpoint ext n ids) diff --git a/compiler/GHC/Core/TyCo/Subst.hs b/compiler/GHC/Core/TyCo/Subst.hs index b1ff5849b0a5..9901fb3311dd 100644 --- a/compiler/GHC/Core/TyCo/Subst.hs +++ b/compiler/GHC/Core/TyCo/Subst.hs @@ -50,6 +50,9 @@ module GHC.Core.TyCo.Subst substForAllCoBndr, substVarBndrUsing, substForAllCoBndrUsing, checkValidSubst, isValidTCvSubst, + + TTCvSubst(..), + substTyUncheckedT, substTyVarBndrT, ) where import GHC.Prelude @@ -267,6 +270,9 @@ isEmptyTCvSubst :: TCvSubst -> Bool -- See Note [Extending the TCvSubstEnv] isEmptyTCvSubst (TCvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv +isEmptyTTCvSubst :: TTCvSubst s -> Bool +isEmptyTTCvSubst (TTCvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv + mkTCvSubst :: InScopeSet -> (TvSubstEnv, CvSubstEnv) -> TCvSubst mkTCvSubst in_scope (tenv, cenv) = TCvSubst in_scope tenv cenv @@ -694,6 +700,12 @@ substTyUnchecked subst ty | isEmptyTCvSubst subst = ty | otherwise = subst_ty subst ty +-- | Persists 'subst' before it is modified. +substTyUncheckedT :: TTCvSubst s -> Type -> ST s Type +substTyUncheckedT subst ty + | isEmptyTTCvSubst subst = return ty + | otherwise = subst_ty_t subst ty + substScaledTy :: HasDebugCallStack => TCvSubst -> Scaled Type -> Scaled Type substScaledTy subst scaled_ty = mapScaledType (substTy subst) scaled_ty @@ -777,6 +789,49 @@ subst_ty subst ty go (CastTy ty co) = (mkCastTy $! (go ty)) $! (subst_co subst co) go (CoercionTy co) = CoercionTy $! (subst_co subst co) +-- | Persists 'subst' before it is modified. +subst_ty_t :: TTCvSubst s -> Type -> ST s Type +-- subst_ty is the main workhorse for type substitution +-- +-- Note that the in_scope set is poked only if we hit a forall +-- so it may often never be fully computed +subst_ty_t subst ty + = go ty + where + go (TyVarTy tv) = return $! substTyVarT subst tv + go (AppTy fun arg) = do + ty1 <- go fun + ty2 <- go arg + return $! (mkAppTy $! ty1) $! ty2 + -- The mkAppTy smart constructor is important + -- we might be replacing (a Int), represented with App + -- by [Int], represented with TyConApp + go ty@(TyConApp tc []) = return $ tc `seq` ty -- avoid allocation in this common case + go (TyConApp tc tys) = (mkTyConApp $! tc) <$> mapM go tys + -- NB: mkTyConApp, not TyConApp. + -- mkTyConApp has optimizations. + -- See Note [Using synonyms to compress types] + -- in GHC.Core.Type + go ty@(FunTy { ft_mult = mult, ft_arg = arg, ft_res = res }) = do + !mult' <- go mult + !arg' <- go arg + !res' <- go res + return $! ty { ft_mult = mult', ft_arg = arg', ft_res = res' } + go (ForAllTy (Bndr tv vis) ty) = do + persistent_subst <- persistentTCvSubst subst + case substVarBndrUnchecked persistent_subst tv of + (subst', tv') -> + return $! (ForAllTy $! ((Bndr $! tv') vis)) $! (subst_ty subst' ty) + go (LitTy n) = return $ LitTy $! n + -- TODO: make a subst_co_t version of subst_co + go (CastTy ty co) = do + ty' <- go ty + persistent_subst <- persistentTCvSubst subst + return $! (mkCastTy $! ty') $! (subst_co persistent_subst co) + go (CoercionTy co) = do + persistent_subst <- persistentTCvSubst subst + return $! CoercionTy $! (subst_co persistent_subst co) + substTyVar :: TCvSubst -> TyVar -> Type substTyVar (TCvSubst _ tenv _) tv = assert (isTyVar tv) $ @@ -784,6 +839,13 @@ substTyVar (TCvSubst _ tenv _) tv Just ty -> ty Nothing -> TyVarTy tv +substTyVarT :: TTCvSubst s -> TyVar -> Type +substTyVarT (TTCvSubst _ tenv _) tv + = assert (isTyVar tv) $ + case lookupVarEnv tenv tv of + Just ty -> ty + Nothing -> TyVarTy tv + substTyVars :: TCvSubst -> [TyVar] -> [Type] substTyVars subst = map $ substTyVar subst diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index 166a56cabb68..4cacd6c0126b 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -194,6 +194,7 @@ module GHC.Core.Type ( -- * Main type substitution data types TvSubstEnv, -- Representation widely visible TCvSubst(..), -- Representation visible to a few friends + TTCvSubst(..), -- ** Manipulating type substitutions emptyTvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst, @@ -224,6 +225,8 @@ module GHC.Core.Type ( substTyCoBndr, cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar, + substTyUncheckedT, substTyVarBndrT, + -- * Tidying type related things up for printing tidyType, tidyTypes, tidyOpenType, tidyOpenTypes, From 950beeca17daefeef69e62e56c4d4caa866d168a Mon Sep 17 00:00:00 2001 From: Pascal Ellinger Date: Tue, 23 Aug 2022 23:22:19 +0200 Subject: [PATCH 06/17] Use the TInScopeSet in subst_opt_bndrs --- compiler/GHC/Core/SimpleOpt.hs | 53 ++++++++++++++++++++++++++++++++-- compiler/GHC/Core/Subst.hs | 2 ++ compiler/GHC/Plugins.hs | 2 +- 3 files changed, 54 insertions(+), 3 deletions(-) diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index 1d604120b935..c836585ddab5 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -40,7 +40,7 @@ import GHC.Types.Demand( etaConvertDmdSig, topSubDmd ) import GHC.Types.Tickish import GHC.Core.Coercion.Opt ( optCoercion, OptCoercionOpts (..) ) import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList - , isInScope, substTyVarBndr, cloneTyVarBndr ) + , isInScope, substTyVarBndr, cloneTyVarBndr, substTyVarBndrT ) import GHC.Core.Coercion hiding ( substCo, substCoVarBndr ) import GHC.Builtin.Types import GHC.Builtin.Names @@ -51,8 +51,10 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Misc +import GHC.Utils.Monad import GHC.Data.Maybe ( orElse ) import GHC.Data.Graph.UnVar +import Control.Monad.ST import Data.List (mapAccumL) import qualified Data.ByteString as BS @@ -198,12 +200,37 @@ data SimpleOptEnv -- See Note [Eta reduction in recursive RHSs] } +data TSimpleOptEnv s + = TSOE { tsoe_opts :: {-# UNPACK #-} !SimpleOpts + -- ^ Simplifier options + + , tsoe_inl :: IdEnv SimpleClo + -- ^ Deals with preInlineUnconditionally; things + -- that occur exactly once and are inlined + -- without having first been simplified + + , tsoe_subst :: TSubst s + -- ^ Deals with cloning; includes the InScopeSet + + , tsoe_rec_ids :: !UnVarSet + -- ^ Fast OutVarSet tracking which recursive RHSs we are analysing. + -- See Note [Eta reduction in recursive RHSs] + } + instance Outputable SimpleOptEnv where ppr (SOE { soe_inl = inl, soe_subst = subst }) = text "SOE {" <+> vcat [ text "soe_inl =" <+> ppr inl , text "soe_subst =" <+> ppr subst ] <+> text "}" +transientSOE :: SimpleOptEnv -> TSimpleOptEnv s +transientSOE (SOE opts inl subst ids) = TSOE opts inl (transientSubst subst) ids + +persistentSOE :: TSimpleOptEnv s -> ST s SimpleOptEnv +persistentSOE (TSOE opts inl subst ids) = do + persistent_subst <- persistentSubst subst + return (SOE opts inl persistent_subst ids) + emptyEnv :: SimpleOpts -> SimpleOptEnv emptyEnv opts = SOE { soe_inl = emptyVarEnv , soe_subst = emptySubst @@ -685,7 +712,13 @@ it outputs. ---------------------- subst_opt_bndrs :: SimpleOptEnv -> [InVar] -> (SimpleOptEnv, [OutVar]) -subst_opt_bndrs env bndrs = mapAccumL subst_opt_bndr env bndrs +subst_opt_bndrs env bndrs = runST $ do + (env', bndrs') <- subst_opt_bndrs_t (transientSOE env) bndrs + persistent_env <- persistentSOE env' + return (persistent_env, bndrs') + +subst_opt_bndrs_t :: TSimpleOptEnv s -> [InVar] -> ST s (TSimpleOptEnv s, [OutVar]) +subst_opt_bndrs_t env bndrs = mapAccumLM subst_opt_bndr_t env bndrs subst_opt_bndr :: SimpleOptEnv -> InVar -> (SimpleOptEnv, OutVar) subst_opt_bndr env bndr @@ -697,6 +730,22 @@ subst_opt_bndr env bndr (subst_tv, tv') = substTyVarBndr subst bndr (subst_cv, cv') = substCoVarBndr subst bndr +subst_opt_bndr_t :: TSimpleOptEnv s -> InVar -> ST s (TSimpleOptEnv s, OutVar) +subst_opt_bndr_t env bndr + | isTyVar bndr = do + (subst_tv, tv') <- substTyVarBndrT subst bndr + return (env { tsoe_subst = subst_tv }, tv') + | isCoVar bndr = do + persistent_subst <- persistentSubst subst + let (subst_cv, cv') = substCoVarBndr persistent_subst bndr + return (env { tsoe_subst = transientSubst subst_cv }, cv') + | otherwise = do + persistent_env <- persistentSOE env + let (env', id') = subst_opt_id_bndr persistent_env bndr + return (transientSOE env', id') + where + subst = tsoe_subst env + subst_opt_id_bndr :: SimpleOptEnv -> InId -> (SimpleOptEnv, OutId) -- Nuke all fragile IdInfo, unfolding, and RULES; it gets added back later by -- add_info. diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs index 53a79071ec6a..b97b54506ab2 100644 --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -32,6 +32,8 @@ module GHC.Core.Subst ( substBndr, substBndrs, substRecBndrs, substTyVarBndr, substCoVarBndr, cloneBndr, cloneBndrs, cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs, + TSubst(..), + transientSubst, persistentSubst, substTyVarBndrT, ) where import GHC.Prelude diff --git a/compiler/GHC/Plugins.hs b/compiler/GHC/Plugins.hs index 93220b5eef9c..c13416726b23 100644 --- a/compiler/GHC/Plugins.hs +++ b/compiler/GHC/Plugins.hs @@ -89,7 +89,7 @@ import GHC.Core.DataCon import GHC.Core.Utils import GHC.Core.Make import GHC.Core.FVs -import GHC.Core.Subst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst, extendSubstInScopeSet ) +import GHC.Core.Subst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst, extendSubstInScopeSet, substTyVarBndrT ) -- These names are also exported by Type import GHC.Core.Rules From 07d6a772fb7e4c8fafc9a075c9ba181d4cd3f23f Mon Sep 17 00:00:00 2001 From: Pascal Ellinger Date: Tue, 23 Aug 2022 23:33:50 +0200 Subject: [PATCH 07/17] Use the TInScopeSet in simplBinders --- compiler/GHC/Core/Opt/Simplify/Env.hs | 107 +++++++++++++++++++++++++- compiler/GHC/Core/TyCo/Subst.hs | 4 + compiler/GHC/Core/Type.hs | 2 +- 3 files changed, 110 insertions(+), 3 deletions(-) diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs index 47927d5d7f68..7267b0b4d881 100644 --- a/compiler/GHC/Core/Opt/Simplify/Env.hs +++ b/compiler/GHC/Core/Opt/Simplify/Env.hs @@ -63,7 +63,8 @@ import GHC.Driver.Session ( DynFlags ) import GHC.Builtin.Types import GHC.Core.TyCo.Rep ( TyCoBinder(..) ) import qualified GHC.Core.Type as Type -import GHC.Core.Type hiding ( substTy, substTyVar, substTyVarBndr, extendTvSubst, extendCvSubst ) +import GHC.Core.Type hiding ( substTy, substTyVar, substTyVarBndr, extendTvSubst, extendCvSubst + , substTyVarBndrT ) import qualified GHC.Core.Coercion as Coercion import GHC.Core.Coercion hiding ( substCo, substCoVar, substCoVarBndr ) import GHC.Types.Basic @@ -75,6 +76,7 @@ import GHC.Utils.Misc import GHC.Utils.Logger import GHC.Types.Unique.FM ( pprUniqFM ) +import Control.Monad.ST import Data.List (mapAccumL) {- @@ -113,6 +115,17 @@ data SimplEnv , seCaseDepth :: !Int -- Depth of multi-branch case alternatives } +data TSimplEnv s + = TSimplEnv { + tseMode :: !SimplMode + , tseTvSubst :: TvSubstEnv + , tseCvSubst :: CvSubstEnv + , tseIdSubst :: SimplIdSubst + , tseRecIds :: !UnVarSet + , tseInScope :: !(TInScopeSet s) + , tseCaseDepth :: !Int + } + data SimplFloats = SimplFloats { -- Ordinary let bindings @@ -439,6 +452,16 @@ setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst mkContEx :: SimplEnv -> InExpr -> SimplSR mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e +transientSimplEnv :: SimplEnv -> TSimplEnv s +transientSimplEnv (SimplEnv mode tv_subst cv_subst id_subst rec_ids in_scope case_depth) + = let transient_in_scope = transientInScopeSet in_scope + in TSimplEnv mode tv_subst cv_subst id_subst rec_ids transient_in_scope case_depth + +persistentSimplEnv :: TSimplEnv s -> ST s SimplEnv +persistentSimplEnv (TSimplEnv mode tv_subst cv_subst id_subst rec_ids in_scope case_depth) = do + persistent_in_scope <- persistentInScopeSet in_scope + return (SimplEnv mode tv_subst cv_subst id_subst rec_ids persistent_in_scope case_depth) + {- ************************************************************************ * * @@ -799,7 +822,13 @@ See also Note [Scaling join point arguments]. -} simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) -simplBinders !env bndrs = mapAccumLM simplBinder env bndrs +simplBinders !env bndrs = return $ runST $ do + (env', bndrs') <- simplBindersT (transientSimplEnv env) bndrs + persistent_env <- persistentSimplEnv env' + return (persistent_env, bndrs') + +simplBindersT :: TSimplEnv s -> [InBndr] -> ST s (TSimplEnv s, [OutBndr]) +simplBindersT !env bndrs = mapAccumLM simplBinderT env bndrs ------------- simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) @@ -814,6 +843,13 @@ simplBinder !env bndr | otherwise = do { let (env', id) = substIdBndr env bndr ; seqId id `seq` return (env', id) } +simplBinderT :: TSimplEnv s -> InBndr -> ST s (TSimplEnv s, OutBndr) +simplBinderT !env bndr + | isTyVar bndr = do { (env', tv) <- substTyVarBndrT env bndr + ; seqTyVar tv `seq` return (env', tv) } + | otherwise = do { (env', id) <- substIdBndrT env bndr + ; seqId id `seq` return (env', id) } + --------------- simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) -- A non-recursive let binder @@ -838,6 +874,16 @@ substIdBndr env bndr | isCoVar bndr = substCoVarBndr env bndr | otherwise = substNonCoVarIdBndr env bndr +substIdBndrT :: TSimplEnv s -> InBndr -> ST s (TSimplEnv s, OutBndr) +-- Might be a coercion variable +substIdBndrT env bndr + | isCoVar bndr = do + -- TODO: Make a substCoVarBndrT version of substCoVarBndr + persistent_env <- persistentSimplEnv env + let (env', id) = substCoVarBndr persistent_env bndr + return (transientSimplEnv env', id) + | otherwise = substNonCoVarIdBndrT env bndr + --------------- substNonCoVarIdBndr :: SimplEnv @@ -862,6 +908,9 @@ substNonCoVarIdBndr -- all fragile info is zapped substNonCoVarIdBndr env id = subst_id_bndr env id (\x -> x) +substNonCoVarIdBndrT :: TSimplEnv s -> InBndr -> ST s (TSimplEnv s, OutBndr) +substNonCoVarIdBndrT env id = subst_id_bndr_t env id (\x -> x) + -- Inline to make the (OutId -> OutId) function a known call. -- This is especially important for `substNonCoVarIdBndr` which -- passes an identity lambda. @@ -898,6 +947,34 @@ subst_id_bndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) !new_in_scope = in_scope `extendInScopeSet` new_id +-- Inline to make the (OutId -> OutId) function a known call. +-- This is especially important for `substNonCoVarIdBndrT` which +-- passes an identity lambda. +{-# INLINE subst_id_bndr_t #-} +subst_id_bndr_t :: TSimplEnv s + -> InBndr -- Env and binder to transform + -> (OutId -> OutId) -- Adjust the type + -> ST s (TSimplEnv s, OutBndr) +subst_id_bndr_t env@(TSimplEnv { tseInScope = in_scope, tseIdSubst = id_subst }) + old_id adjust_type + = assertPpr (not (isCoVar old_id)) (ppr old_id) $ do + !id1 <- uniqAwayT in_scope old_id + !id2 <- substIdTypeT env id1 + let !id3 = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding + -- and fragile OccInfo + !new_id = adjust_type id3 + + -- Extend the substitution if the unique has changed, + -- or there's some useful occurrence information + -- See the notes with substTyVarBndr for the delSubstEnv + !new_subst | new_id /= old_id + = extendVarEnv id_subst old_id (DoneId new_id) + | otherwise + = delVarEnv id_subst old_id + + new_in_scope <- in_scope `extendTInScopeSet` new_id + return (env { tseInScope = new_in_scope, tseIdSubst = new_subst }, new_id) + ------------------------------------ seqTyVar :: TyVar -> () seqTyVar b = b `seq` () @@ -1044,6 +1121,11 @@ getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env , seCvSubst = cv_env }) = mkTCvSubst in_scope (tv_env, cv_env) +getTTCvSubst :: TSimplEnv s -> TTCvSubst s +getTTCvSubst (TSimplEnv { tseInScope = in_scope, tseTvSubst = tv_env + , tseCvSubst = cv_env }) + = mkTTCvSubst in_scope (tv_env, cv_env) + substTy :: HasDebugCallStack => SimplEnv -> Type -> Type substTy env ty = Type.substTy (getTCvSubst env) ty @@ -1056,6 +1138,11 @@ substTyVarBndr env tv (TCvSubst in_scope' tv_env' cv_env', tv') -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, tv') +substTyVarBndrT :: TSimplEnv s -> TyVar -> ST s (TSimplEnv s, TyVar) +substTyVarBndrT env tv = do + (TTCvSubst in_scope' tv_env' cv_env', tv') <- Type.substTyVarBndrT (getTTCvSubst env) tv + return (env { tseInScope = in_scope', tseTvSubst = tv_env', tseCvSubst = cv_env' }, tv') + substCoVar :: SimplEnv -> CoVar -> Coercion substCoVar env tv = Coercion.substCoVar (getTCvSubst env) tv @@ -1083,3 +1170,19 @@ substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv subst = TCvSubst in_scope tv_env cv_env old_ty = idType id old_w = varMult id + +-- | Persists the 'TInScopeSet' before it is modfied. +substIdTypeT :: TSimplEnv s -> Id -> ST s Id +substIdTypeT (TSimplEnv { tseInScope = in_scope, tseTvSubst = tv_env, tseCvSubst = cv_env }) id + | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) + || no_free_vars + = return id + | otherwise = Id.updateIdTypeAndMultM (Type.substTyUncheckedT subst) id + -- The tyCoVarsOfType is cheaper than it looks + -- because we cache the free tyvars of the type + -- in a Note in the id's type itself + where + no_free_vars = noFreeVarsOfType old_ty && noFreeVarsOfType old_w + subst = TTCvSubst in_scope tv_env cv_env + old_ty = idType id + old_w = varMult id diff --git a/compiler/GHC/Core/TyCo/Subst.hs b/compiler/GHC/Core/TyCo/Subst.hs index 9901fb3311dd..f7aa986fdbec 100644 --- a/compiler/GHC/Core/TyCo/Subst.hs +++ b/compiler/GHC/Core/TyCo/Subst.hs @@ -52,6 +52,7 @@ module GHC.Core.TyCo.Subst checkValidSubst, isValidTCvSubst, TTCvSubst(..), + mkTTCvSubst, substTyUncheckedT, substTyVarBndrT, ) where @@ -276,6 +277,9 @@ isEmptyTTCvSubst (TTCvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv c mkTCvSubst :: InScopeSet -> (TvSubstEnv, CvSubstEnv) -> TCvSubst mkTCvSubst in_scope (tenv, cenv) = TCvSubst in_scope tenv cenv +mkTTCvSubst :: TInScopeSet s -> (TvSubstEnv, CvSubstEnv) -> TTCvSubst s +mkTTCvSubst in_scope (tenv, cenv) = TTCvSubst in_scope tenv cenv + mkTvSubst :: InScopeSet -> TvSubstEnv -> TCvSubst -- ^ Make a TCvSubst with specified tyvar subst and empty covar subst mkTvSubst in_scope tenv = TCvSubst in_scope tenv emptyCvSubstEnv diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index 4cacd6c0126b..d08bbdd8f3ed 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -225,7 +225,7 @@ module GHC.Core.Type ( substTyCoBndr, cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar, - substTyUncheckedT, substTyVarBndrT, + mkTTCvSubst, substTyUncheckedT, substTyVarBndrT, -- * Tidying type related things up for printing tidyType, tidyTypes, From 6de05af13be635e082c22c01c6501b360f2ea250 Mon Sep 17 00:00:00 2001 From: Pascal Ellinger Date: Wed, 24 Aug 2022 23:13:57 +0200 Subject: [PATCH 08/17] Add substCoVarBndrUsingT --- compiler/GHC/Core/Coercion.hs | 2 + compiler/GHC/Core/Subst.hs | 10 ++++- compiler/GHC/Core/TyCo/Subst.hs | 76 ++++++++++++++++++++++++--------- compiler/GHC/Plugins.hs | 3 +- 4 files changed, 68 insertions(+), 23 deletions(-) diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs index 1416e231a9dd..84f2a80097ac 100644 --- a/compiler/GHC/Core/Coercion.hs +++ b/compiler/GHC/Core/Coercion.hs @@ -91,6 +91,8 @@ module GHC.Core.Coercion ( substCoVarBndr, extendTvSubstAndInScope, getCvSubstEnv, + substCoVarBndrT, + -- ** Lifting liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx, emptyLiftingContext, extendLiftingContext, extendLiftingContextAndInScope, diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs index b97b54506ab2..24421cd6ddaa 100644 --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -33,7 +33,7 @@ module GHC.Core.Subst ( cloneBndr, cloneBndrs, cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs, TSubst(..), - transientSubst, persistentSubst, substTyVarBndrT, + transientSubst, persistentSubst, substTyVarBndrT, substCoVarBndrT ) where import GHC.Prelude @@ -49,7 +49,7 @@ import qualified GHC.Core.Coercion as Coercion import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList , isInScope, substTyVarBndr, cloneTyVarBndr, substTyVarBndrT ) -import GHC.Core.Coercion hiding ( substCo, substCoVarBndr ) +import GHC.Core.Coercion hiding ( substCo, substCoVarBndr, substCoVarBndrT ) import GHC.Types.Var.Set import GHC.Types.Var.Env as InScopeSet @@ -697,6 +697,12 @@ substCoVarBndr (Subst in_scope id_env tv_env cv_env) cv (TCvSubst in_scope' tv_env' cv_env', cv') -> (Subst in_scope' id_env tv_env' cv_env', cv') +substCoVarBndrT :: TSubst s -> CoVar -> ST s (TSubst s, CoVar) +substCoVarBndrT (TSubst in_scope id_env tv_env cv_env) cv = do + (TTCvSubst in_scope' tv_env' cv_env', cv') <- + Coercion.substCoVarBndrT (TTCvSubst in_scope tv_env cv_env) cv + return (TSubst in_scope' id_env tv_env' cv_env', cv') + -- | See 'GHC.Core.Type.substTy'. substTy :: Subst -> Type -> Type substTy subst ty = Type.substTyUnchecked (getTCvSubst subst) ty diff --git a/compiler/GHC/Core/TyCo/Subst.hs b/compiler/GHC/Core/TyCo/Subst.hs index f7aa986fdbec..471a17a9bcb4 100644 --- a/compiler/GHC/Core/TyCo/Subst.hs +++ b/compiler/GHC/Core/TyCo/Subst.hs @@ -53,7 +53,7 @@ module GHC.Core.TyCo.Subst TTCvSubst(..), mkTTCvSubst, - substTyUncheckedT, substTyVarBndrT, + substTyUncheckedT, substTyVarBndrT, substCoVarBndrT, ) where import GHC.Prelude @@ -694,6 +694,15 @@ substTy subst ty | otherwise = checkValidSubst subst [ty] [] $ subst_ty subst ty +-- | Substitute within a 'Type' +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +-- Persists 'subst' before it is modified. +substTyT :: HasDebugCallStack => TTCvSubst s -> Type -> ST s Type +substTyT subst ty + | isEmptyTTCvSubst subst = return ty + | otherwise = subst_ty_t subst ty + -- | Substitute within a 'Type' disabling the sanity checks. -- The problems that the sanity checks in substTy catch are described in -- Note [The substitution invariant]. @@ -1032,7 +1041,7 @@ substTyVarBndr :: HasDebugCallStack => TCvSubst -> TyVar -> (TCvSubst, TyVar) substTyVarBndr = substTyVarBndrUsing substTy substTyVarBndrT :: HasDebugCallStack => TTCvSubst s -> TyVar -> ST s (TTCvSubst s, TyVar) -substTyVarBndrT = substTyVarBndrUsingT substTy +substTyVarBndrT = substTyVarBndrUsingT substTyT substTyVarBndrs :: HasDebugCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar]) substTyVarBndrs subst tvs = runST $ do @@ -1047,7 +1056,7 @@ substVarBndr :: HasDebugCallStack => TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) substVarBndr = substVarBndrUsing substTy substVarBndrT :: HasDebugCallStack => TTCvSubst s -> TyCoVar -> ST s (TTCvSubst s, TyCoVar) -substVarBndrT = substVarBndrUsingT substTy +substVarBndrT = substVarBndrUsingT substTyT substVarBndrs :: HasDebugCallStack => TCvSubst -> [TyCoVar] -> (TCvSubst, [TyCoVar]) substVarBndrs subst vs = runST $ do @@ -1061,6 +1070,9 @@ substVarBndrsT = mapAccumLM substVarBndrT substCoVarBndr :: HasDebugCallStack => TCvSubst -> CoVar -> (TCvSubst, CoVar) substCoVarBndr = substCoVarBndrUsing substTy +substCoVarBndrT :: HasDebugCallStack => TTCvSubst s -> CoVar -> ST s (TTCvSubst s, CoVar) +substCoVarBndrT = substCoVarBndrUsingT substTyT + -- | Like 'substVarBndr', but disables sanity checks. -- The problems that the sanity checks in substTy catch are described in -- Note [The substitution invariant]. @@ -1075,14 +1087,12 @@ substVarBndrUsing subst_fn subst v | isTyVar v = substTyVarBndrUsing subst_fn subst v | otherwise = substCoVarBndrUsing subst_fn subst v -substVarBndrUsingT :: (TCvSubst -> Type -> Type) +-- | 'subst_fn' must persist the subst before modifying it. +substVarBndrUsingT :: (TTCvSubst s -> Type -> ST s Type) -> TTCvSubst s -> TyCoVar -> ST s (TTCvSubst s, TyCoVar) substVarBndrUsingT subst_fn subst v | isTyVar v = substTyVarBndrUsingT subst_fn subst v - | otherwise = do - persistent_subst <- persistentTCvSubst subst - let (subst', v') = substCoVarBndrUsing subst_fn persistent_subst v - return (transientTCvSubst subst', v') + | otherwise = substCoVarBndrUsingT subst_fn subst v -- | Substitute a tyvar in a binding position, returning an -- extended subst and a new tyvar. @@ -1122,22 +1132,19 @@ substTyVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var -- | Substitute a tyvar in a binding position, returning an -- extended subst and a new tyvar. -- Use the supplied function to substitute in the kind +-- 'subst_fn' must persist the subst before modifying it. substTyVarBndrUsingT - :: (TCvSubst -> Type -> Type) -- ^ Use this to substitute in the kind + :: (TTCvSubst s -> Type -> ST s Type) -- ^ Use this to substitute in the kind -> TTCvSubst s -> TyVar -> ST s (TTCvSubst s, TyVar) -substTyVarBndrUsingT subst_fn (TTCvSubst in_scope tenv cenv) old_var +substTyVarBndrUsingT subst_fn subst@(TTCvSubst in_scope tenv cenv) old_var = assert (isTyVar old_var ) $ do - (in_scope', new_var) <- + new_var <- if no_kind_change - then do - new_var <- uniqAwayT in_scope old_var - pure (in_scope, new_var) + then + uniqAwayT in_scope old_var else do - persistent_in_scope <- persistentInScopeSet in_scope - let subst = TCvSubst persistent_in_scope tenv cenv - let new_var = uniqAway persistent_in_scope $ - setTyVarKind old_var (subst_fn subst old_ki) - pure (transientInScopeSet persistent_in_scope, new_var) + kind <- subst_fn subst old_ki + uniqAwayT in_scope $ setTyVarKind old_var kind -- The uniqAway part makes sure the new variable is not already in scope let new_env | no_change = delVarEnv tenv old_var @@ -1159,7 +1166,7 @@ substTyVarBndrUsingT subst_fn (TTCvSubst in_scope tenv cenv) old_var massertPpr _no_capture (pprTyVar old_var $$ pprTyVar new_var) - new_in_scope <- in_scope' `extendTInScopeSet` new_var + new_in_scope <- in_scope `extendTInScopeSet` new_var return (TTCvSubst new_in_scope new_env cenv, new_var) where old_ki = tyVarKind old_var @@ -1192,6 +1199,35 @@ substCoVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var -- It's important to do the substitution for coercions, -- because they can have free type variables +-- | Substitute a covar in a binding position, returning an +-- extended subst and a new covar. +-- Use the supplied function to substitute in the kind +-- 'subst_fn' must persist the subst before modifying it. +substCoVarBndrUsingT + :: (TTCvSubst s -> Type -> ST s Type) + -> TTCvSubst s -> CoVar -> ST s (TTCvSubst s, CoVar) +substCoVarBndrUsingT subst_fn subst@(TTCvSubst in_scope tenv cenv) old_var + = assert (isCoVar old_var) $ do + t1' <- subst_fn subst t1 + t2' <- subst_fn subst t2 + + let subst_old_var = mkCoVar (varName old_var) new_var_type + new_var_type = mkCoercionType role t1' t2' + + new_var <- uniqAwayT in_scope subst_old_var + + let new_co = mkCoVarCo new_var + no_change = new_var == old_var && no_kind_change + + new_cenv | no_change = delVarEnv cenv old_var + | otherwise = extendVarEnv cenv old_var new_co + + new_in_scope <- in_scope `extendTInScopeSet` new_var + return (TTCvSubst new_in_scope tenv new_cenv, new_var) + where + no_kind_change = noFreeVarsOfTypes [t1, t2] + (_, _, t1, t2, role) = coVarKindsTypesRole old_var + cloneTyVarBndr :: TCvSubst -> TyVar -> Unique -> (TCvSubst, TyVar) cloneTyVarBndr subst@(TCvSubst in_scope tv_env cv_env) tv uniq = assertPpr (isTyVar tv) (ppr tv) -- I think it's only called on TyVars diff --git a/compiler/GHC/Plugins.hs b/compiler/GHC/Plugins.hs index c13416726b23..6b5ebffc7716 100644 --- a/compiler/GHC/Plugins.hs +++ b/compiler/GHC/Plugins.hs @@ -89,7 +89,8 @@ import GHC.Core.DataCon import GHC.Core.Utils import GHC.Core.Make import GHC.Core.FVs -import GHC.Core.Subst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst, extendSubstInScopeSet, substTyVarBndrT ) +import GHC.Core.Subst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst, extendSubstInScopeSet + , substTyVarBndrT, substCoVarBndrT ) -- These names are also exported by Type import GHC.Core.Rules From 1129996d6b343982947eeed237fce02c5960ab34 Mon Sep 17 00:00:00 2001 From: Pascal Ellinger Date: Wed, 24 Aug 2022 23:16:29 +0200 Subject: [PATCH 09/17] Add subst_opt_id_bndr_t and use substCoVarBndrT --- compiler/GHC/Core/Opt/Simplify/Env.hs | 13 +++++---- compiler/GHC/Core/SimpleOpt.hs | 42 ++++++++++++++++++++------- compiler/GHC/Core/Subst.hs | 8 ++--- 3 files changed, 40 insertions(+), 23 deletions(-) diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs index 7267b0b4d881..55b7a5fc5ba8 100644 --- a/compiler/GHC/Core/Opt/Simplify/Env.hs +++ b/compiler/GHC/Core/Opt/Simplify/Env.hs @@ -66,7 +66,7 @@ import qualified GHC.Core.Type as Type import GHC.Core.Type hiding ( substTy, substTyVar, substTyVarBndr, extendTvSubst, extendCvSubst , substTyVarBndrT ) import qualified GHC.Core.Coercion as Coercion -import GHC.Core.Coercion hiding ( substCo, substCoVar, substCoVarBndr ) +import GHC.Core.Coercion hiding ( substCo, substCoVar, substCoVarBndr, substCoVarBndrT ) import GHC.Types.Basic import GHC.Utils.Monad import GHC.Utils.Outputable @@ -877,11 +877,7 @@ substIdBndr env bndr substIdBndrT :: TSimplEnv s -> InBndr -> ST s (TSimplEnv s, OutBndr) -- Might be a coercion variable substIdBndrT env bndr - | isCoVar bndr = do - -- TODO: Make a substCoVarBndrT version of substCoVarBndr - persistent_env <- persistentSimplEnv env - let (env', id) = substCoVarBndr persistent_env bndr - return (transientSimplEnv env', id) + | isCoVar bndr = substCoVarBndrT env bndr | otherwise = substNonCoVarIdBndrT env bndr --------------- @@ -1152,6 +1148,11 @@ substCoVarBndr env cv (TCvSubst in_scope' tv_env' cv_env', cv') -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv') +substCoVarBndrT :: TSimplEnv s -> CoVar -> ST s (TSimplEnv s, CoVar) +substCoVarBndrT env cv = do + (TTCvSubst in_scope' tv_env' cv_env', cv') <- Coercion.substCoVarBndrT (getTTCvSubst env) cv + return (env { tseInScope = in_scope', tseTvSubst = tv_env', tseCvSubst = cv_env' }, cv') + substCo :: SimplEnv -> Coercion -> Coercion substCo env co = Coercion.substCo (getTCvSubst env) co diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index c836585ddab5..8b00e5e149b2 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -41,7 +41,7 @@ import GHC.Types.Tickish import GHC.Core.Coercion.Opt ( optCoercion, OptCoercionOpts (..) ) import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList , isInScope, substTyVarBndr, cloneTyVarBndr, substTyVarBndrT ) -import GHC.Core.Coercion hiding ( substCo, substCoVarBndr ) +import GHC.Core.Coercion hiding ( substCo, substCoVarBndr, substCoVarBndrT ) import GHC.Builtin.Types import GHC.Builtin.Names import GHC.Types.Basic @@ -732,19 +732,15 @@ subst_opt_bndr env bndr subst_opt_bndr_t :: TSimpleOptEnv s -> InVar -> ST s (TSimpleOptEnv s, OutVar) subst_opt_bndr_t env bndr - | isTyVar bndr = do + | isTyVar bndr = do (subst_tv, tv') <- substTyVarBndrT subst bndr return (env { tsoe_subst = subst_tv }, tv') - | isCoVar bndr = do - persistent_subst <- persistentSubst subst - let (subst_cv, cv') = substCoVarBndr persistent_subst bndr - return (env { tsoe_subst = transientSubst subst_cv }, cv') - | otherwise = do - persistent_env <- persistentSOE env - let (env', id') = subst_opt_id_bndr persistent_env bndr - return (transientSOE env', id') + | isCoVar bndr = do + (subst_cv, cv') <- substCoVarBndrT subst bndr + return (env { tsoe_subst = subst_cv }, cv') + | otherwise = subst_opt_id_bndr_t env bndr where - subst = tsoe_subst env + subst = tsoe_subst env subst_opt_id_bndr :: SimpleOptEnv -> InId -> (SimpleOptEnv, OutId) -- Nuke all fragile IdInfo, unfolding, and RULES; it gets added back later by @@ -779,6 +775,30 @@ subst_opt_id_bndr env@(SOE { soe_subst = subst, soe_inl = inl }) old_id new_subst = Subst new_in_scope new_id_subst tv_subst cv_subst new_inl = delVarEnv inl old_id +subst_opt_id_bndr_t :: TSimpleOptEnv s -> InId -> ST s (TSimpleOptEnv s, OutId) +subst_opt_id_bndr_t env@(TSOE { tsoe_subst = subst, tsoe_inl = inl }) old_id = do + id1 <- uniqAwayT in_scope old_id + id2 <- updateIdTypeAndMultM (substTyT subst) id1 + + let new_id = zapFragileIdInfo id2 + -- Zaps rules, unfolding, and fragile OccInfo + -- The unfolding and rules will get added back later, by add_info + + new_in_scope <- in_scope `extendTInScopeSet` new_id + let no_change = new_id == old_id + + -- Extend the substitution if the unique has changed, + -- See the notes with substTyVarBndr for the delSubstEnv + new_id_subst + | no_change = delVarEnv id_subst old_id + | otherwise = extendVarEnv id_subst old_id (Var new_id) + + new_subst = TSubst new_in_scope new_id_subst tv_subst cv_subst + return (env { tsoe_subst = new_subst, tsoe_inl = new_inl }, new_id) + where + TSubst in_scope id_subst tv_subst cv_subst = subst + new_inl = delVarEnv inl old_id + ---------------------- add_info :: SimpleOptEnv -> InVar -> TopLevelFlag -> OutExpr -> OutVar -> OutVar add_info env old_bndr top_level new_rhs new_bndr diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs index 24421cd6ddaa..2a038984a173 100644 --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -33,7 +33,7 @@ module GHC.Core.Subst ( cloneBndr, cloneBndrs, cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs, TSubst(..), - transientSubst, persistentSubst, substTyVarBndrT, substCoVarBndrT + transientSubst, persistentSubst, substTyT, substTyVarBndrT, substCoVarBndrT ) where import GHC.Prelude @@ -479,11 +479,7 @@ substBndr subst bndr substBndrT :: TSubst s -> Var -> ST s (TSubst s, Var) substBndrT subst bndr | isTyVar bndr = substTyVarBndrT subst bndr - | isCoVar bndr = do - persistent_subst <- persistentSubst subst - -- TODO: Make a substCoVarBndrT version of substCoVarBndr - let (subst', bndr') = substCoVarBndr persistent_subst bndr - return (transientSubst subst', bndr') + | isCoVar bndr = substCoVarBndrT subst bndr | otherwise = substIdBndrT (text "var-bndr") subst bndr -- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right From aeb1942c40ff42574345007c4f10e2763b19b820 Mon Sep 17 00:00:00 2001 From: Pascal Ellinger Date: Wed, 24 Aug 2022 23:26:39 +0200 Subject: [PATCH 10/17] Use the TInScopeSet in substExpr --- compiler/GHC/Core/Subst.hs | 81 +++++++++++++++++++++++++++----------- 1 file changed, 58 insertions(+), 23 deletions(-) diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs index 2a038984a173..b5a356bc96ce 100644 --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -374,37 +374,65 @@ substExprSC subst orig_expr -- See Note [Extending the Subst] substExpr :: HasDebugCallStack => Subst -> CoreExpr -> CoreExpr -- HasDebugCallStack so we can track failures in lookupIdSubst -substExpr subst expr +substExpr subst expr = runST $ substExprT (transientSubst subst) expr + +substExprT :: HasDebugCallStack => TSubst s -> CoreExpr -> ST s CoreExpr +substExprT subst expr = go expr where - go (Var v) = lookupIdSubst subst v - go (Type ty) = Type (substTy subst ty) - go (Coercion co) = Coercion (substCo subst co) - go (Lit lit) = Lit lit - go (App fun arg) = App (go fun) (go arg) - go (Tick tickish e) = mkTick (substTickish subst tickish) (go e) - go (Cast e co) = Cast (go e) (substCo subst co) + go (Var v) = lookupIdSubstT subst v + go (Type ty) = Type <$> (substTyT subst ty) + go (Lit lit) = return $ Lit lit + + go (Coercion co) = do + persistent_subst <- persistentSubst subst + return $ Coercion (substCo persistent_subst co) + + go (App fun arg) = do + _ <- persistentSubst subst + fun' <- go fun + arg' <- go arg + return $ App fun' arg' + + go (Tick tickish e) = do + t <- substTickishT subst tickish + e' <- go e + return $ mkTick t e' + + go (Cast e co) = do + persistent_subst <- persistentSubst subst + e' <- go e + return $ Cast e' (substCo persistent_subst co) -- Do not optimise even identity coercions -- Reason: substitution applies to the LHS of RULES, and -- if you "optimise" an identity coercion, you may -- lose a binder. We optimise the LHS of rules at -- construction time - go (Lam bndr body) = Lam bndr' (substExpr subst' body) - where - (subst', bndr') = substBndr subst bndr - - go (Let bind body) = Let bind' (substExpr subst' body) - where - (subst', bind') = substBind subst bind - - go (Case scrut bndr ty alts) = Case (go scrut) bndr' (substTy subst ty) (map (go_alt subst') alts) - where - (subst', bndr') = substBndr subst bndr - - go_alt subst (Alt con bndrs rhs) = Alt con bndrs' (substExpr subst' rhs) - where - (subst', bndrs') = substBndrs subst bndrs + go (Lam bndr body) = do + (subst', bndr') <- substBndrT subst bndr + body' <- substExprT subst' body + return $ Lam bndr' body' + + go (Let bind body) = do + persistent_subst <- persistentSubst subst + let (subst', bind') = substBind persistent_subst bind + body' <- substExprT (transientSubst subst') body + return $ Let bind' body' + + go (Case scrut bndr ty alts) = do + _ <- persistentSubst subst + scrut' <- go scrut + (subst', bndr') <- substBndrT subst bndr + persistent_subst' <- persistentSubst subst' + ty' <- substTyT subst ty + alts' <- mapM (go_alt persistent_subst') alts + return $ Case scrut' bndr' ty' alts' + + go_alt subst (Alt con bndrs rhs) = do + (subst', bndrs') <- substBndrsT (transientSubst subst) bndrs + rhs' <- substExprT subst' rhs + return $ Alt con bndrs' rhs' -- | Apply a substitution to an entire 'CoreBind', additionally returning an updated 'Subst' -- that should be used by subsequent substitutions. @@ -940,6 +968,13 @@ substTickish subst (Breakpoint ext n ids) do_one = getIdFromTrivialExpr . lookupIdSubst subst substTickish _subst other = other +substTickishT :: TSubst s -> CoreTickish -> ST s CoreTickish +substTickishT subst (Breakpoint ext n ids) + = Breakpoint ext n <$> (mapM do_one ids) + where + do_one id = getIdFromTrivialExpr <$> lookupIdSubstT subst id +substTickishT _subst other = return other + {- Note [Substitute lazily] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ The functions that substitute over IdInfo must be pretty lazy, because From 304bda0142e5ffd86b667ef86c013d77cc3c5ff9 Mon Sep 17 00:00:00 2001 From: Pascal Ellinger Date: Thu, 25 Aug 2022 19:03:11 +0200 Subject: [PATCH 11/17] Use the TInScopeSet in simplRecBndrs --- compiler/GHC/Core/Opt/Simplify/Env.hs | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs index 55b7a5fc5ba8..4932cb764c0c 100644 --- a/compiler/GHC/Core/Opt/Simplify/Env.hs +++ b/compiler/GHC/Core/Opt/Simplify/Env.hs @@ -861,12 +861,17 @@ simplNonRecBndr !env id --------------- simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv -- Recursive let binders -simplRecBndrs env@(SimplEnv {}) ids +simplRecBndrs env@(SimplEnv {}) ids = return $ runST $ do + env' <- simplRecBndrsT (transientSimplEnv env) ids + persistentSimplEnv env' + +simplRecBndrsT :: TSimplEnv s -> [InBndr] -> ST s (TSimplEnv s) +-- Recursive let binders +simplRecBndrsT env@(TSimplEnv {}) ids -- See Note [Bangs in the Simplifier] = assert (all (not . isJoinId) ids) $ - do { let (!env1, ids1) = mapAccumL substIdBndr env ids + do { (!env1, ids1) <- mapAccumLM substIdBndrT env ids ; seqIds ids1 `seq` return env1 } - --------------- substIdBndr :: SimplEnv -> InBndr -> (SimplEnv, OutBndr) -- Might be a coercion variable From 8680241a18f1e3a04a2ab00fa0afcdbb3a3b956f Mon Sep 17 00:00:00 2001 From: Pascal Ellinger Date: Thu, 25 Aug 2022 22:15:54 +0200 Subject: [PATCH 12/17] Add subst_co_t --- compiler/GHC/Core/TyCo/Subst.hs | 63 +++++++++++++++++++++++++++++---- 1 file changed, 57 insertions(+), 6 deletions(-) diff --git a/compiler/GHC/Core/TyCo/Subst.hs b/compiler/GHC/Core/TyCo/Subst.hs index 471a17a9bcb4..4368592016cf 100644 --- a/compiler/GHC/Core/TyCo/Subst.hs +++ b/compiler/GHC/Core/TyCo/Subst.hs @@ -836,14 +836,10 @@ subst_ty_t subst ty (subst', tv') -> return $! (ForAllTy $! ((Bndr $! tv') vis)) $! (subst_ty subst' ty) go (LitTy n) = return $ LitTy $! n - -- TODO: make a subst_co_t version of subst_co go (CastTy ty co) = do ty' <- go ty - persistent_subst <- persistentTCvSubst subst - return $! (mkCastTy $! ty') $! (subst_co persistent_subst co) - go (CoercionTy co) = do - persistent_subst <- persistentTCvSubst subst - return $! CoercionTy $! (subst_co persistent_subst co) + (mkCastTy $! ty') <$> (subst_co_t subst co) + go (CoercionTy co) = CoercionTy <$> (subst_co_t subst co) substTyVar :: TCvSubst -> TyVar -> Type substTyVar (TCvSubst _ tenv _) tv @@ -948,6 +944,55 @@ subst_co subst co go_hole h@(CoercionHole { ch_co_var = cv }) = h { ch_co_var = updateVarType go_ty cv } +-- | Persists 'subst' before it is modified. +subst_co_t :: TTCvSubst s -> Coercion -> ST s Coercion +subst_co_t subst co + = go co + where + go_ty = subst_ty_t subst + + go_mco MRefl = return MRefl + go_mco (MCo co) = MCo <$> go co + + go (Refl ty) = mkNomReflCo <$> (go_ty ty) + go (GRefl r ty mco) = (mkGReflCo r <$> (go_ty ty)) <*> (go_mco mco) + go (TyConAppCo r tc args) = do + args' <- mapM go args + args' `seqList` (return $ mkTyConAppCo r tc args') + go (AppCo co arg) = (mkAppCo <$> go co) <*> go arg + go (ForAllCo tv kind_co co) = do + persistent_subst <- persistentTCvSubst subst + case substForAllCoBndrUnchecked persistent_subst tv kind_co of + (subst', tv', kind_co') -> + return $! ((mkForAllCo $! tv') $! kind_co') $! subst_co subst' co + go (FunCo r w co1 co2) = ((mkFunCo r <$> go w) <*> go co1) <*> go co2 + go (CoVarCo cv) = return $ substCoVarT subst cv + go (AxiomInstCo con ind cos) = mkAxiomInstCo con ind <$> mapM go cos + go (UnivCo p r t1 t2) = do + p' <- go_prov p + (((mkUnivCo $! p') $! r) <$> (go_ty t1)) <*> (go_ty t2) + go (SymCo co) = mkSymCo <$> (go co) + go (TransCo co1 co2) = (mkTransCo <$> (go co1)) <*> (go co2) + go (NthCo r d co) = mkNthCo r d <$> (go co) + go (LRCo lr co) = mkLRCo lr <$> (go co) + go (InstCo co arg) = (mkInstCo <$> (go co)) <*> go arg + go (KindCo co) = mkKindCo <$> (go co) + go (SubCo co) = mkSubCo <$> (go co) + go (AxiomRuleCo c cs) = do + cs1 <- mapM go cs + cs1 `seqList` (return $ AxiomRuleCo c cs1) + go (HoleCo h) = HoleCo <$> go_hole h + + go_prov (PhantomProv kco) = PhantomProv <$> go kco + go_prov (ProofIrrelProv kco) = ProofIrrelProv <$> go kco + go_prov p@(PluginProv _) = return p + go_prov p@(CorePrepProv _) = return p + + -- See Note [Substituting in a coercion hole] + go_hole h@(CoercionHole { ch_co_var = cv }) = do + cv' <- updateVarTypeM go_ty cv + return h { ch_co_var = cv' } + substForAllCoBndr :: TCvSubst -> TyCoVar -> KindCoercion -> (TCvSubst, TyCoVar, Coercion) substForAllCoBndr subst @@ -1031,6 +1076,12 @@ substCoVar (TCvSubst _ _ cenv) cv Just co -> co Nothing -> CoVarCo cv +substCoVarT :: TTCvSubst s -> CoVar -> Coercion +substCoVarT (TTCvSubst _ _ cenv) cv + = case lookupVarEnv cenv cv of + Just co -> co + Nothing -> CoVarCo cv + substCoVars :: TCvSubst -> [CoVar] -> [Coercion] substCoVars subst cvs = map (substCoVar subst) cvs From c6b6417a3e6825339308ca87c10e9a67c823e212 Mon Sep 17 00:00:00 2001 From: Pascal Ellinger Date: Mon, 29 Aug 2022 09:30:48 +0200 Subject: [PATCH 13/17] Bump haskell-transients submodule --- libraries/haskell-transients | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libraries/haskell-transients b/libraries/haskell-transients index 0a6e94757399..61ee7f3d40b0 160000 --- a/libraries/haskell-transients +++ b/libraries/haskell-transients @@ -1 +1 @@ -Subproject commit 0a6e947573993d79833f6f9027513c91b94a8823 +Subproject commit 61ee7f3d40b01a03e4ec405d538586e90126fefc From b2b831dd10c59ecf79920031fe4ff36193d80301 Mon Sep 17 00:00:00 2001 From: Sebastian Graf Date: Tue, 30 Aug 2022 13:06:49 +0200 Subject: [PATCH 14/17] haskell-transients over SSH --- .gitmodules | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitmodules b/.gitmodules index a3b365fb3c0e..9e60f3bbc040 100644 --- a/.gitmodules +++ b/.gitmodules @@ -116,5 +116,5 @@ ignore = untracked [submodule "libraries/haskell-transients"] path = libraries/haskell-transients - url = https://github.com/PascEll/haskell-transients.git + url = git@github.com:PascEll/haskell-transients.git ignore = untracked From e505cde7a9564386c5c3f382f50cd51c32f6b496 Mon Sep 17 00:00:00 2001 From: Sebastian Graf Date: Tue, 30 Aug 2022 21:57:36 +0200 Subject: [PATCH 15/17] Perf tweaks --- compiler/GHC/Core/Opt/Simplify/Env.hs | 10 +++++---- compiler/GHC/Core/TyCo/Subst.hs | 31 +++++++++++++-------------- compiler/GHC/Types/Var/Env.hs | 6 +++--- libraries/haskell-transients | 2 +- 4 files changed, 25 insertions(+), 24 deletions(-) diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs index 4932cb764c0c..11f804d67283 100644 --- a/compiler/GHC/Core/Opt/Simplify/Env.hs +++ b/compiler/GHC/Core/Opt/Simplify/Env.hs @@ -1141,8 +1141,9 @@ substTyVarBndr env tv substTyVarBndrT :: TSimplEnv s -> TyVar -> ST s (TSimplEnv s, TyVar) substTyVarBndrT env tv = do - (TTCvSubst in_scope' tv_env' cv_env', tv') <- Type.substTyVarBndrT (getTTCvSubst env) tv - return (env { tseInScope = in_scope', tseTvSubst = tv_env', tseCvSubst = cv_env' }, tv') + (TTCvSubst in_scope' tv_env' cv_env', !tv') <- Type.substTyVarBndrT (getTTCvSubst env) tv + let !env' = env { tseInScope = in_scope', tseTvSubst = tv_env', tseCvSubst = cv_env' } + return (env', tv') substCoVar :: SimplEnv -> CoVar -> Coercion substCoVar env tv = Coercion.substCoVar (getTCvSubst env) tv @@ -1155,8 +1156,9 @@ substCoVarBndr env cv substCoVarBndrT :: TSimplEnv s -> CoVar -> ST s (TSimplEnv s, CoVar) substCoVarBndrT env cv = do - (TTCvSubst in_scope' tv_env' cv_env', cv') <- Coercion.substCoVarBndrT (getTTCvSubst env) cv - return (env { tseInScope = in_scope', tseTvSubst = tv_env', tseCvSubst = cv_env' }, cv') + (TTCvSubst in_scope' tv_env' cv_env', !cv') <- Coercion.substCoVarBndrT (getTTCvSubst env) cv + let !env' = env { tseInScope = in_scope', tseTvSubst = tv_env', tseCvSubst = cv_env' } + return (env', cv') substCo :: SimplEnv -> Coercion -> Coercion substCo env co = Coercion.substCo (getTCvSubst env) co diff --git a/compiler/GHC/Core/TyCo/Subst.hs b/compiler/GHC/Core/TyCo/Subst.hs index 4368592016cf..680b50b43754 100644 --- a/compiler/GHC/Core/TyCo/Subst.hs +++ b/compiler/GHC/Core/TyCo/Subst.hs @@ -580,9 +580,9 @@ substitution. substTyWith :: HasDebugCallStack => [TyVar] -> [Type] -> Type -> Type -- Works only if the domain of the substitution is a -- superset of the type being substituted into -substTyWith tvs tys = {-#SCC "substTyWith" #-} - assert (tvs `equalLength` tys ) - substTy (zipTvSubst tvs tys) +substTyWith tvs tys ty = {-#SCC "substTyWith" #-} + assert (tvs `equalLength` tys ) + substTy (zipTvSubst tvs tys) ty -- | Type substitution, see 'zipTvSubst'. Disables sanity checks. -- The problems that the sanity checks in substTy catch are described in @@ -590,9 +590,9 @@ substTyWith tvs tys = {-#SCC "substTyWith" #-} -- The goal of #11371 is to migrate all the calls of substTyUnchecked to -- substTy and remove this function. Please don't use in new code. substTyWithUnchecked :: [TyVar] -> [Type] -> Type -> Type -substTyWithUnchecked tvs tys +substTyWithUnchecked tvs tys ty = assert (tvs `equalLength` tys ) - substTyUnchecked (zipTvSubst tvs tys) + substTyUnchecked (zipTvSubst tvs tys) ty -- | Substitute tyvars within a type using a known 'InScopeSet'. -- Pre-condition: the 'in_scope' set should satisfy Note [The substitution @@ -606,8 +606,8 @@ substTyWithInScope in_scope tvs tys ty = -- | Coercion substitution, see 'zipTvSubst' substCoWith :: HasDebugCallStack => [TyVar] -> [Type] -> Coercion -> Coercion -substCoWith tvs tys = assert (tvs `equalLength` tys ) - substCo (zipTvSubst tvs tys) +substCoWith tvs tys co = assert (tvs `equalLength` tys ) + substCo (zipTvSubst tvs tys) co -- | Coercion substitution, see 'zipTvSubst'. Disables sanity checks. -- The problems that the sanity checks in substCo catch are described in @@ -615,25 +615,25 @@ substCoWith tvs tys = assert (tvs `equalLength` tys ) -- The goal of #11371 is to migrate all the calls of substCoUnchecked to -- substCo and remove this function. Please don't use in new code. substCoWithUnchecked :: [TyVar] -> [Type] -> Coercion -> Coercion -substCoWithUnchecked tvs tys +substCoWithUnchecked tvs tys co = assert (tvs `equalLength` tys ) - substCoUnchecked (zipTvSubst tvs tys) + substCoUnchecked (zipTvSubst tvs tys) co -- | Substitute covars within a type substTyWithCoVars :: [CoVar] -> [Coercion] -> Type -> Type -substTyWithCoVars cvs cos = substTy (zipCvSubst cvs cos) +substTyWithCoVars cvs cos ty = substTy (zipCvSubst cvs cos) ty -- | Type substitution, see 'zipTvSubst' substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type] -substTysWith tvs tys = assert (tvs `equalLength` tys ) - substTys (zipTvSubst tvs tys) +substTysWith tvs tys ty = assert (tvs `equalLength` tys ) + substTys (zipTvSubst tvs tys) ty -- | Type substitution, see 'zipTvSubst' substTysWithCoVars :: [CoVar] -> [Coercion] -> [Type] -> [Type] -substTysWithCoVars cvs cos = assert (cvs `equalLength` cos ) - substTys (zipCvSubst cvs cos) +substTysWithCoVars cvs cos tys = assert (cvs `equalLength` cos ) + substTys (zipCvSubst cvs cos) tys -- | Substitute within a 'Type' after adding the free variables of the type -- to the in-scope set. This is useful for the case when the free variables @@ -774,7 +774,7 @@ subst_ty :: TCvSubst -> Type -> Type -- -- Note that the in_scope set is poked only if we hit a forall -- so it may often never be fully computed -subst_ty subst ty +subst_ty !subst ty = go ty where go (TyVarTy tv) = substTyVar subst tv @@ -1306,4 +1306,3 @@ substTyCoBndr subst (Anon af ty) = (subst, Anon af (substScaledTy subst substTyCoBndr subst (Named (Bndr tv vis)) = (subst', Named (Bndr tv' vis)) where (subst', tv') = substVarBndr subst tv - diff --git a/compiler/GHC/Types/Var/Env.hs b/compiler/GHC/Types/Var/Env.hs index 183025845f40..b7d34d644049 100644 --- a/compiler/GHC/Types/Var/Env.hs +++ b/compiler/GHC/Types/Var/Env.hs @@ -246,7 +246,7 @@ mkInScopeSet :: VarSet -> InScopeSet mkInScopeSet in_scope = InScope (FastVarSet (WordMap.fromAscList $ map intKeyToWordKey $ varSetToAscList in_scope)) where - intKeyToWordKey (k, v) = (fromIntegral k, v) + intKeyToWordKey (k, v) = ((,) $! fromIntegral k) v extendInScopeSet :: InScopeSet -> Var -> InScopeSet extendInScopeSet (InScope in_scope) v @@ -293,7 +293,7 @@ mkTInScopeSet in_scope = do tmap <- WordMap.fromAscListT $ map intKeyToWordKey $ varSetToAscList in_scope return $ TInScope (TFastVarSet tmap) where - intKeyToWordKey (k, v) = (fromIntegral k, v) + intKeyToWordKey (k, v) = ((,) $! fromIntegral k) v extendTInScopeSet :: TInScopeSet s -> Var -> ST s (TInScopeSet s) extendTInScopeSet (TInScope in_scope) v @@ -401,7 +401,7 @@ unsafeGetFreshLocalUniqueT (TInScope (TFastVarSet set)) = do case mb_uniq of Just (uniq,_) | let uniq' = mkLocalUnique (fromIntegral uniq) - , not $ uniq' `ltUnique` minLocalUnique + , not $ uniq' `ltUnique` minLocalUnique -> return $! incrUnique uniq' _ -> return minLocalUnique diff --git a/libraries/haskell-transients b/libraries/haskell-transients index 61ee7f3d40b0..56de7f1dd0c3 160000 --- a/libraries/haskell-transients +++ b/libraries/haskell-transients @@ -1 +1 @@ -Subproject commit 61ee7f3d40b01a03e4ec405d538586e90126fefc +Subproject commit 56de7f1dd0c3e8a5562392b04a0b68c45e6d58de From 7d285589015165418c4f1ad041feae561ad8fa79 Mon Sep 17 00:00:00 2001 From: Sebastian Graf Date: Wed, 7 Sep 2022 14:27:55 +0200 Subject: [PATCH 16/17] Bump for NOINLINE shareNode/unsafePersistNode --- libraries/haskell-transients | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libraries/haskell-transients b/libraries/haskell-transients index 56de7f1dd0c3..687ff8343a76 160000 --- a/libraries/haskell-transients +++ b/libraries/haskell-transients @@ -1 +1 @@ -Subproject commit 56de7f1dd0c3e8a5562392b04a0b68c45e6d58de +Subproject commit 687ff8343a76597049612096155ce1a016fd9925 From bc4ea4ee1350de3add61c3fed5d80795e883c2cd Mon Sep 17 00:00:00 2001 From: Sebastian Graf Date: Thu, 8 Sep 2022 17:53:31 +0200 Subject: [PATCH 17/17] The Rewrite Rule --- compiler/GHC/Builtin/Names.hs | 48 +++++++++++++++---- compiler/GHC/Core/Opt/Simplify.hs | 78 ++++++++++++++++++++++++++++++- compiler/GHC/Unit/Types.hs | 11 ++++- hadrian/src/Settings/Packages.hs | 4 ++ libraries/haskell-transients | 2 +- 5 files changed, 128 insertions(+), 15 deletions(-) diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index 115a7f53f4fb..dfa36b26757a 100644 --- a/compiler/GHC/Builtin/Names.hs +++ b/compiler/GHC/Builtin/Names.hs @@ -497,6 +497,12 @@ basicKnownKeyNames , unsafeEqualityTyConName , unsafeReflDataConName , unsafeCoercePrimName + + -- unsafePersistNode/shareNode rewrite rule + , unsafePersistNodeName + , shareNodeName + , wordMapTyConName + , tWordMapTyConName ] genericTyConNames :: [Name] @@ -644,6 +650,9 @@ gHC_RECORDS = mkBaseModule (fsLit "GHC.Records") rOOT_MAIN :: Module rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation +wORD_MAP :: Module +wORD_MAP = mkModule transientsUnit (mkModuleNameFS (fsLit "WordMap")) + mkInteractiveModule :: Int -> Module -- (mkInteractiveMoudule 9) makes module 'interactive:Ghci9' mkInteractiveModule n = mkModule interactiveUnit (mkModuleName ("Ghci" ++ show n)) @@ -1102,16 +1111,6 @@ joinMName, alternativeClassName :: Name joinMName = varQual gHC_BASE (fsLit "join") joinMIdKey alternativeClassName = clsQual mONAD (fsLit "Alternative") alternativeClassKey --- -joinMIdKey, apAClassOpKey, pureAClassOpKey, thenAClassOpKey, - alternativeClassKey :: Unique -joinMIdKey = mkPreludeMiscIdUnique 750 -apAClassOpKey = mkPreludeMiscIdUnique 751 -- <*> -pureAClassOpKey = mkPreludeMiscIdUnique 752 -thenAClassOpKey = mkPreludeMiscIdUnique 753 -alternativeClassKey = mkPreludeMiscIdUnique 754 - - -- Functions for GHC extensions considerAccessibleName :: Name considerAccessibleName = varQual gHC_EXTS (fsLit "considerAccessible") considerAccessibleIdKey @@ -1654,6 +1653,12 @@ fingerprintDataConName :: Name fingerprintDataConName = dcQual gHC_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey +shareNodeName, unsafePersistNodeName, wordMapTyConName, tWordMapTyConName :: Name +shareNodeName = varQual wORD_MAP (fsLit "shareNode") shareNodeIdKey +unsafePersistNodeName = varQual wORD_MAP (fsLit "unsafePersistNode") unsafePersistNodeIdKey +wordMapTyConName = tcQual wORD_MAP (fsLit "WordMap") wordMapTyConKey +tWordMapTyConName = tcQual wORD_MAP (fsLit "TWordMap") tWordMapTyConKey + {- ************************************************************************ * * @@ -2674,6 +2679,29 @@ mkRationalBase2IdKey, mkRationalBase10IdKey :: Unique mkRationalBase2IdKey = mkPreludeMiscIdUnique 700 mkRationalBase10IdKey = mkPreludeMiscIdUnique 701 :: Unique +------------------------------------------------------ +-- Applicative/Alternative/Monad combinators 750-754 uniques +------------------------------------------------------ + +joinMIdKey, apAClassOpKey, pureAClassOpKey, thenAClassOpKey, + alternativeClassKey :: Unique +joinMIdKey = mkPreludeMiscIdUnique 750 +apAClassOpKey = mkPreludeMiscIdUnique 751 -- <*> +pureAClassOpKey = mkPreludeMiscIdUnique 752 +thenAClassOpKey = mkPreludeMiscIdUnique 753 +alternativeClassKey = mkPreludeMiscIdUnique 754 + + +------------------------------------------------------ +-- haskell-transients 755-759 uniques +------------------------------------------------------ + +shareNodeIdKey, unsafePersistNodeIdKey, wordMapTyConKey, tWordMapTyConKey :: Unique +shareNodeIdKey = mkPreludeMiscIdUnique 755 +unsafePersistNodeIdKey = mkPreludeMiscIdUnique 756 +wordMapTyConKey = mkPreludeMiscIdUnique 757 +tWordMapTyConKey = mkPreludeMiscIdUnique 758 + {- ************************************************************************ * * diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 0f842be2d3ce..5aefb6716a1e 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -53,7 +53,7 @@ import GHC.Types.SourceText import GHC.Types.Id import GHC.Types.Id.Make ( seqId ) import GHC.Types.Id.Info -import GHC.Types.Name ( mkSystemVarName, isExternalName, getOccFS ) +import GHC.Types.Name ( mkSystemVarName, isExternalName, getOccFS, nameModule, nameUnique ) import GHC.Types.Demand import GHC.Types.Cpr ( mkCprSig, botCpr ) import GHC.Types.Unique ( hasKey ) @@ -62,7 +62,7 @@ import GHC.Types.Tickish import GHC.Types.Var ( isTyCoVar ) import GHC.Builtin.PrimOps ( PrimOp (SeqOp) ) import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) -import GHC.Builtin.Names( runRWKey ) +import GHC.Builtin.Names( runRWKey, unsafePersistNodeIdKey, shareNodeIdKey, unsafePersistNodeName ) import GHC.Data.Maybe ( isNothing, orElse ) import GHC.Data.FastString @@ -77,6 +77,11 @@ import GHC.Utils.Logger import GHC.Utils.Misc import Control.Monad +import GHC.Unit.Types (moduleUnit) +import GHC.Unit.State (unitPackageName) +import GHC.Unit (unitFS) +import GHC.Builtin.Utils (knownKeyNames) +import GHC.Core.TyCo.Rep (UnivCoProvenance(CorePrepProv)) {- The guts of the simplifier is in this module, but the driver loop for @@ -2889,6 +2894,19 @@ rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont ; case mb_rule of Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont' Nothing -> reallyRebuildCase env scrut case_bndr alts cont } + + -- 2d. Try the builtin unsafePersistNode/shareNode rule. Recall that + -- + -- > shareNode :: forall s a. Node a -> TNode s a + -- > unsafePersistNode :: forall s a. TNode s a -> State# s -> (# State# s, Node a #) + -- + -- Now if + -- a) the scrutinee is `unsafePersistNode @RealWorld @ty_a tn s` + -- b) The case alt looks like `(# s', n #) -> rhs[s', shareNode @RealWorld @ty_a n]` + -- c) n's OccInfo tells us that its only OneOcc is in that call to shareNode + -- Then rewrite the expr to `rhs[s, tn]`. + | Just (env', rhs') <- rewriteTransientPersistent env scrut case_bndr bndrs rhs + = simplExprF env' rhs' cont where all_dead_bndrs = all isDeadBinder bndrs -- bndrs are [InId] is_plain_seq = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect @@ -2896,6 +2914,62 @@ rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont rebuildCase env scrut case_bndr alts cont = reallyRebuildCase env scrut case_bndr alts cont +-- shareNode :: forall s a. Node a -> TNode s a +-- unsafePersistNode :: forall s a. TNode s a -> State# s -> (# State# s, Node a #) +-- case unsafePersistNode @ty_s @ty_a tm s of +-- (# s', m #) -> E[s', shareNode @ty_s @ty_a m] +-- ==> { if `shareNode m` is the only occurrence of m and not under a multishot lambda } +-- E[s, tm] +rewriteTransientPersistent :: SimplEnv -> OutExpr -> InId -> [InId] -> InExpr -> Maybe (SimplEnv, InExpr) +rewriteTransientPersistent env scrut case_bndr alt_bndrs rhs + | isDeadBinder case_bndr -- Otherwise we might dup the map + , [s', m] <- alt_bndrs -- (# s', m #) -> +-- , pprTrace "rewrite? 1" (ppr scrut) True + , OneOcc { occ_in_lam = NotInsideLam } <- idOccInfo m +-- , pprTrace "rewrite? occ OK 2" empty True + , (Var fun_id, [_ty_s, _ty_a, tm, Var s]) <- collectArgs scrut -- unsafePersistNode @ty_s @ty_a (tm :: TWordMap ty_s ty_a) RealWorld +-- , pprTrace "rewrite? App recogn 3" (ppr fun_id) True + , fun_id `hasKey` unsafePersistNodeIdKey +-- , pprTrace "rewrite? Id matches 4" empty True + , let tm_in_id = mkLocalId (idName m) (idMult m) (exprType tm) -- we simply take m's InId Unique as the InId Unique for tm + , Just rhs' <- rw m tm_in_id rhs +-- , pprTrace "rewrite? Yes!" (ppr rhs $$ ppr rhs') True + , let env' = extendIdSubst (extendIdSubst env tm_in_id (DoneEx tm Nothing)) s' (DoneId s) + = Just (env', rhs') -- substitute s for s' + | otherwise + = Nothing + where + rw :: InId -> InId -> InExpr -> Maybe InExpr + rw m tm e = go e + where + go e@App{} = case collectArgs e of + (Var fun_id, [_ty_s, _ty_a, Var m']) + | fun_id `hasKey` shareNodeIdKey + , m == m' + , let co = mkUnivCo (CorePrepProv False) Representational (idType tm) (exprType e) + , pprTrace "rw: found app" (ppr e $$ ppr co) True + -> Just (mkCast (Var tm) co) + (f, args) + -> mkApps <$> go f <*> traverse go args + go (Var v) | v == m = Nothing -- at least one occurrence outside of a unsafePersistNode call ==> abort + go (Tick t e) = Tick t <$> go e + go (Cast e c) = flip Cast c <$> go e + go (Lam b e) = Lam b <$> shadow [b] go e + go (Case s b ty alts) = Case <$> go s <*> pure b <*> pure ty <*> traverse (shadow [b] go_alt) alts + go (Let b e) = Let <$> go_bind b <*> shadow (bindersOf b) go e + go e = Just e + + shadow :: [Var] -> (a -> Maybe a) -> a -> Maybe a + shadow bs f a | m `elem` bs = Just a -- NB: Don't need to check tm because it has the same unique as m + | otherwise = f a + + go_bind (NonRec b e) = NonRec b <$> go e + go_bind (Rec pairs) = (Rec . zip bs) <$> traverse (shadow bs go) rhss + where + (bs, rhss) = unzip pairs + + go_alt (Alt con bs rhs) = Alt con bs <$> shadow bs go rhs + doCaseToLet :: OutExpr -- Scrutinee -> InId -- Case binder diff --git a/compiler/GHC/Unit/Types.hs b/compiler/GHC/Unit/Types.hs index f71ce9c02e70..d769ad4ded93 100644 --- a/compiler/GHC/Unit/Types.hs +++ b/compiler/GHC/Unit/Types.hs @@ -67,6 +67,7 @@ module GHC.Unit.Types , mainUnitId , thisGhcUnitId , interactiveUnitId + , transientsUnitId , primUnit , bignumUnit @@ -76,6 +77,7 @@ module GHC.Unit.Types , mainUnit , thisGhcUnit , interactiveUnit + , transientsUnit , isInteractiveModule , wiredInUnitIds @@ -581,10 +583,12 @@ Make sure you change 'GHC.Unit.State.findWiredInUnits' if you add an entry here. -} bignumUnitId, primUnitId, baseUnitId, rtsUnitId, - thUnitId, mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId + thUnitId, mainUnitId, thisGhcUnitId, interactiveUnitId, + transientsUnitId :: UnitId bignumUnit, primUnit, baseUnit, rtsUnit, - thUnit, mainUnit, thisGhcUnit, interactiveUnit :: Unit + thUnit, mainUnit, thisGhcUnit, interactiveUnit, + transientsUnit :: Unit primUnitId = UnitId (fsLit "ghc-prim") bignumUnitId = UnitId (fsLit "ghc-bignum") @@ -593,6 +597,7 @@ rtsUnitId = UnitId (fsLit "rts") thisGhcUnitId = UnitId (fsLit "ghc") interactiveUnitId = UnitId (fsLit "interactive") thUnitId = UnitId (fsLit "template-haskell") +transientsUnitId = UnitId (fsLit "haskell-transients") thUnit = RealUnit (Definite thUnitId) primUnit = RealUnit (Definite primUnitId) @@ -601,6 +606,7 @@ baseUnit = RealUnit (Definite baseUnitId) rtsUnit = RealUnit (Definite rtsUnitId) thisGhcUnit = RealUnit (Definite thisGhcUnitId) interactiveUnit = RealUnit (Definite interactiveUnitId) +transientsUnit = RealUnit (Definite transientsUnitId) -- | This is the package Id for the current program. It is the default -- package Id if you don't specify a package name. We don't add this prefix @@ -619,6 +625,7 @@ wiredInUnitIds = , rtsUnitId , thUnitId , thisGhcUnitId + , transientsUnitId ] --------------------------------------------------------------------- diff --git a/hadrian/src/Settings/Packages.hs b/hadrian/src/Settings/Packages.hs index aa61147ccda5..9f176f68b47c 100644 --- a/hadrian/src/Settings/Packages.hs +++ b/hadrian/src/Settings/Packages.hs @@ -159,6 +159,10 @@ packageArgs = do ? notM (expr $ anyTargetOs ["freebsd", "solaris2"])? mconcat [ builder (Ghc LinkHs) ? arg "-optl-Wl,--export-dynamic" ] + -------------------------------- haskell-transients ------------------------------- + , package haskellTransients ? + builder (Cabal Flags) ? notStage0 `cabalFlag` "wired-in" + -------------------------------- haddock ------------------------------- , package haddock ? builder (Cabal Flags) ? arg "in-ghc-tree" diff --git a/libraries/haskell-transients b/libraries/haskell-transients index 687ff8343a76..4ed6c9ea5527 160000 --- a/libraries/haskell-transients +++ b/libraries/haskell-transients @@ -1 +1 @@ -Subproject commit 687ff8343a76597049612096155ce1a016fd9925 +Subproject commit 4ed6c9ea55276ecf4582dde3ac45becef218b03d