[Git][ghc/ghc][wip/andreask/rec_field_shapes] findTypeShape: Properly deal with recursive types.

[Andreas Klebinger]

Andreas Klebinger pushed to branch wip/andreask/rec_field_shapes at Glasgow Haskell Compiler / GHC


Commits:
1a29762d by Andreas Klebinger at 2020-06-15T01:30:35+02:00
findTypeShape: Properly deal with recursive types.

Now we check for recursive types by:
* Traversing the data type in a dfs fashion.
* Remembering seen types along the way.
* Bailing out if any type is seen twice along a path.

This is sadly less performant than what we did before. Where we simply looked
at TyCon's instead of types. However it properly distinguishes between
nested non-recursive ty-cons and recursive types. Something the old
approach was fundamentally not able to do.

- - - - -


3 changed files:

- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Types/Demand.hs


Changes:

=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -48,6 +48,7 @@ import GHC.Types.Unique.Set
 ************************************************************************
 -}
 
+{-# NOINLINE dmdAnalProgram #-}
 dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
 dmdAnalProgram dflags fam_envs binds = do
   let env             = emptyAnalEnv dflags fam_envs
@@ -1252,7 +1253,7 @@ findBndrDmd env arg_of_dfun dmd_ty id
   = (dmd_ty', dmd')
   where
     dmd' = strictify $
-           trimToType starting_dmd (findTypeShape fam_envs id_ty)
+                trimToType starting_dmd (findTypeShape fam_envs id_ty)
 
     (dmd_ty', starting_dmd) = peelFV dmd_ty id
 


=====================================
compiler/GHC/Core/Opt/WorkWrap/Utils.hs
=====================================
@@ -40,12 +40,14 @@ import GHC.Core.Coercion
 import GHC.Core.FamInstEnv
 import GHC.Types.Basic       ( Boxity(..) )
 import GHC.Core.TyCon
+import GHC.Core.Map (TypeMap, lookupTypeMap, extendTypeMap)
 import GHC.Types.Unique.Supply
 import GHC.Types.Unique
 import GHC.Data.Maybe
 import GHC.Utils.Misc
 import GHC.Utils.Outputable
 import GHC.Driver.Session
+import GHC.Data.TrieMap
 import GHC.Data.FastString
 import GHC.Data.List.SetOps
 
@@ -1001,30 +1003,47 @@ findTypeShape :: FamInstEnvs -> Type -> TypeShape
 -- The data type TypeShape is defined in GHC.Types.Demand
 -- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal
 findTypeShape fam_envs ty
-  = go (setRecTcMaxBound 2 initRecTc) ty
-       -- You might think this bound of 2 is low, but actually
-       -- I think even 1 would be fine.  This only bites for recursive
-       -- product types, which are rare, and we really don't want
-       -- to look deep into such products -- see #18034
+  = go emptyTM ty
+       -- We keep track of types we have seen to avoid looking deep
+       -- into recursive types -- see #18304.
+
+       -- The solution is simple. If a type is recursive one of it's
+       -- fields will eventually mention it's outermost type.
+       -- So we check for this using TypeMap.
+
+       -- TypeMap isn't ideal for this. It covers types we will never
+       -- see here, and it wastes space as it's a map used as set.
+
+       -- This makes this somewhat more expensive (~0.1 allocations)
+       -- than using checkRecTc. But it's more precise as things like
+       -- deeply nested tuples won't bail out early so still desireable.
+
+       -- Implementing a typeset suitable for this use could increase
+       -- performance further if this ever becomes a bottleneck.
+
   where
-    go rec_tc ty
+    prodFieldShape :: TypeMap () -> Type -> Type -> TypeShape
+    prodFieldShape tyMap origTy fldTy
+      | Just _ <- lookupTypeMap tyMap' fldTy
+      = TsRecField
+      | otherwise
+      = go tyMap' fldTy
+      where
+        tyMap' = extendTypeMap tyMap origTy ()
+    go tyMap ty
        | Just (_, res) <- splitFunTy_maybe ty
-       = TsFun (go rec_tc res)
+       = TsFun (go tyMap res)
 
+       -- Product types
        | Just (tc, tc_args)  <- splitTyConApp_maybe ty
        , Just con <- isDataProductTyCon_maybe tc
-       , Just rec_tc <- if isTupleTyCon tc
-                        then Just rec_tc
-                        else checkRecTc rec_tc tc
-         -- We treat tuples specially because they can't cause loops.
-         -- Maybe we should do so in checkRecTc.
-       = TsProd (map (go rec_tc) (dataConInstArgTys con tc_args))
+       = TsProd (map (prodFieldShape tyMap ty) (dataConInstArgTys con tc_args))
 
        | Just (_, ty') <- splitForAllTy_maybe ty
-       = go rec_tc ty'
+       = go tyMap ty'
 
        | Just (_, ty') <- topNormaliseType_maybe fam_envs ty
-       = go rec_tc ty'
+       = go tyMap ty'
 
        | otherwise
        = TsUnk


=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -833,6 +833,8 @@ data TypeShape -- See Note [Trimming a demand to a type]
                --     in GHC.Core.Opt.DmdAnal
   = TsFun TypeShape
   | TsProd [TypeShape]
+  | TsRecField -- ^ A field which refers to a type it's a part of.
+               -- e.g. the second field in data T = MkT Int T
   | TsUnk
 
 trimToType :: Demand -> TypeShape -> Demand
@@ -864,6 +866,7 @@ trimToType (JD { sd = ms, ud = mu }) ts
 
 instance Outputable TypeShape where
   ppr TsUnk        = text "TsUnk"
+  ppr TsRecField   = text "TsRecField"
   ppr (TsFun ts)   = text "TsFun" <> parens (ppr ts)
   ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss)
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1a29762d494ef8ee99caaf7792398923e566a32a

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1a29762d494ef8ee99caaf7792398923e566a32a
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200614/5934eef7/attachment-0001.html>