X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsBinds.lhs;h=f28cff83aeba0997c3a410fdd27fc71024980930;hb=9c26739695219d8343505a88457cb55c76b65449;hp=2c2a687d700314182ae0bf9188df52cad5d5b291;hpb=7a3bd641457666e10d0a47be9f22762e03defbf0;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index 2c2a687..f28cff8 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -13,27 +13,35 @@ module HsBinds where IMP_Ubiq() -- friends: -IMPORT_DELOOPER(HsLoop) -import HsMatches ( pprMatches, pprGRHSsAndBinds, - Match, GRHSsAndBinds ) -import HsPat ( collectPatBinders, InPat ) +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 +IMPORT_DELOOPER(HsLoop) ( pprMatches, pprGRHSsAndBinds, + Match, GRHSsAndBinds, + pprExpr, HsExpr ) +#endif + import HsPragmas ( GenPragmas, ClassOpPragmas ) import HsTypes ( HsType ) import CoreSyn ( SYN_IE(CoreExpr) ) --others: import Id ( SYN_IE(DictVar), SYN_IE(Id), GenId ) -import Name ( pprNonSym, getOccName, OccName ) -import Outputable ( interpp'SP, ifnotPprForUser, +import Name ( OccName, NamedThing(..) ) +import Outputable ( interpp'SP, ifnotPprForUser, pprQuote, Outputable(..){-instance * (,)-} ) -import PprCore ( GenCoreExpr {- instance Outputable -} ) +import PprCore --( GenCoreExpr {- instance Outputable -} ) import PprType ( GenTyVar {- instance Outputable -} ) import Pretty import Bag import SrcLoc ( SrcLoc{-instances-} ) import TyVar ( GenTyVar{-instances-} ) import Unique ( Unique {- instance Eq -} ) + +#if __GLASGOW_HASKELL__ >= 202 +import {-# SOURCE #-} HsExpr ( pprExpr, HsExpr ) +import {-# SOURCE #-} HsMatches ( pprMatches, Match, pprGRHSsAndBinds, GRHSsAndBinds ) +#endif + \end{code} %************************************************************************ @@ -57,27 +65,13 @@ data HsBinds tyvar uvar id pat -- binders and bindees | ThenBinds (HsBinds tyvar uvar id pat) (HsBinds tyvar uvar id pat) - | SingleBind (Bind tyvar uvar id pat) + | MonoBind (MonoBinds tyvar uvar id pat) + [Sig id] -- Empty on typechecker output + RecFlag - | BindWith -- Bind with a type signature. - -- These appear only on typechecker input - -- (HsType [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" - - -- Creates bindings for *new* (polymorphic, overloaded) locals - -- in terms of *old* (monomorphic, non-overloaded) ones. - -- - -- See section 9 of static semantics paper for more details. - -- (You can get a PhD for explaining the True Meaning - -- of this last construct.) +type RecFlag = Bool +recursive = True +nonRecursive = False \end{code} \begin{code} @@ -85,9 +79,7 @@ nullBinds :: HsBinds tyvar uvar id pat -> Bool 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 +nullBinds (MonoBind b _ _) = nullMonoBinds b \end{code} \begin{code} @@ -95,131 +87,22 @@ 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))) -\end{code} - -%************************************************************************ -%* * -\subsection{@Sig@: type signatures and value-modifying user pragmas} -%* * -%************************************************************************ - -It is convenient to lump ``value-modifying'' user-pragmas (e.g., -``specialise this function to these four types...'') in with type -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 - (HsType name) - SrcLoc - - | ClassOpSig name -- class-op sigs have different pragmas - (HsType name) - (ClassOpPragmas name) -- only interface ones have pragmas - SrcLoc - - | SpecSig name -- specialise a function or datatype ... - (HsType name) -- ... to these types - (Maybe name) -- ... maybe using this as the code for it - SrcLoc - - | InlineSig name -- INLINE f - SrcLoc - - | 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 _) - = ppHang (ppCat [pprNonSym sty var, ppPStr SLIT("::")]) - 4 (ppr sty ty) - - ppr sty (ClassOpSig var ty pragmas _) - = ppHang (ppCat [ppr sty (getOccName 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} - -%************************************************************************ -%* * -\subsection{Binding: @Bind@} -%* * -%************************************************************************ - -\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} - -\begin{code} -nullBind :: Bind tyvar uvar id pat -> Bool - -nullBind EmptyBind = True -nullBind (NonRecBind bs) = nullMonoBinds bs -nullBind (RecBind bs) = nullMonoBinds bs -\end{code} - -\begin{code} -bindIsRecursive :: Bind tyvar uvar id pat -> Bool - -bindIsRecursive EmptyBind = False -bindIsRecursive (NonRecBind _) = False -bindIsRecursive (RecBind _) = True -\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) + ppr sty binds = pprQuote sty (\ sty -> ppr_binds sty binds) + +ppr_binds sty EmptyBinds = empty +ppr_binds sty (ThenBinds binds1 binds2) + = ($$) (ppr_binds sty binds1) (ppr_binds sty binds2) +ppr_binds sty (MonoBind bind sigs is_rec) + = vcat [ + ifnotPprForUser sty (ptext rec_str), + if null sigs + then empty + else vcat (map (ppr sty) sigs), + ppr sty bind + ] + where + rec_str | is_rec = SLIT("{- rec -}") + | otherwise = SLIT("{- nonrec -}") \end{code} %************************************************************************ @@ -233,11 +116,14 @@ Global bindings (where clauses) \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 @@ -248,74 +134,155 @@ data MonoBinds tyvar uvar id pat | CoreMonoBind id -- TRANSLATION CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types! + + | AbsBinds -- Binds abstraction; TRANSLATION + [tyvar] -- Type variables + [id] -- Dicts + [([tyvar], id, id)] -- (type variables, polymorphic, momonmorphic) triples + (MonoBinds tyvar uvar id pat) -- The "business end" + + -- Creates bindings for *new* (polymorphic, overloaded) locals + -- in terms of *old* (monomorphic, non-overloaded) ones. + -- + -- See section 9 of static semantics paper for more details. + -- (You can get a PhD for explaining the True Meaning + -- of this last construct.) \end{code} +What AbsBinds means +~~~~~~~~~~~~~~~~~~~ + AbsBinds tvs + [d1,d2] + [(tvs1, f1p, f1m), + (tvs2, f2p, f2m)] + BIND +means + + 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.. + + p = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND + in (fm,gm) + \begin{code} nullMonoBinds :: MonoBinds tyvar uvar id pat -> Bool nullMonoBinds EmptyMonoBinds = True nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2 nullMonoBinds other_monobind = False + +andMonoBinds :: [MonoBinds tyvar uvar id pat] -> MonoBinds tyvar uvar id pat +andMonoBinds binds = foldr AndMonoBinds EmptyMonoBinds binds \end{code} \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 mbind = pprQuote sty (\ sty -> ppr_monobind sty mbind) + - ppr sty (PatMonoBind pat grhss_n_binds locn) - = ppHang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds) +ppr_monobind sty EmptyMonoBinds = empty +ppr_monobind sty (AndMonoBinds binds1 binds2) + = ($$) (ppr_monobind sty binds1) (ppr_monobind sty binds2) - ppr sty (FunMonoBind fun inf matches locn) - = pprMatches sty (False, pprNonSym sty fun) matches +ppr_monobind sty (PatMonoBind pat grhss_n_binds locn) + = hang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds) + +ppr_monobind sty (FunMonoBind fun inf matches locn) + = pprMatches sty (False, ppr sty fun) matches -- ToDo: print infix if appropriate - ppr sty (VarMonoBind name expr) - = ppHang (ppCat [pprNonSym sty name, ppEquals]) 4 (ppr sty expr) +ppr_monobind sty (VarMonoBind name expr) + = hang (hsep [ppr sty name, equals]) 4 (pprExpr sty expr) + +ppr_monobind sty (CoreMonoBind name expr) + = hang (hsep [ppr sty name, equals]) 4 (ppr sty expr) - ppr sty (CoreMonoBind name expr) - = ppHang (ppCat [pprNonSym sty name, ppEquals]) 4 (ppr sty expr) +ppr_monobind sty (AbsBinds tyvars dictvars exports val_binds) + = ($$) (sep [ptext SLIT("AbsBinds"), + brackets (interpp'SP sty tyvars), + brackets (interpp'SP sty dictvars), + brackets (interpp'SP sty exports)]) + (nest 4 (ppr sty val_binds)) \end{code} %************************************************************************ %* * -\subsection{Collecting binders from @HsBinds@} +\subsection{@Sig@: type signatures and value-modifying user pragmas} %* * %************************************************************************ -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). +It is convenient to lump ``value-modifying'' user-pragmas (e.g., +``specialise this function to these four types...'') in with type +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 + (HsType name) + SrcLoc + + | ClassOpSig name -- Selector name + name -- Default-method name + (HsType name) + SrcLoc + + | SpecSig name -- specialise a function or datatype ... + (HsType name) -- ... to these types + (Maybe name) -- ... maybe using this as the code for it + SrcLoc + + | InlineSig name -- INLINE f + SrcLoc + + | 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} -collectTopBinders :: HsBinds tyvar uvar name (InPat name) -> Bag (name,SrcLoc) -collectTopBinders EmptyBinds = emptyBag -collectTopBinders (SingleBind b) = collectBinders b -collectTopBinders (BindWith b _) = collectBinders b -collectTopBinders (ThenBinds b1 b2) - = collectTopBinders b1 `unionBags` collectTopBinders b2 - -collectBinders :: Bind tyvar uvar name (InPat name) -> Bag (name,SrcLoc) -collectBinders EmptyBind = emptyBag -collectBinders (NonRecBind monobinds) = collectMonoBinders monobinds -collectBinders (RecBind monobinds) = collectMonoBinders monobinds - -collectMonoBinders :: MonoBinds tyvar uvar name (InPat name) -> Bag (name,SrcLoc) -collectMonoBinders EmptyMonoBinds = emptyBag -collectMonoBinders (PatMonoBind pat grhss_w_binds loc) = listToBag (map (\v->(v,loc)) (collectPatBinders pat)) -collectMonoBinders (FunMonoBind f _ matches loc) = unitBag (f,loc) -collectMonoBinders (VarMonoBind v expr) = error "collectMonoBinders" -collectMonoBinders (CoreMonoBind v expr) = error "collectMonoBinders" -collectMonoBinders (AndMonoBinds bs1 bs2) - = collectMonoBinders bs1 `unionBags` collectMonoBinders bs2 +instance (NamedThing name, Outputable name) => Outputable (Sig name) where + ppr sty sig = pprQuote sty (\ sty -> ppr_sig sty sig) + + +ppr_sig sty (Sig var ty _) + = sep [ppr sty var <+> ptext SLIT("::"), + nest 4 (ppr sty ty)] + +ppr_sig sty (ClassOpSig var _ ty _) + = sep [ppr sty (getOccName var) <+> ptext SLIT("::"), + nest 4 (ppr sty ty)] + +ppr_sig sty (DeforestSig var _) + = hsep [text "{-# DEFOREST", ppr sty var, text "#-}"] + +ppr_sig sty (SpecSig var ty using _) + = sep [ hsep [text "{-# SPECIALIZE", ppr sty var, ptext SLIT("::")], + nest 4 (hsep [ppr sty ty, pp_using using, text "#-}"]) + ] + where + pp_using Nothing = empty + pp_using (Just me) = hsep [char '=', ppr sty me] + +ppr_sig sty (InlineSig var _) + = hsep [text "{-# INLINE", ppr sty var, text "#-}"] + +ppr_sig sty (MagicUnfoldingSig var str _) + = hsep [text "{-# MAGIC_UNFOLDING", ppr sty var, ptext str, text "#-}"] \end{code} +