diff options
Diffstat (limited to 'compiler/GHC/Stg/Syntax.hs')
| -rw-r--r-- | compiler/GHC/Stg/Syntax.hs | 98 |
1 files changed, 75 insertions, 23 deletions
diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs index b38c2f1ab0..37f834d2bb 100644 --- a/compiler/GHC/Stg/Syntax.hs +++ b/compiler/GHC/Stg/Syntax.hs @@ -3,7 +3,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -25,9 +27,11 @@ module GHC.Stg.Syntax ( GenStgTopBinding(..), GenStgBinding(..), GenStgExpr(..), GenStgRhs(..), GenStgAlt, AltType(..), - StgPass(..), BinderP, XRhsClosure, XLet, XLetNoEscape, + StgPass(..), BinderP, XRhsClosure, XLet, XLetNoEscape, XXStgExpr, + StgPassWitness(..), IsStgPass, NoExtFieldSilent, noExtFieldSilent, OutputablePass, + StgLam(..), UpdateFlag(..), isUpdatable, @@ -40,6 +44,9 @@ module GHC.Stg.Syntax ( -- a set of synonyms for the lambda lifting parameterisation LlStgTopBinding, LlStgBinding, LlStgExpr, LlStgRhs, LlStgAlt, + -- a set of synonyms for the core to stg parameterisation + SgStgTopBinding, SgStgBinding, SgStgExpr, SgStgRhs, SgStgAlt, + -- a set of synonyms to distinguish in- and out variants InStgArg, InStgTopBinding, InStgBinding, InStgExpr, InStgRhs, InStgAlt, OutStgArg, OutStgTopBinding, OutStgBinding, OutStgExpr, OutStgRhs, OutStgAlt, @@ -73,6 +80,10 @@ import Data.Data ( Data ) import Data.List ( intersperse ) import GHC.Core.DataCon import GHC.Driver.Session +import GHC.Hs.Extension ( NoExtCon ) +#if __GLASGOW_HASKELL__ < 811 +import GHC.Hs.Extension ( noExtCon ) +#endif import GHC.Types.ForeignCall ( ForeignCall ) import GHC.Types.Id import GHC.Types.Name ( isDynLinkName ) @@ -256,22 +267,6 @@ literals. {- ************************************************************************ * * -StgLam -* * -************************************************************************ - -StgLam is used *only* during CoreToStg's work. Before CoreToStg has finished it -encodes (\x -> e) as (let f = \x -> e in f) TODO: Encode this via an extension -to GenStgExpr à la TTG. --} - - | StgLam - (NonEmpty (BinderP pass)) - StgExpr -- Body of lambda - -{- -************************************************************************ -* * GenStgExpr: case-expressions * * ************************************************************************ @@ -386,6 +381,8 @@ Finally for @hpc@ expressions we introduce a new STG construct. (Tickish Id) (GenStgExpr pass) -- sub expression + | XStgExpr !(XXStgExpr pass) + -- END of GenStgExpr {- @@ -441,6 +438,28 @@ data StgPass = Vanilla | LiftLams | CodeGen + | StgGen + +data StgPassWitness (pass :: StgPass) where + VanillaWitness :: StgPassWitness 'Vanilla + LiftLamsWitness :: StgPassWitness 'LiftLams + CodeGenWitness :: StgPassWitness 'CodeGen + StgGenWitness :: StgPassWitness 'StgGen + +class IsStgPass (pass :: StgPass) where + stgPass :: StgPassWitness pass + +instance IsStgPass 'Vanilla where + stgPass = VanillaWitness + +instance IsStgPass 'LiftLams where + stgPass = LiftLamsWitness + +instance IsStgPass 'CodeGen where + stgPass = CodeGenWitness + +instance IsStgPass 'StgGen where + stgPass = StgGenWitness -- | Like 'GHC.Hs.Extension.NoExtField', but with an 'Outputable' instance that -- returns 'empty'. @@ -462,19 +481,37 @@ noExtFieldSilent = NoExtFieldSilent type family BinderP (pass :: StgPass) type instance BinderP 'Vanilla = Id type instance BinderP 'CodeGen = Id +type instance BinderP 'StgGen = Id type family XRhsClosure (pass :: StgPass) type instance XRhsClosure 'Vanilla = NoExtFieldSilent -- | Code gen needs to track non-global free vars type instance XRhsClosure 'CodeGen = DIdSet +type instance XRhsClosure 'StgGen = NoExtFieldSilent type family XLet (pass :: StgPass) type instance XLet 'Vanilla = NoExtFieldSilent type instance XLet 'CodeGen = NoExtFieldSilent +type instance XLet 'StgGen = NoExtFieldSilent type family XLetNoEscape (pass :: StgPass) type instance XLetNoEscape 'Vanilla = NoExtFieldSilent type instance XLetNoEscape 'CodeGen = NoExtFieldSilent +type instance XLetNoEscape 'StgGen = NoExtFieldSilent + +type family XXStgExpr (pass :: StgPass) +type instance XXStgExpr 'Vanilla = NoExtCon +type instance XXStgExpr 'CodeGen = NoExtCon +type instance XXStgExpr 'LiftLams = NoExtCon +type instance XXStgExpr 'StgGen = StgLam + +-- StgLam is used *only* during CoreToStg's work. Before CoreToStg has finished +-- it encodes (\x -> e) as (let f = \x -> e in f). We define this here rather +-- than in CoreToStg because we need it for pretty-printing StgExpr and +-- importing CoreToStg would create an import cycle. +data StgLam = StgLam + (NonEmpty Id) + SgStgExpr stgRhsArity :: StgRhs -> Int stgRhsArity (StgRhsClosure _ _ _ bndrs _) @@ -541,6 +578,12 @@ type CgStgExpr = GenStgExpr 'CodeGen type CgStgRhs = GenStgRhs 'CodeGen type CgStgAlt = GenStgAlt 'CodeGen +type SgStgTopBinding = GenStgTopBinding 'StgGen +type SgStgBinding = GenStgBinding 'StgGen +type SgStgExpr = GenStgExpr 'StgGen +type SgStgRhs = GenStgRhs 'StgGen +type SgStgAlt = GenStgAlt 'StgGen + {- Many passes apply a substitution, and it's very handy to have type synonyms to remind us whether or not the substitution has been applied. See GHC.Core for precedence in Core land @@ -645,6 +688,7 @@ type OutputablePass pass = , Outputable (XLetNoEscape pass) , Outputable (XRhsClosure pass) , OutputableBndr (BinderP pass) + , IsStgPass pass ) -- | STG pretty-printing options @@ -701,7 +745,7 @@ pprStgArg :: StgArg -> SDoc pprStgArg (StgVarArg var) = ppr var pprStgArg (StgLitArg con) = ppr con -pprStgExpr :: OutputablePass pass => StgPprOpts -> GenStgExpr pass -> SDoc +pprStgExpr :: forall pass. OutputablePass pass => StgPprOpts -> GenStgExpr pass -> SDoc pprStgExpr opts e = case e of -- special case StgLit lit -> ppr lit @@ -709,11 +753,6 @@ pprStgExpr opts e = case e of StgApp func args -> hang (ppr func) 4 (interppSP args) StgConApp con args _ -> hsep [ ppr con, brackets (interppSP args) ] StgOpApp op args _ -> hsep [ pprStgOp op, brackets (interppSP args)] - StgLam bndrs body -> let ppr_list = brackets . fsep . punctuate comma - in sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) (toList bndrs)) - <+> text "->" - , pprStgExpr opts body - ] -- special case: let v = <very specific thing> -- in @@ -786,6 +825,19 @@ pprStgExpr opts e = case e of , char '}' ] + XStgExpr xStgExpr -> case stgPass @pass of +#if __GLASGOW_HASKELL__ < 811 + VanillaWitness -> noExtCon xStgExpr + LiftLamsWitness -> noExtCon xStgExpr + CodeGenWitness -> noExtCon xStgExpr +#endif + StgGenWitness -> case xStgExpr of + StgLam bndrs body -> let ppr_list = brackets . fsep . punctuate comma + in sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) (toList bndrs)) + <+> text "->" + , pprStgExpr opts body + ] + pprStgAlt :: OutputablePass pass => StgPprOpts -> Bool -> GenStgAlt pass -> SDoc pprStgAlt opts indent (con, params, expr) |