[Git][ghc/ghc][wip/T22717] 2 commits: Wibbles
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Mon Jan 23 17:57:52 UTC 2023
Simon Peyton Jones pushed to branch wip/T22717 at Glasgow Haskell Compiler / GHC
Commits:
f5e93e30 by Simon Peyton Jones at 2023-01-23T17:52:16+00:00
Wibbles
- Including adding GHC.Stg.Lift.Types, and moving instances to
GHC.Stg.Syntax, to avoid orphan instances
- - - - -
1dba1d6f by Simon Peyton Jones at 2023-01-23T17:58:03+00:00
Update test
- - - - -
15 changed files:
- compiler/GHC/Stg/Lift/Analysis.hs
- + compiler/GHC/Stg/Lift/Types.hs
- compiler/GHC/Stg/Syntax.hs
- compiler/ghc.cabal.in
- testsuite/tests/indexed-types/should_compile/Makefile
- testsuite/tests/indexed-types/should_compile/T22717.hs
- + testsuite/tests/indexed-types/should_compile/T22717.stderr
- testsuite/tests/indexed-types/should_compile/T22717b.hs
- testsuite/tests/indexed-types/should_compile/T22717c.hs
- + testsuite/tests/indexed-types/should_fail/T19773.hs
- + testsuite/tests/indexed-types/should_fail/T19773.stderr
- + testsuite/tests/indexed-types/should_fail/T19773a.hs
- + testsuite/tests/indexed-types/should_fail/T19773b.hs
- + testsuite/tests/indexed-types/should_fail/T19773c.hs
- testsuite/tests/indexed-types/should_fail/all.T
Changes:
=====================================
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
=====================================
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
+
=====================================
compiler/GHC/Stg/Syntax.hs
=====================================
@@ -69,7 +69,8 @@ module GHC.Stg.Syntax (
import GHC.Prelude
import GHC.Stg.InferTags.TagSig( TagSig )
- -- To avoid having an orphan instance for BinderP InferTaggedBinders
+import GHC.Stg.Lift.Types
+ -- To avoid having an orphan instances for BinderP, XLet etc
import GHC.Types.CostCentre ( CostCentreStack )
@@ -612,9 +613,11 @@ 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 'LiftLams = DIdSet
type instance XRhsClosure 'InferTagged = NoExtFieldSilent
type instance XRhsClosure 'InferTaggedBinders = XRhsClosure 'CodeGen
-- | Code gen needs to track non-global free vars
@@ -623,12 +626,14 @@ type instance XRhsClosure 'CodeGen = DIdSet
type family XLet (pass :: StgPass)
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 'LiftLams = Skeleton
type instance XLetNoEscape 'InferTagged = NoExtFieldSilent
type instance XLetNoEscape 'InferTaggedBinders = XLetNoEscape 'CodeGen
type instance XLetNoEscape 'CodeGen = NoExtFieldSilent
=====================================
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
=====================================
testsuite/tests/indexed-types/should_compile/Makefile
=====================================
@@ -45,7 +45,7 @@ T8500:
# T22717 must be done in one-shot mode, one file at a time
T22717:
$(RM) T22717*.o T22717*.hi
- '$(TEST_HC)' $(TEST_HC_OPTS) -c T22717d.hs
- '$(TEST_HC)' $(TEST_HC_OPTS) -c T22717c.hs
- '$(TEST_HC)' $(TEST_HC_OPTS) -c T22717b.hs
- '$(TEST_HC)' $(TEST_HC_OPTS) -c T22717.hs
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c T22717d.hs -Wall
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c T22717c.hs -Wall
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c T22717b.hs -Wall
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c T22717.hs -Wall
=====================================
testsuite/tests/indexed-types/should_compile/T22717.hs
=====================================
@@ -3,5 +3,6 @@ module T22717 where
import T22717b
+f :: Int
f = p (3::Int)
=====================================
testsuite/tests/indexed-types/should_compile/T22717.stderr
=====================================
@@ -0,0 +1,7 @@
+
+T22717c.hs:9:1: warning: [GHC-61125] [-Worphans (in -Wall)]
+ Orphan family instance:
+ type instance F T = Private -- Defined at T22717c.hs:9:15
+ Suggested fix:
+ Move the instance declaration to the module of the type family or of the type, or
+ wrap the type with a newtype and declare the instance on the new type.
=====================================
testsuite/tests/indexed-types/should_compile/T22717b.hs
=====================================
@@ -1,7 +1,7 @@
{-# LANGUAGE TypeFamilies #-}
module T22717b where
-import T22717c
+import T22717c ()
import T22717d
p :: F (F T) -> Int
=====================================
testsuite/tests/indexed-types/should_compile/T22717c.hs
=====================================
@@ -1,9 +1,12 @@
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE EmptyDataDecls, TypeFamilies #-}
module T22717c() where
import T22717d
-data Private = Private
+data Private
+-- This is an orphan instance
type instance F T = Private
+
+-- But this is not
type instance F Private = Int
=====================================
testsuite/tests/indexed-types/should_fail/T19773.hs
=====================================
@@ -0,0 +1,5 @@
+module T19973 where
+
+import T19773a
+import T19773b
+import T19773c
=====================================
testsuite/tests/indexed-types/should_fail/T19773.stderr
=====================================
@@ -0,0 +1,23 @@
+[1 of 4] Compiling T19773a ( T19773a.hs, T19773a.o )
+[2 of 4] Compiling T19773b ( T19773b.hs, T19773b.o )
+
+T19773b.hs:6:1: warning: [GHC-61125] [-Worphans (in -Wall)]
+ Orphan family instance:
+ data instance DF [a] -- Defined at T19773b.hs:6:15
+ Suggested fix:
+ Move the instance declaration to the module of the type family or of the type, or
+ wrap the type with a newtype and declare the instance on the new type.
+[3 of 4] Compiling T19773c ( T19773c.hs, T19773c.o )
+
+T19773c.hs:6:1: warning: [GHC-61125] [-Worphans (in -Wall)]
+ Orphan family instance:
+ data instance DF [a] -- Defined at T19773c.hs:6:15
+ Suggested fix:
+ Move the instance declaration to the module of the type family or of the type, or
+ wrap the type with a newtype and declare the instance on the new type.
+[4 of 4] Compiling T19973 ( T19773.hs, T19773.o )
+
+T19773.hs:1:1: error: [GHC-34447]
+ Conflicting family instance declarations:
+ DF [a] -- Defined in module T19773b
+ DF [a] -- Defined in module T19773c
=====================================
testsuite/tests/indexed-types/should_fail/T19773a.hs
=====================================
@@ -0,0 +1,4 @@
+{-# LANGUAGE TypeFamilies #-}
+module T19773a where
+
+data family DF a
=====================================
testsuite/tests/indexed-types/should_fail/T19773b.hs
=====================================
@@ -0,0 +1,6 @@
+{-# LANGUAGE TypeFamilies #-}
+module T19773b where
+import T19773a
+
+-- Should warn for orphan instance
+data instance DF [a] = DF_B a
=====================================
testsuite/tests/indexed-types/should_fail/T19773c.hs
=====================================
@@ -0,0 +1,6 @@
+{-# LANGUAGE TypeFamilies #-}
+module T19773c where
+import T19773a
+
+-- Should warn for orphan instance
+data instance DF [a] = DF_C a
=====================================
testsuite/tests/indexed-types/should_fail/all.T
=====================================
@@ -171,3 +171,4 @@ test('T20521', normal, compile_fail, [''])
test('T21896', normal, compile_fail, [''])
test('HsBootFam', [extra_files(['HsBootFam_aux.hs','HsBootFam_aux.hs-boot'])], multimod_compile_fail, ['HsBootFam', ''])
test('BadFamInstDecl', [extra_files(['BadFamInstDecl_aux.hs'])], multimod_compile_fail, ['BadFamInstDecl', ''])
+test('T19773', [], multimod_compile_fail, ['T19773', '-Wall'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/27c53cfd8fea807e4542e326dc9614cdb6c27369...1dba1d6fd2acc1254e1b76512503829a353ce35f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/27c53cfd8fea807e4542e326dc9614cdb6c27369...1dba1d6fd2acc1254e1b76512503829a353ce35f
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/20230123/bba2abf5/attachment-0001.html>
More information about the ghc-commits
mailing list