X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FHsBinds.lhs;h=f3648832f3c6c4e39d0fc4781c4d070e5b28ffe6;hb=6f8ff0bbad3b9fa389c960ad1b5a267a1ae502f1;hp=0cf796692e3d70950f0baef703cf33d0d83a0db1;hpb=a9db145ff5b02ad9c79fcef44898a37254cc6c1a;p=ghc-hetmet.git

diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index 0cf7966..f364883 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -16,7 +16,7 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
 
 module HsBinds where
 
-import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, LHsExpr,
+import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,
 			       MatchGroup, pprFunBind,
 			       GRHSs, pprPatBind )
 import {-# SOURCE #-} HsPat  ( LPat )
@@ -130,8 +130,10 @@ data HsBindLR idL idR
     }
 
   | VarBind {	-- Dictionary binding and suchlike 
-	var_id :: idL,		-- All VarBinds are introduced by the type checker
-	var_rhs :: LHsExpr idR	-- Located only for consistency
+	var_id     :: idL,	     -- All VarBinds are introduced by the type checker
+	var_rhs    :: LHsExpr idR,   -- Located only for consistency
+	var_inline :: Bool           -- True <=> inline this binding regardless
+				     --	(used for implication constraints only)
     }
 
   | AbsBinds {					-- Binds abstraction; TRANSLATION
@@ -141,7 +143,7 @@ data HsBindLR idL idR
        -- AbsBinds only gets used when idL = idR after renaming,
        -- but these need to be idL's for the collect... code in HsUtil to have
        -- the right type
-	abs_exports :: [([TyVar], idL, idL, [LPrag])],	-- (tvs, poly_id, mono_id, prags)
+	abs_exports :: [([TyVar], idL, idL, TcSpecPrags)],	-- (tvs, poly_id, mono_id, prags)
 	abs_binds   :: LHsBinds idL		-- The dictionary bindings and typechecked user bindings
 						-- mixed up together; you can tell the dict bindings because
 						-- they are all VarBinds
@@ -290,7 +292,7 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_dicts = dictvars,
   where
     ppr_exp (tvs, gbl, lcl, prags)
 	= vcat [ppr gbl <+> ptext (sLit "<=") <+> ppr tvs <+> ppr lcl,
-	  	nest 2 (vcat (map (pprPrag gbl) prags))]
+	  	nest 2 (pprTcSpecPrags gbl prags)]
 \end{code}
 
 
@@ -363,7 +365,6 @@ data HsWrapper
 
   | WpLam Var	 		-- \d. []	the 'd' is a type-class dictionary or coercion variable
   | WpTyLam TyVar 		-- \a. []	the 'a' is a type variable (not coercion var)
-  | WpInline			-- inline_me []   Wrap inline around the thing
 
 	-- Non-empty bindings, so that the identity coercion
 	-- is always exactly WpHole
@@ -384,7 +385,6 @@ pprHsWrapper it wrap =
         help it (WpLam id)    = sep [ptext (sLit "\\") <> pprBndr LambdaBind id <> dot, it]
         help it (WpTyLam tv)  = sep [ptext (sLit "/\\") <> pprBndr LambdaBind tv <> dot, it]
         help it (WpLet binds) = sep [ptext (sLit "let") <+> braces (ppr binds), it]
-        help it WpInline      = sep [ptext (sLit "_inline_me_"), it]
     in
       -- in debug mode, print the wrapper
       -- otherwise just print what's inside
@@ -452,13 +452,15 @@ data Sig name	-- Signatures and pragmas
 	-- An inline pragma
 	-- {#- INLINE f #-}
   | InlineSig	(Located name)	-- Function name
-		InlineSpec
+		InlinePragma	-- Never defaultInlinePragma
 
 	-- A specialisation pragma
 	-- {-# SPECIALISE f :: Int -> Int #-}
   | SpecSig 	(Located name)	-- Specialise a function or datatype ...
 		(LHsType name)	-- ... to these types
-		InlineSpec
+		InlinePragma    -- The pragma on SPECIALISE_INLINE form
+				-- If it's just defaultInlinePragma, then we said
+				--    SPECIALISE, not SPECIALISE_INLINE
 
 	-- A specialisation pragma for instance declarations only
 	-- {-# SPECIALISE instance Eq [Int] #-}
@@ -469,24 +471,28 @@ data Sig name	-- Signatures and pragmas
 type LFixitySig name = Located (FixitySig name)
 data FixitySig name = FixitySig (Located name) Fixity 
 
--- A Prag conveys pragmas from the type checker to the desugarer
-type LPrag = Located Prag
-data Prag 
-  = InlinePrag 
-	InlineSpec
+-- TsSpecPrags conveys pragmas from the type checker to the desugarer
+data TcSpecPrags 
+  = IsDefaultMethod	-- Super-specialised: a default method should 
+    			-- be macro-expanded at every call site
+  | SpecPrags [Located TcSpecPrag]
 
-  | SpecPrag   
-	(HsExpr Id)	-- An expression, of the given specialised type, which
-	PostTcType 	-- specialises the polymorphic function
-	InlineSpec 	-- Inlining spec for the specialised function
+data TcSpecPrag 
+  = SpecPrag   
+	HsWrapper	-- An wrapper, that specialises the polymorphic function
+	InlinePragma 	-- Inlining spec for the specialised function
 
-isInlinePrag :: Prag -> Bool
-isInlinePrag (InlinePrag _) = True
-isInlinePrag _              = False
+noSpecPrags :: TcSpecPrags
+noSpecPrags = SpecPrags []
+
+hasSpecPrags :: TcSpecPrags -> Bool
+hasSpecPrags (SpecPrags ps) = not (null ps)
+hasSpecPrags IsDefaultMethod = False
+
+isDefaultMethod :: TcSpecPrags -> Bool
+isDefaultMethod IsDefaultMethod = True
+isDefaultMethod (SpecPrags {})  = False
 
-isSpecPrag :: Prag -> Bool
-isSpecPrag (SpecPrag {}) = True
-isSpecPrag _             = False
 \end{code}
 
 \begin{code}
@@ -585,10 +591,10 @@ instance (OutputableBndr name) => Outputable (Sig name) where
     ppr sig = ppr_sig sig
 
 ppr_sig :: OutputableBndr name => Sig name -> SDoc
-ppr_sig (TypeSig var ty)	  = pprVarSig (unLoc var) ty
-ppr_sig (IdSig id)	          = pprVarSig id (varType id)
+ppr_sig (TypeSig var ty)	  = pprVarSig (unLoc var) (ppr ty)
+ppr_sig (IdSig id)	          = pprVarSig id (ppr (varType id))
 ppr_sig (FixSig fix_sig) 	  = ppr fix_sig
-ppr_sig (SpecSig var ty inl) 	  = pragBrackets (pprSpec var ty inl)
+ppr_sig (SpecSig var ty inl) 	  = pragBrackets (pprSpec var (ppr ty) inl)
 ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> ppr var)
 ppr_sig (SpecInstSig ty) 	  = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
 
@@ -598,14 +604,23 @@ instance Outputable name => Outputable (FixitySig name) where
 pragBrackets :: SDoc -> SDoc
 pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}") 
 
-pprVarSig :: (Outputable id, Outputable ty) => id -> ty -> SDoc
-pprVarSig var ty = sep [ppr var <+> dcolon, nest 2 (ppr ty)]
+pprVarSig :: (Outputable id) => id -> SDoc -> SDoc
+pprVarSig var pp_ty = sep [ppr var <+> dcolon, nest 2 pp_ty]
+
+pprSpec :: (Outputable id) => id -> SDoc -> InlinePragma -> SDoc
+pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig var pp_ty
+  where
+    pp_inl | isDefaultInlinePragma inl = empty
+           | otherwise = ppr inl
+
+pprTcSpecPrags :: Outputable id => id -> TcSpecPrags -> SDoc
+pprTcSpecPrags _   IsDefaultMethod = ptext (sLit "<default method>")
+pprTcSpecPrags gbl (SpecPrags ps)  = vcat (map (pprSpecPrag gbl) ps)
 
-pprSpec :: (Outputable id, Outputable ty) => id -> ty -> InlineSpec -> SDoc
-pprSpec var ty inl = sep [ptext (sLit "SPECIALIZE") <+> ppr inl <+> pprVarSig var ty]
+pprSpecPrag :: Outputable id => id -> Located TcSpecPrag -> SDoc
+pprSpecPrag var (L _ (SpecPrag _expr inl)) = pprSpec var (ptext (sLit "<type>")) inl
 
-pprPrag :: Outputable id => id -> LPrag -> SDoc
-pprPrag var (L _ (InlinePrag inl))        = ppr inl <+> ppr var
-pprPrag var (L _ (SpecPrag _expr ty inl)) = pprSpec var ty inl
+instance Outputable TcSpecPrag where
+  ppr (SpecPrag _ p) = ptext (sLit "SpecPrag") <+> ppr p
 \end{code}