Avoid orphans in STG

This patch removes some orphan instances in the STG namespace
by introducing the GHC.Stg.Lift.Types module, which allows various
type family instances to be moved to GHC.Stg.Syntax, avoiding orphan
instances.

10 files changed, 149 insertions, 111 deletions

diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs
index 9684c20ad5..c077b28557 100644
--- a/compiler/GHC/Iface/Make.hs
+++ b/compiler/GHC/Iface/Make.hs
@@ -98,7 +98,7 @@ import Data.Function
 import Data.List ( findIndex, mapAccumL, sortBy )
 import Data.Ord
 import Data.IORef
-import GHC.Stg.Pipeline (StgCgInfos)
+import GHC.Stg.InferTags.TagSig (StgCgInfos)
 
 
 {-
diff --git a/compiler/GHC/Stg/InferTags/TagSig.hs b/compiler/GHC/Stg/InferTags/TagSig.hs
index 391c9e35a3..6d3bbf2d5e 100644
--- a/compiler/GHC/Stg/InferTags/TagSig.hs
+++ b/compiler/GHC/Stg/InferTags/TagSig.hs
@@ -13,11 +13,21 @@ where
 import GHC.Prelude
 
 import GHC.Types.Var
+import GHC.Types.Name.Env( NameEnv )
 import GHC.Utils.Outputable
 import GHC.Utils.Binary
 import GHC.Utils.Panic.Plain
 import Data.Coerce
 
+-- | Information to be exposed in interface files which is produced
+-- by the stg2stg passes.
+type StgCgInfos = NameEnv TagSig
+
+newtype TagSig  -- The signature for each binding, this is a newtype as we might
+                -- want to track more information in the future.
+  = TagSig TagInfo
+  deriving (Eq)
+
 data TagInfo
   = TagDunno            -- We don't know anything about the tag.
   | TagTuple [TagInfo]  -- Represents a function/thunk which when evaluated
@@ -46,11 +56,6 @@ instance Binary TagInfo where
                           4 -> return TagTagged
                           _ -> panic ("get TagInfo " ++ show tag)
 
-newtype TagSig  -- The signature for each binding, this is a newtype as we might
-                -- want to track more information in the future.
-  = TagSig TagInfo
-  deriving (Eq)
-
 instance Outputable TagSig where
   ppr (TagSig ti) = char '<' <> ppr ti <> char '>'
 instance OutputableBndr (Id,TagSig) where
diff --git a/compiler/GHC/Stg/InferTags/Types.hs b/compiler/GHC/Stg/InferTags/Types.hs
index bcb1f3300b..e6ee76e0e4 100644
--- a/compiler/GHC/Stg/InferTags/Types.hs
+++ b/compiler/GHC/Stg/InferTags/Types.hs
@@ -30,11 +30,6 @@ import GHC.StgToCmm.Types
 *                                                                      *
 ********************************************************************* -}
 
-type instance BinderP      'InferTaggedBinders = (Id, TagSig)
-type instance XLet         'InferTaggedBinders = XLet         'CodeGen
-type instance XLetNoEscape 'InferTaggedBinders = XLetNoEscape 'CodeGen
-type instance XRhsClosure  'InferTaggedBinders = XRhsClosure  'CodeGen
-
 type InferStgTopBinding = GenStgTopBinding 'InferTaggedBinders
 type InferStgBinding    = GenStgBinding    'InferTaggedBinders
 type InferStgExpr       = GenStgExpr       'InferTaggedBinders
diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs
index dbb9504813..abc4c69ca0 100644
--- a/compiler/GHC/Stg/Lift/Analysis.hs
+++ b/compiler/GHC/Stg/Lift/Analysis.hs
@@ -27,9 +27,13 @@ import GHC.Platform.Profile
 import GHC.Types.Basic
 import GHC.Types.Demand
 import GHC.Types.Id
+
 import GHC.Runtime.Heap.Layout ( WordOff )
+
 import GHC.Stg.Lift.Config
+import GHC.Stg.Lift.Types
 import GHC.Stg.Syntax
+
 import qualified GHC.StgToCmm.ArgRep  as StgToCmm.ArgRep
 import qualified GHC.StgToCmm.Closure as StgToCmm.Closure
 import qualified GHC.StgToCmm.Layout  as StgToCmm.Layout
@@ -110,80 +114,6 @@ llTrace :: String -> SDoc -> a -> a
 llTrace _ _ c = c
 -- llTrace a b c = pprTrace a b c
 
-type instance BinderP      'LiftLams = BinderInfo
-type instance XRhsClosure  'LiftLams = DIdSet
-type instance XLet         'LiftLams = Skeleton
-type instance XLetNoEscape 'LiftLams = Skeleton
-
-
--- | Captures details of the syntax tree relevant to the cost model, such as
--- closures, multi-shot lambdas and case expressions.
-data Skeleton
-  = ClosureSk !Id !DIdSet {- ^ free vars -} !Skeleton
-  | RhsSk !Card {- ^ how often the RHS was entered -} !Skeleton
-  | AltSk !Skeleton !Skeleton
-  | BothSk !Skeleton !Skeleton
-  | NilSk
-
-bothSk :: Skeleton -> Skeleton -> Skeleton
-bothSk NilSk b = b
-bothSk a NilSk = a
-bothSk a b     = BothSk a b
-
-altSk :: Skeleton -> Skeleton -> Skeleton
-altSk NilSk b = b
-altSk a NilSk = a
-altSk a b     = AltSk a b
-
-rhsSk :: Card -> Skeleton -> Skeleton
-rhsSk _        NilSk = NilSk
-rhsSk body_dmd skel  = RhsSk body_dmd skel
-
--- | The type used in binder positions in 'GenStgExpr's.
-data BinderInfo
-  = BindsClosure !Id !Bool -- ^ Let(-no-escape)-bound thing with a flag
-                           --   indicating whether it occurs as an argument
-                           --   or in a nullary application
-                           --   (see "GHC.Stg.Lift.Analysis#arg_occs").
-  | BoringBinder !Id       -- ^ Every other kind of binder
-
--- | Gets the bound 'Id' out a 'BinderInfo'.
-binderInfoBndr :: BinderInfo -> Id
-binderInfoBndr (BoringBinder bndr)   = bndr
-binderInfoBndr (BindsClosure bndr _) = bndr
-
--- | Returns 'Nothing' for 'BoringBinder's and 'Just' the flag indicating
--- occurrences as argument or in a nullary applications otherwise.
-binderInfoOccursAsArg :: BinderInfo -> Maybe Bool
-binderInfoOccursAsArg BoringBinder{}     = Nothing
-binderInfoOccursAsArg (BindsClosure _ b) = Just b
-
-instance Outputable Skeleton where
-  ppr NilSk = text ""
-  ppr (AltSk l r) = vcat
-    [ text "{ " <+> ppr l
-    , text "ALT"
-    , text "  " <+> ppr r
-    , text "}"
-    ]
-  ppr (BothSk l r) = ppr l $$ ppr r
-  ppr (ClosureSk f fvs body) = ppr f <+> ppr fvs $$ nest 2 (ppr body)
-  ppr (RhsSk card body) = hcat
-    [ lambda
-    , ppr card
-    , dot
-    , ppr body
-    ]
-
-instance Outputable BinderInfo where
-  ppr = ppr . binderInfoBndr
-
-instance OutputableBndr BinderInfo where
-  pprBndr b = pprBndr b . binderInfoBndr
-  pprPrefixOcc = pprPrefixOcc . binderInfoBndr
-  pprInfixOcc = pprInfixOcc . binderInfoBndr
-  bndrIsJoin_maybe = bndrIsJoin_maybe . binderInfoBndr
-
 mkArgOccs :: [StgArg] -> IdSet
 mkArgOccs = mkVarSet . mapMaybe stg_arg_var
   where
diff --git a/compiler/GHC/Stg/Lift/Types.hs b/compiler/GHC/Stg/Lift/Types.hs
new file mode 100644
index 0000000000..c59cde5f38
--- /dev/null
+++ b/compiler/GHC/Stg/Lift/Types.hs
@@ -0,0 +1,92 @@
+{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+
+-- This module declares some basic types used by GHC.Stg.Lift
+-- We can import this module into GHC.Stg.Syntax, where the
+-- type instance declartions for BinderP etc live
+
+module GHC.Stg.Lift.Types(
+   Skeleton(..),
+   bothSk, altSk, rhsSk,
+
+   BinderInfo(..),
+   binderInfoBndr, binderInfoOccursAsArg
+   ) where
+
+import GHC.Prelude
+
+import GHC.Types.Id
+import GHC.Types.Demand
+import GHC.Types.Var.Set
+
+import GHC.Utils.Outputable
+
+-- | Captures details of the syntax tree relevant to the cost model, such as
+-- closures, multi-shot lambdas and case expressions.
+data Skeleton
+  = ClosureSk !Id !DIdSet {- ^ free vars -} !Skeleton
+  | RhsSk !Card {- ^ how often the RHS was entered -} !Skeleton
+  | AltSk !Skeleton !Skeleton
+  | BothSk !Skeleton !Skeleton
+  | NilSk
+
+bothSk :: Skeleton -> Skeleton -> Skeleton
+bothSk NilSk b = b
+bothSk a NilSk = a
+bothSk a b     = BothSk a b
+
+altSk :: Skeleton -> Skeleton -> Skeleton
+altSk NilSk b = b
+altSk a NilSk = a
+altSk a b     = AltSk a b
+
+rhsSk :: Card -> Skeleton -> Skeleton
+rhsSk _        NilSk = NilSk
+rhsSk body_dmd skel  = RhsSk body_dmd skel
+
+-- | The type used in binder positions in 'GenStgExpr's.
+data BinderInfo
+  = BindsClosure !Id !Bool -- ^ Let(-no-escape)-bound thing with a flag
+                           --   indicating whether it occurs as an argument
+                           --   or in a nullary application
+                           --   (see "GHC.Stg.Lift.Analysis#arg_occs").
+  | BoringBinder !Id       -- ^ Every other kind of binder
+
+-- | Gets the bound 'Id' out a 'BinderInfo'.
+binderInfoBndr :: BinderInfo -> Id
+binderInfoBndr (BoringBinder bndr)   = bndr
+binderInfoBndr (BindsClosure bndr _) = bndr
+
+-- | Returns 'Nothing' for 'BoringBinder's and 'Just' the flag indicating
+-- occurrences as argument or in a nullary applications otherwise.
+binderInfoOccursAsArg :: BinderInfo -> Maybe Bool
+binderInfoOccursAsArg BoringBinder{}     = Nothing
+binderInfoOccursAsArg (BindsClosure _ b) = Just b
+
+instance Outputable Skeleton where
+  ppr NilSk = text ""
+  ppr (AltSk l r) = vcat
+    [ text "{ " <+> ppr l
+    , text "ALT"
+    , text "  " <+> ppr r
+    , text "}"
+    ]
+  ppr (BothSk l r) = ppr l $$ ppr r
+  ppr (ClosureSk f fvs body) = ppr f <+> ppr fvs $$ nest 2 (ppr body)
+  ppr (RhsSk card body) = hcat
+    [ lambda
+    , ppr card
+    , dot
+    , ppr body
+    ]
+
+instance Outputable BinderInfo where
+  ppr = ppr . binderInfoBndr
+
+instance OutputableBndr BinderInfo where
+  pprBndr b = pprBndr b . binderInfoBndr
+  pprPrefixOcc = pprPrefixOcc . binderInfoBndr
+  pprInfixOcc = pprInfixOcc . binderInfoBndr
+  bndrIsJoin_maybe = bndrIsJoin_maybe . binderInfoBndr
+
diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs
index 2a72f7a28e..9e20010cf7 100644
--- a/compiler/GHC/Stg/Pipeline.hs
+++ b/compiler/GHC/Stg/Pipeline.hs
@@ -41,8 +41,7 @@ import Control.Monad.IO.Class
 import Control.Monad.Trans.Reader
 import GHC.Settings (Platform)
 import GHC.Stg.InferTags (inferTags)
-import GHC.Types.Name.Env (NameEnv)
-import GHC.Stg.InferTags.TagSig (TagSig)
+import GHC.Stg.InferTags.TagSig ( StgCgInfos )
 
 data StgPipelineOpts = StgPipelineOpts
   { stgPipeline_phases      :: ![StgToDo]
@@ -56,10 +55,6 @@ data StgPipelineOpts = StgPipelineOpts
 newtype StgM a = StgM { _unStgM :: ReaderT Char IO a }
   deriving (Functor, Applicative, Monad, MonadIO)
 
--- | Information to be exposed in interface files which is produced
--- by the stg2stg passes.
-type StgCgInfos = NameEnv TagSig
-
 instance MonadUnique StgM where
   getUniqueSupplyM = StgM $ do { mask <- ask
                                ; liftIO $! mkSplitUniqSupply mask}
diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs
index 448b784f63..8b0ae6af54 100644
--- a/compiler/GHC/Stg/Syntax.hs
+++ b/compiler/GHC/Stg/Syntax.hs
@@ -68,27 +68,36 @@ module GHC.Stg.Syntax (
 
 import GHC.Prelude
 
-import GHC.Core     ( AltCon )
+import GHC.Stg.InferTags.TagSig( TagSig )
+import GHC.Stg.Lift.Types
+  -- To avoid having an orphan instances for BinderP, XLet etc
+
 import GHC.Types.CostCentre ( CostCentreStack )
-import Data.ByteString ( ByteString )
-import Data.Data   ( Data )
-import Data.List   ( intersperse )
+
+import GHC.Core     ( AltCon )
 import GHC.Core.DataCon
+import GHC.Core.TyCon    ( PrimRep(..), TyCon )
+import GHC.Core.Type     ( Type )
+import GHC.Core.Ppr( {- instances -} )
+
 import GHC.Types.ForeignCall ( ForeignCall )
 import GHC.Types.Id
 import GHC.Types.Name        ( isDynLinkName )
 import GHC.Types.Tickish     ( StgTickish )
 import GHC.Types.Var.Set
 import GHC.Types.Literal     ( Literal, literalType )
+import GHC.Types.RepType ( typePrimRep1, typePrimRep )
+
 import GHC.Unit.Module       ( Module )
 import GHC.Utils.Outputable
+import GHC.Utils.Panic.Plain
+
 import GHC.Platform
-import GHC.Core.Ppr( {- instances -} )
 import GHC.Builtin.PrimOps ( PrimOp, PrimCall )
-import GHC.Core.TyCon    ( PrimRep(..), TyCon )
-import GHC.Core.Type     ( Type )
-import GHC.Types.RepType ( typePrimRep1, typePrimRep )
-import GHC.Utils.Panic.Plain
+
+import Data.ByteString ( ByteString )
+import Data.Data   ( Data )
+import Data.List   ( intersperse )
 
 {-
 ************************************************************************
@@ -600,25 +609,34 @@ data StgPass
   | CodeGen
 
 type family BinderP (pass :: StgPass)
-type instance BinderP 'Vanilla = Id
-type instance BinderP 'CodeGen = Id
-type instance BinderP 'InferTagged = Id
+type instance BinderP 'Vanilla            = Id
+type instance BinderP 'CodeGen            = Id
+type instance BinderP 'InferTagged        = Id
+type instance BinderP 'InferTaggedBinders = (Id, TagSig)
+type instance BinderP 'LiftLams           = BinderInfo
 
 type family XRhsClosure (pass :: StgPass)
-type instance XRhsClosure 'Vanilla = NoExtFieldSilent
-type instance XRhsClosure 'InferTagged = NoExtFieldSilent
+type instance XRhsClosure 'Vanilla            = NoExtFieldSilent
+type instance XRhsClosure  'LiftLams          = DIdSet
+type instance XRhsClosure 'InferTagged        = NoExtFieldSilent
+type instance XRhsClosure 'InferTaggedBinders = XRhsClosure  'CodeGen
 -- | Code gen needs to track non-global free vars
 type instance XRhsClosure 'CodeGen = DIdSet
 
+
 type family XLet (pass :: StgPass)
-type instance XLet 'Vanilla = NoExtFieldSilent
-type instance XLet 'InferTagged = NoExtFieldSilent
-type instance XLet 'CodeGen = NoExtFieldSilent
+type instance XLet 'Vanilla            = NoExtFieldSilent
+type instance XLet 'LiftLams           = Skeleton
+type instance XLet 'InferTagged        = NoExtFieldSilent
+type instance XLet 'InferTaggedBinders = XLet 'CodeGen
+type instance XLet 'CodeGen            = NoExtFieldSilent
 
 type family XLetNoEscape (pass :: StgPass)
-type instance XLetNoEscape 'Vanilla = NoExtFieldSilent
-type instance XLetNoEscape 'InferTagged = NoExtFieldSilent
-type instance XLetNoEscape 'CodeGen = NoExtFieldSilent
+type instance XLetNoEscape 'Vanilla            = NoExtFieldSilent
+type instance XLetNoEscape 'LiftLams           = Skeleton
+type instance XLetNoEscape 'InferTagged        = NoExtFieldSilent
+type instance XLetNoEscape 'InferTaggedBinders = XLetNoEscape 'CodeGen
+type instance XLetNoEscape 'CodeGen            = NoExtFieldSilent
 
 {-
 
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index aea74cfb49..4373ee7b75 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -606,6 +606,7 @@ Library
         GHC.Stg.Lift.Analysis
         GHC.Stg.Lift.Config
         GHC.Stg.Lift.Monad
+        GHC.Stg.Lift.Types
         GHC.Stg.Lint
         GHC.Stg.InferTags
         GHC.Stg.InferTags.Rewrite
diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout
index 384243cd93..cdc15da1ca 100644
--- a/testsuite/tests/count-deps/CountDepsAst.stdout
+++ b/testsuite/tests/count-deps/CountDepsAst.stdout
@@ -179,6 +179,7 @@ GHC.Settings
 GHC.Settings.Config
 GHC.Settings.Constants
 GHC.Stg.InferTags.TagSig
+GHC.Stg.Lift.Types
 GHC.Stg.Syntax
 GHC.StgToCmm.Config
 GHC.StgToCmm.Types
diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout
index f00c74ce8d..8256bb8add 100644
--- a/testsuite/tests/count-deps/CountDepsParser.stdout
+++ b/testsuite/tests/count-deps/CountDepsParser.stdout
@@ -186,6 +186,7 @@ GHC.Settings
 GHC.Settings.Config
 GHC.Settings.Constants
 GHC.Stg.InferTags.TagSig
+GHC.Stg.Lift.Types
 GHC.Stg.Syntax
 GHC.StgToCmm.Config
 GHC.StgToCmm.Types