[Git][ghc/ghc][wip/andreask/rec_field_shapes] WIP: Try harder to detect recursive fields

[Andreas Klebinger]

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


Commits:
750101f2 by Andreas Klebinger at 2020-06-13T17:32:54+02:00
WIP: Try harder to detect recursive fields

- - - - -


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,14 @@ findBndrDmd env arg_of_dfun dmd_ty id
   = (dmd_ty', dmd')
   where
     dmd' = strictify $
-           trimToType starting_dmd (findTypeShape fam_envs id_ty)
+          --  pprTrace "trimToType"
+          --     (ppr id <> text "::" <> ppr id_ty $$
+          --      text "shape" <+> ppr (findTypeShape fam_envs id_ty) $$
+          --     (text "untrimmed" <+> ppr starting_dmd) $$
+          --     (text "trimmed" <+> ppr (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,34 +1003,61 @@ 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
+  = go emptyTM (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
   where
-    go rec_tc ty
+    fieldShape :: TypeMap () -> RecTcChecker -> Type -> Type -> TypeShape
+    fieldShape tyMap rec_tc origTy fldTy
+      | Just _ <- lookupTypeMap tyMap' fldTy = TsRecField
+      | otherwise = go tyMap' rec_tc fldTy
+      where
+        tyMap' = extendTypeMap tyMap origTy ()
+    go tyMap rec_tc ty
        | Just (_, res) <- splitFunTy_maybe ty
-       = TsFun (go rec_tc res)
+       = TsFun (go tyMap rec_tc res)
 
+       -- Tuples are never recursive
        | 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
+       , isTupleTyCon tc
+       = TsProd (map (go tyMap rec_tc) (dataConInstArgTys con tc_args))
+
+       | Just (tc, tc_args)  <- splitTyConApp_maybe ty
+       , Just con <- isDataProductTyCon_maybe tc
+      --  , fieldTys <- dataConInstArgTys con
+       = TsProd (map (fieldShape tyMap rec_tc ty) (dataConInstArgTys con tc_args))
+
+       -- Check for recursion using rec_tc
+       | Just (tc, tc_args)  <- splitTyConApp_maybe ty
+       , Just con <- isDataProductTyCon_maybe tc
+       , Just rec_tc <- 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 (go tyMap rec_tc) (dataConInstArgTys con tc_args))
 
        | Just (_, ty') <- splitForAllTy_maybe ty
-       = go rec_tc ty'
+       = go tyMap rec_tc ty'
 
        | Just (_, ty') <- topNormaliseType_maybe fam_envs ty
-       = go rec_tc ty'
+       = go tyMap rec_tc ty'
 
        | otherwise
        = TsUnk
 
+
+    --    , Just con <- isDataProductTyCon_maybe tc
+    --    , False
+    --    = let rec_tc
+    --             | isTupleTyCon tc = Just rec_tc
+    --             | otherwise = checkRecTc rec_tc tc
+    --      in
+    --      -- 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))
+
 {-
 ************************************************************************
 *                                                                      *


=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -833,6 +833,7 @@ data TypeShape -- See Note [Trimming a demand to a type]
                --     in GHC.Core.Opt.DmdAnal
   = TsFun TypeShape
   | TsProd [TypeShape]
+  | TsRecField
   | TsUnk
 
 trimToType :: Demand -> TypeShape -> Demand
@@ -864,6 +865,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/750101f2567cf3323a321c6108a1ca4fb6d80001

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/750101f2567cf3323a321c6108a1ca4fb6d80001
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/20200613/ef26b7ab/attachment-0001.html>