X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsBinds.lhs;h=458a713daddf017087e03307fb2c49101a3f1b11;hb=1796a476986f14cca2f7628d2f7cf6d530853495;hp=a725c1d6fdbc7906dceda852a878165916efdcfc;hpb=2f51f1402e6869c0f049ffbe7b019bf6ab80558f;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index a725c1d..458a713 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -1,71 +1,115 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[HsBinds]{Abstract syntax: top-level bindings and signatures} -Datatype for: @HsBinds@, @Bind@, @Sig@, @MonoBinds@. +Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. \begin{code} -#include "HsVersions.h" - module HsBinds where -import Ubiq +#include "HsVersions.h" + +import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, LHsExpr, + LMatch, pprFunBind, + GRHSs, pprPatBind ) -- friends: -import HsLoop -import HsMatches ( pprMatches, pprGRHSsAndBinds, - Match, GRHSsAndBinds ) -import HsPat ( collectPatBinders, InPat ) -import HsPragmas ( GenPragmas, ClassOpPragmas ) -import HsTypes ( PolyType ) +import HsPat ( LPat ) +import HsTypes ( LHsType ) --others: -import Id ( DictVar(..), Id(..), GenId ) -import Name ( pprNonSym ) -import Outputable ( interpp'SP, ifnotPprForUser, - Outputable(..){-instance * (,)-} - ) -import Pretty -import SrcLoc ( SrcLoc{-instances-} ) ---import TyVar ( GenTyVar{-instances-} ) +import Name ( Name ) +import NameSet ( NameSet, elemNameSet, nameSetToList ) +import BasicTypes ( IPName, RecFlag(..), Activation(..), Fixity ) +import Outputable +import SrcLoc ( Located(..), unLoc ) +import Var ( TyVar ) +import Bag ( Bag, bagToList ) \end{code} %************************************************************************ %* * -\subsection{Bindings: @HsBinds@} +\subsection{Bindings: @BindGroup@} %* * %************************************************************************ -The following syntax may produce new syntax which is not part of the input, -and which is instead a translation of the input to the typechecker. -Syntax translations are marked TRANSLATION in comments. New empty -productions are useful in development but may not appear in the final -grammar. - -Collections of bindings, created by dependency analysis and translation: +Global bindings (where clauses) \begin{code} -data HsBinds tyvar uvar id pat -- binders and bindees - = EmptyBinds - - | ThenBinds (HsBinds tyvar uvar id pat) - (HsBinds tyvar uvar id pat) - - | SingleBind (Bind tyvar uvar id pat) - - | BindWith -- Bind with a type signature. - -- These appear only on typechecker input - -- (PolyType [in Sigs] can't appear on output) - (Bind tyvar uvar id pat) - [Sig id] - - | AbsBinds -- Binds abstraction; TRANSLATION - [tyvar] - [id] -- Dicts - [(id, id)] -- (old, new) pairs - [(id, HsExpr tyvar uvar id pat)] -- local dictionaries - (Bind tyvar uvar id pat) -- "the business end" +data HsBindGroup id + = HsBindGroup -- A mutually recursive group + (LHsBinds id) + [LSig id] -- Empty on typechecker output, Type Signatures + RecFlag + + | HsIPBinds + [LIPBind id] -- Not allowed at top level + +instance OutputableBndr id => Outputable (HsBindGroup id) where + ppr (HsBindGroup binds sigs is_rec) + = vcat [ppr_isrec, + vcat (map ppr sigs), + pprLHsBinds binds + ] + where + ppr_isrec = getPprStyle $ \ sty -> + if userStyle sty then empty else + case is_rec of + Recursive -> ptext SLIT("{- rec -}") + NonRecursive -> ptext SLIT("{- nonrec -}") + + ppr (HsIPBinds ipbinds) + = vcat (map ppr ipbinds) + +-- ----------------------------------------------------------------------------- +-- Implicit parameter bindings + +type LIPBind id = Located (IPBind id) + +-- | Implicit parameter bindings. +data IPBind id + = IPBind + (IPName id) + (LHsExpr id) + +instance (OutputableBndr id) => Outputable (IPBind id) where + ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs) + +-- ----------------------------------------------------------------------------- + +type LHsBinds id = Bag (LHsBind id) +type LHsBind id = Located (HsBind id) + +pprLHsBinds :: OutputableBndr id => LHsBinds id -> SDoc +pprLHsBinds binds = lbrace <+> vcat (map ppr (bagToList binds)) <+> rbrace + +data HsBind id + = FunBind (Located id) + -- Used for both functions f x = e + -- and variables f = \x -> e + -- Reason: the Match stuff lets us have an optional + -- result type sig f :: a->a = ...mentions a... + -- + -- This also means that instance decls can only have + -- FunBinds, so if you change this, you'll need to + -- change e.g. rnMethodBinds + Bool -- True => infix declaration + [LMatch id] + + | PatBind (LPat id) -- The pattern is never a simple variable; + -- That case is done by FunBind + (GRHSs id) + + | VarBind id (Located (HsExpr id)) -- Dictionary binding and suchlike; + -- located only for consistency + + | AbsBinds -- Binds abstraction; TRANSLATION + [TyVar] -- Type variables + [id] -- Dicts + [([TyVar], id, id)] -- (type variables, polymorphic, momonmorphic) triples + NameSet -- Set of *polymorphic* variables that have an INLINE pragma + (LHsBinds id) -- The "business end" -- Creates bindings for *new* (polymorphic, overloaded) locals -- in terms of *old* (monomorphic, non-overloaded) ones. @@ -75,36 +119,52 @@ data HsBinds tyvar uvar id pat -- binders and bindees -- of this last construct.) \end{code} -\begin{code} -nullBinds :: HsBinds tyvar uvar id pat -> Bool +What AbsBinds means +~~~~~~~~~~~~~~~~~~~ + AbsBinds tvs + [d1,d2] + [(tvs1, f1p, f1m), + (tvs2, f2p, f2m)] + BIND +means -nullBinds EmptyBinds = True -nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2 -nullBinds (SingleBind b) = nullBind b -nullBinds (BindWith b _) = nullBind b -nullBinds (AbsBinds _ _ _ ds b) = null ds && nullBind b -\end{code} + f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND + in fm + + gp = ...same again, with gm instead of fm + +This is a pretty bad translation, because it duplicates all the bindings. +So the desugarer tries to do a better job: + + fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of + (fm,gm) -> fm + ..ditto for gp.. + + tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND + in (fm,gm) \begin{code} -instance (Outputable pat, NamedThing id, Outputable id, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - Outputable (HsBinds tyvar uvar id pat) where - - ppr sty EmptyBinds = ppNil - ppr sty (ThenBinds binds1 binds2) - = ppAbove (ppr sty binds1) (ppr sty binds2) - ppr sty (SingleBind bind) = ppr sty bind - ppr sty (BindWith bind sigs) - = ppAbove (if null sigs - then ppNil - else ppAboves (map (ppr sty) sigs)) - (ppr sty bind) - ppr sty (AbsBinds tyvars dictvars local_pairs dict_binds val_binds) - = ppAbove (ppSep [ppPStr SLIT("AbsBinds"), - ppBesides[ppLbrack, interpp'SP sty tyvars, ppRbrack], - ppBesides[ppLbrack, interpp'SP sty dictvars, ppRbrack], - ppBesides[ppLbrack, interpp'SP sty local_pairs, ppRbrack]]) - (ppNest 4 (ppAbove (ppAboves (map (ppr sty) dict_binds)) (ppr sty val_binds))) +instance OutputableBndr id => Outputable (HsBind id) where + ppr mbind = ppr_monobind mbind + +ppr_monobind :: OutputableBndr id => HsBind id -> SDoc + +ppr_monobind (PatBind pat grhss) = pprPatBind pat grhss +ppr_monobind (VarBind var rhs) = ppr var <+> equals <+> pprExpr (unLoc rhs) +ppr_monobind (FunBind fun inf matches) = pprFunBind (unLoc fun) matches + -- ToDo: print infix if appropriate + +ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds) + = sep [ptext SLIT("AbsBinds"), + brackets (interpp'SP tyvars), + brackets (interpp'SP dictvars), + brackets (sep (punctuate comma (map ppr exports))), + brackets (interpp'SP (nameSetToList inlines))] + $$ + nest 4 ( vcat [pprBndr LetBind x | (_,x,_) <- exports] + -- Print type signatures + $$ + pprLHsBinds val_binds ) \end{code} %************************************************************************ @@ -119,215 +179,115 @@ signatures. Then all the machinery to move them into place, etc., serves for both. \begin{code} -data Sig name - = Sig name -- a bog-std type signature - (PolyType name) - (GenPragmas name) -- only interface ones have pragmas - SrcLoc - - | ClassOpSig name -- class-op sigs have different pragmas - (PolyType name) - (ClassOpPragmas name) -- only interface ones have pragmas - SrcLoc - - | SpecSig name -- specialise a function or datatype ... - (PolyType name) -- ... to these types - (Maybe name) -- ... maybe using this as the code for it - SrcLoc - - | InlineSig name -- INLINE f - SrcLoc - - -- ToDo: strictly speaking, could omit based on -DOMIT_DEFORESTER - | DeforestSig name -- Deforest using this function definition - SrcLoc - - | MagicUnfoldingSig - name -- Associate the "name"d function with - FAST_STRING -- the compiler-builtin unfolding (known - SrcLoc -- by the String name) -\end{code} - -\begin{code} -instance (NamedThing name, Outputable name) => Outputable (Sig name) where - ppr sty (Sig var ty pragmas _) - = ppHang (ppCat [pprNonSym sty var, ppPStr SLIT("::")]) - 4 (ppHang (ppr sty ty) - 4 (ifnotPprForUser sty (ppr sty pragmas))) - - ppr sty (ClassOpSig var ty pragmas _) - = ppHang (ppCat [pprNonSym sty var, ppPStr SLIT("::")]) - 4 (ppHang (ppr sty ty) - 4 (ifnotPprForUser sty (ppr sty pragmas))) - - ppr sty (DeforestSig var _) - = ppHang (ppCat [ppStr "{-# DEFOREST", pprNonSym sty var]) - 4 (ppStr "#-}") - - ppr sty (SpecSig var ty using _) - = ppHang (ppCat [ppPStr SLIT("{-# SPECIALIZE"), pprNonSym sty var, ppPStr SLIT("::")]) - 4 (ppCat [ppr sty ty, pp_using using, ppPStr SLIT("#-}")]) - where - pp_using Nothing = ppNil - pp_using (Just me) = ppCat [ppChar '=', ppr sty me] - - ppr sty (InlineSig var _) - = ppCat [ppPStr SLIT("{-# INLINE"), pprNonSym sty var, ppPStr SLIT("#-}")] - - ppr sty (MagicUnfoldingSig var str _) - = ppCat [ppPStr SLIT("{-# MAGIC_UNFOLDING"), pprNonSym sty var, ppPStr str, ppPStr SLIT("#-}")] -\end{code} +type LSig name = Located (Sig name) -%************************************************************************ -%* * -\subsection{Binding: @Bind@} -%* * -%************************************************************************ +data Sig name + = Sig (Located name) -- a bog-std type signature + (LHsType name) -\begin{code} -data Bind tyvar uvar id pat -- binders and bindees - = EmptyBind -- because it's convenient when parsing signatures - | NonRecBind (MonoBinds tyvar uvar id pat) - | RecBind (MonoBinds tyvar uvar id pat) -\end{code} + | SpecSig (Located name) -- specialise a function or datatype ... + (LHsType name) -- ... to these types -\begin{code} -nullBind :: Bind tyvar uvar id pat -> Bool + | InlineSig Bool -- True <=> INLINE f, False <=> NOINLINE f + (Located name) -- Function name + Activation -- When inlining is *active* -nullBind EmptyBind = True -nullBind (NonRecBind bs) = nullMonoBinds bs -nullBind (RecBind bs) = nullMonoBinds bs -\end{code} + | SpecInstSig (LHsType name) -- (Class tys); should be a specialisation of the + -- current instance decl -\begin{code} -bindIsRecursive :: Bind tyvar uvar id pat -> Bool + | FixSig (FixitySig name) -- Fixity declaration -bindIsRecursive EmptyBind = False -bindIsRecursive (NonRecBind _) = False -bindIsRecursive (RecBind _) = True +type LFixitySig name = Located (FixitySig name) +data FixitySig name = FixitySig (Located name) Fixity \end{code} \begin{code} -instance (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - Outputable (Bind tyvar uvar id pat) where - ppr sty EmptyBind = ppNil - ppr sty (NonRecBind binds) - = ppAbove (ifnotPprForUser sty (ppStr "{- nonrec -}")) - (ppr sty binds) - ppr sty (RecBind binds) - = ppAbove (ifnotPprForUser sty (ppStr "{- rec -}")) - (ppr sty binds) +okBindSig :: NameSet -> LSig Name -> Bool +okBindSig ns sig = sigForThisGroup ns sig + +okClsDclSig :: LSig Name -> Bool +okClsDclSig (L _ (SpecInstSig _)) = False +okClsDclSig sig = True -- All others OK + +okInstDclSig :: NameSet -> LSig Name -> Bool +okInstDclSig ns lsig@(L _ sig) = ok ns sig + where + ok ns (Sig _ _) = False + ok ns (FixSig _) = False + ok ns (SpecInstSig _) = True + ok ns sig = sigForThisGroup ns lsig + +sigForThisGroup :: NameSet -> LSig Name -> Bool +sigForThisGroup ns sig + = case sigName sig of + Nothing -> False + Just n -> n `elemNameSet` ns + +sigName :: LSig name -> Maybe name +sigName (L _ sig) = f sig + where + f (Sig n _) = Just (unLoc n) + f (SpecSig n _) = Just (unLoc n) + f (InlineSig _ n _) = Just (unLoc n) + f (FixSig (FixitySig n _)) = Just (unLoc n) + f other = Nothing + +isFixitySig :: Sig name -> Bool +isFixitySig (FixSig _) = True +isFixitySig _ = False + +isPragSig :: Sig name -> Bool + -- Identifies pragmas +isPragSig (SpecSig _ _) = True +isPragSig (InlineSig _ _ _) = True +isPragSig (SpecInstSig _) = True +isPragSig other = False + +hsSigDoc (Sig _ _) = ptext SLIT("type signature") +hsSigDoc (SpecSig _ _) = ptext SLIT("SPECIALISE pragma") +hsSigDoc (InlineSig True _ _) = ptext SLIT("INLINE pragma") +hsSigDoc (InlineSig False _ _) = ptext SLIT("NOINLINE pragma") +hsSigDoc (SpecInstSig _) = ptext SLIT("SPECIALISE instance pragma") +hsSigDoc (FixSig (FixitySig _ _)) = ptext SLIT("fixity declaration") \end{code} -%************************************************************************ -%* * -\subsection{Bindings: @MonoBinds@} -%* * -%************************************************************************ - -Global bindings (where clauses) +Signature equality is used when checking for duplicate signatures \begin{code} -data MonoBinds tyvar uvar id pat - = EmptyMonoBinds - | AndMonoBinds (MonoBinds tyvar uvar id pat) - (MonoBinds tyvar uvar id pat) - | PatMonoBind pat - (GRHSsAndBinds tyvar uvar id pat) - SrcLoc - | FunMonoBind id - Bool -- True => infix declaration - [Match tyvar uvar id pat] -- must have at least one Match - SrcLoc - | VarMonoBind id -- TRANSLATION - (HsExpr tyvar uvar id pat) +eqHsSig :: Sig Name -> Sig Name -> Bool +eqHsSig (FixSig (FixitySig n1 _)) (FixSig (FixitySig n2 _)) = unLoc n1 == unLoc n2 +eqHsSig (Sig n1 _) (Sig n2 _) = unLoc n1 == unLoc n2 +eqHsSig (InlineSig b1 n1 _) (InlineSig b2 n2 _) = b1 == b2 && unLoc n1 == unLoc n2 + -- For specialisations, we don't have equality over + -- HsType, so it's not convenient to spot duplicate + -- specialisations here. Check for this later, when we're in Type land +eqHsSig _other1 _other2 = False \end{code} \begin{code} -nullMonoBinds :: MonoBinds tyvar uvar id pat -> Bool +instance (OutputableBndr name) => Outputable (Sig name) where + ppr sig = ppr_sig sig -nullMonoBinds EmptyMonoBinds = True -nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2 -nullMonoBinds other_monobind = False -\end{code} +ppr_sig :: OutputableBndr name => Sig name -> SDoc +ppr_sig (Sig var ty) + = sep [ppr var <+> dcolon, nest 4 (ppr ty)] -\begin{code} -instance (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - Outputable (MonoBinds tyvar uvar id pat) where - ppr sty EmptyMonoBinds = ppNil - ppr sty (AndMonoBinds binds1 binds2) - = ppAbove (ppr sty binds1) (ppr sty binds2) - - ppr sty (PatMonoBind pat grhss_n_binds locn) - = ppHang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds) - - ppr sty (FunMonoBind fun inf matches locn) - = pprMatches sty (False, pprNonSym sty fun) matches - -- ToDo: print infix if appropriate +ppr_sig (SpecSig var ty) + = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon], + nest 4 (ppr ty <+> text "#-}") + ] - ppr sty (VarMonoBind name expr) - = ppHang (ppCat [pprNonSym sty name, ppEquals]) 4 (ppr sty expr) -\end{code} +ppr_sig (InlineSig True var phase) + = hsep [text "{-# INLINE", ppr phase, ppr var, text "#-}"] -%************************************************************************ -%* * -\subsection{Collecting binders from @HsBinds@} -%* * -%************************************************************************ +ppr_sig (InlineSig False var phase) + = hsep [text "{-# NOINLINE", ppr phase, ppr var, text "#-}"] -Get all the binders in some @MonoBinds@, IN THE ORDER OF -APPEARANCE; e.g., in: -\begin{verbatim} -... -where - (x, y) = ... - f i j = ... - [a, b] = ... -\end{verbatim} -it should return @[x, y, f, a, b]@ (remember, order important). +ppr_sig (SpecInstSig ty) + = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"] -\begin{code} -collectTopLevelBinders :: HsBinds tyvar uvar name (InPat name) -> [name] -collectTopLevelBinders EmptyBinds = [] -collectTopLevelBinders (SingleBind b) = collectBinders b -collectTopLevelBinders (BindWith b _) = collectBinders b -collectTopLevelBinders (ThenBinds b1 b2) - = collectTopLevelBinders b1 ++ collectTopLevelBinders b2 - -collectBinders :: Bind tyvar uvar name (InPat name) -> [name] -collectBinders EmptyBind = [] -collectBinders (NonRecBind monobinds) = collectMonoBinders monobinds -collectBinders (RecBind monobinds) = collectMonoBinders monobinds - -collectMonoBinders :: MonoBinds tyvar uvar name (InPat name) -> [name] -collectMonoBinders EmptyMonoBinds = [] -collectMonoBinders (PatMonoBind pat grhss_w_binds _) = collectPatBinders pat -collectMonoBinders (FunMonoBind f _ matches _) = [f] -collectMonoBinders (VarMonoBind v expr) = error "collectMonoBinders" -collectMonoBinders (AndMonoBinds bs1 bs2) - = collectMonoBinders bs1 ++ collectMonoBinders bs2 - --- We'd like the binders -- and where they came from -- --- so we can make new ones with equally-useful origin info. - -collectMonoBindersAndLocs - :: MonoBinds tyvar uvar name (InPat name) -> [(name, SrcLoc)] - -collectMonoBindersAndLocs EmptyMonoBinds = [] - -collectMonoBindersAndLocs (AndMonoBinds bs1 bs2) - = collectMonoBindersAndLocs bs1 ++ collectMonoBindersAndLocs bs2 - -collectMonoBindersAndLocs (PatMonoBind pat grhss_w_binds locn) - = collectPatBinders pat `zip` repeat locn - -collectMonoBindersAndLocs (FunMonoBind f _ matches locn) = [(f, locn)] - -#ifdef DEBUG -collectMonoBindersAndLocs (VarMonoBind v expr) - = trace "collectMonoBindersAndLocs:VarMonoBind" [] - -- ToDo: this is dubious, i.e., wrong, but harmless? -#endif +ppr_sig (FixSig fix_sig) = ppr fix_sig + +instance Outputable name => Outputable (FixitySig name) where + ppr (FixitySig name fixity) = sep [ppr fixity, ppr name] \end{code}