X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FBasicTypes.lhs;h=f12571493512e2c2edab0775e463856091571e76;hb=a51fe79ebcdcb8285573a18f12cade2101533419;hp=41a5fa55bd4ed8e15cef7739deb7a77e8e91d998;hpb=215ce9f15215399ce30ae55c9521087847d78646;p=ghc-hetmet.git

diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs
index 41a5fa5..f125714 100644
--- a/compiler/basicTypes/BasicTypes.lhs
+++ b/compiler/basicTypes/BasicTypes.lhs
@@ -21,7 +21,7 @@ module BasicTypes(
 
 	Arity, 
 
-    FunctionOrData(..),
+        FunctionOrData(..),
 	
 	WarningTxt(..),
 
@@ -57,11 +57,15 @@ module BasicTypes(
 	HsBang(..), isBanged, isMarkedUnboxed, 
         StrictnessMark(..), isMarkedStrict,
 
+	DefMethSpec(..),
+
 	CompilerPhase, 
 	Activation(..), isActive, isNeverActive, isAlwaysActive, isEarlyActive,
         RuleMatchInfo(..), isConLike, isFunLike, 
-        InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma,
-	isDefaultInlinePragma, isInlinePragma, inlinePragmaSat,
+        InlineSpec(..), 
+        InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, 
+        neverInlinePragma, dfunInlinePragma, 
+	isDefaultInlinePragma, isInlinePragma, inlinePragmaSpec, inlinePragmaSat,
         inlinePragmaActivation, inlinePragmaRuleMatchInfo,
         setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
 
@@ -322,6 +326,7 @@ data OverlapFlag
 		--
 		-- Example: constraint (Foo [Int])
 		-- 	    instances  (Foo [Int])
+	
 		--		       (Foo [a])	OverlapOk
 		-- Since the second instance has the OverlapOk flag,
 		-- the first instance will be chosen (otherwise 
@@ -522,7 +527,7 @@ instance Show OccInfo where
 
 %************************************************************************
 %*									*
-\subsection{Strictness indication}
+		Strictness indication
 %*									*
 %************************************************************************
 
@@ -575,6 +580,28 @@ isMarkedStrict _               = True   -- All others are strict
 
 %************************************************************************
 %*									*
+		Default method specfication
+%*									*
+%************************************************************************
+
+The DefMethSpec enumeration just indicates what sort of default method
+is used for a class. It is generated from source code, and present in 
+interface files; it is converted to Class.DefMeth before begin put in a 
+Class object.
+
+\begin{code}
+data DefMethSpec = NoDM        -- No default method
+                 | VanillaDM   -- Default method given with polymorphic code
+                 | GenericDM   -- Default method given with generic code
+
+instance Outputable DefMethSpec where
+  ppr NoDM      = empty
+  ppr VanillaDM = ptext (sLit "{- Has default method -}")
+  ppr GenericDM = ptext (sLit "{- Has generic default method -}")
+\end{code}
+
+%************************************************************************
+%*									*
 \subsection{Success flag}
 %*									*
 %************************************************************************
@@ -616,21 +643,36 @@ data Activation = NeverActive
 		| AlwaysActive
 		| ActiveBefore CompilerPhase	-- Active only *before* this phase
 		| ActiveAfter CompilerPhase	-- Active in this phase and later
-		deriving( Eq, Data, Typeable )			-- Eq used in comparing rules in HsDecls
+		deriving( Eq, Data, Typeable )	-- Eq used in comparing rules in HsDecls
 
 data RuleMatchInfo = ConLike 			-- See Note [CONLIKE pragma]
                    | FunLike
-                   deriving( Eq, Data, Typeable )
+                   deriving( Eq, Data, Typeable, Show )
+	-- Show needed for Lexer.x
 
 data InlinePragma  	     -- Note [InlinePragma]
   = InlinePragma
-      { inl_inline :: Bool           -- True <=> INLINE, 
-      		      		     -- False <=> no pragma at all, or NOINLINE
+      { inl_inline :: InlineSpec
+
       , inl_sat    :: Maybe Arity    -- Just n <=> Inline only when applied to n 
       		      	    	     --            explicit (non-type, non-dictionary) args
+				     --   That is, inl_sat describes the number of *source-code*
+                                     --   arguments the thing must be applied to.  We add on the 
+                                     --   number of implicit, dictionary arguments when making
+			             --   the InlineRule, and don't look at inl_sat further
+
       , inl_act    :: Activation     -- Says during which phases inlining is allowed
+
       , inl_rule   :: RuleMatchInfo  -- Should the function be treated like a constructor?
     } deriving( Eq, Data, Typeable )
+
+data InlineSpec   -- What the user's INLINE pragama looked like
+  = Inline
+  | Inlinable
+  | NoInline
+  | EmptyInlineSpec
+  deriving( Eq, Data, Typeable, Show )
+	-- Show needed for Lexer.x
 \end{code}
 
 Note [InlinePragma]
@@ -693,16 +735,24 @@ isFunLike :: RuleMatchInfo -> Bool
 isFunLike FunLike = True
 isFunLike _            = False
 
+isInlineSpec :: InlineSpec -> Bool
+isInlineSpec Inline    = True
+isInlineSpec Inlinable = True
+isInlineSpec _         = False
+
 defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma
   :: InlinePragma
 defaultInlinePragma = InlinePragma { inl_act = AlwaysActive
                                    , inl_rule = FunLike
-                                   , inl_inline = False
+                                   , inl_inline = EmptyInlineSpec
                                    , inl_sat = Nothing }
 
-alwaysInlinePragma = defaultInlinePragma { inl_inline = True }
+alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline }
 neverInlinePragma  = defaultInlinePragma { inl_act    = NeverActive }
 
+inlinePragmaSpec :: InlinePragma -> InlineSpec
+inlinePragmaSpec = inl_inline
+
 -- A DFun has an always-active inline activation so that 
 -- exprIsConApp_maybe can "see" its unfolding
 -- (However, its actual Unfolding is a DFunUnfolding, which is
@@ -714,10 +764,10 @@ isDefaultInlinePragma :: InlinePragma -> Bool
 isDefaultInlinePragma (InlinePragma { inl_act = activation
                                     , inl_rule = match_info
                                     , inl_inline = inline })
-  = not inline && isAlwaysActive activation && isFunLike match_info
+  = isInlineSpec inline && isAlwaysActive activation && isFunLike match_info
 
 isInlinePragma :: InlinePragma -> Bool
-isInlinePragma prag = inl_inline prag
+isInlinePragma prag = isInlineSpec (inl_inline prag)
 
 inlinePragmaSat :: InlinePragma -> Maybe Arity
 inlinePragmaSat = inl_sat
@@ -744,16 +794,20 @@ instance Outputable RuleMatchInfo where
    ppr ConLike = ptext (sLit "CONLIKE")
    ppr FunLike = ptext (sLit "FUNLIKE")
 
+instance Outputable InlineSpec where
+   ppr Inline          = ptext (sLit "INLINE")
+   ppr NoInline        = ptext (sLit "NOINLINE")
+   ppr Inlinable       = ptext (sLit "INLINABLE")
+   ppr EmptyInlineSpec = empty
+
 instance Outputable InlinePragma where
   ppr (InlinePragma { inl_inline = inline, inl_act = activation
                     , inl_rule = info, inl_sat = mb_arity })
-    = pp_inl_act (inline, activation) <+> pp_sat <+> pp_info 
+    = ppr inline <> pp_act inline activation <+> pp_sat <+> pp_info 
     where
-      pp_inl_act (False, AlwaysActive)  = empty	-- defaultInlinePragma
-      pp_inl_act (False, NeverActive)   = ptext (sLit "NOINLINE")
-      pp_inl_act (False, act)           = ptext (sLit "NOINLINE") <> ppr act
-      pp_inl_act (True,  AlwaysActive)  = ptext (sLit "INLINE")
-      pp_inl_act (True,  act)           = ptext (sLit "INLINE") <> ppr act
+      pp_act Inline   AlwaysActive = empty	
+      pp_act NoInline NeverActive  = empty
+      pp_act _        act          = ppr act
 
       pp_sat | Just ar <- mb_arity = parens (ptext (sLit "sat-args=") <> int ar)
              | otherwise           = empty