[project @ 2001-04-14 22:24:24 by qrczak]

Add {-# INLINE instance #-} pragma which ensures that the dictionary
function is inlined.

diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs
index 4483543..13f6047 100644 (file)
--- a/ghc/compiler/hsSyn/HsBinds.lhs
+++ b/ghc/compiler/hsSyn/HsBinds.lhs
@@ -261,6 +261,9 @@ data Sig name
                                -- current instance decl
                SrcLoc
 
+  | InlineInstSig (Maybe Int)  -- phase
+               SrcLoc
+
   | FixSig     (FixitySig name)        -- Fixity declaration
 
 
@@ -283,6 +286,7 @@ okInstDclSig :: NameSet -> Sig Name -> Bool
 okInstDclSig ns (Sig _ _ _)                                       = False
 okInstDclSig ns (FixSig _)                                        = False
 okInstDclSig ns (SpecInstSig _ _)                                 = True
+okInstDclSig ns (InlineInstSig _ _)                               = True
 okInstDclSig ns sig = sigForThisGroup ns sig
 
 sigForThisGroup ns sig 
@@ -314,6 +318,7 @@ isPragSig (SpecSig _ _ _)     = True
 isPragSig (InlineSig   _ _ _) = True
 isPragSig (NoInlineSig _ _ _) = True
 isPragSig (SpecInstSig _ _)   = True
+isPragSig (InlineInstSig _ _) = True
 isPragSig other                      = False
 \end{code}
 
@@ -324,6 +329,7 @@ hsSigDoc (SpecSig    _ _ loc)             = (SLIT("SPECIALISE pragma"),loc)
 hsSigDoc (InlineSig  _ _    loc)      = (SLIT("INLINE pragma"),loc)
 hsSigDoc (NoInlineSig  _ _  loc)      = (SLIT("NOINLINE pragma"),loc)
 hsSigDoc (SpecInstSig _ loc)         = (SLIT("SPECIALISE instance pragma"),loc)
+hsSigDoc (InlineInstSig _ loc)       = (SLIT("INLINE instance pragma"),loc)
 hsSigDoc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc)
 \end{code}
 
@@ -357,6 +363,9 @@ ppr_sig (NoInlineSig var phase _)
 ppr_sig (SpecInstSig ty _)
       = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
 
+ppr_sig (InlineInstSig phase _)
+      = hsep [text "{-# INLINE instance", ppr_phase phase, text "#-}"]
+
 ppr_sig (FixSig fix_sig) = ppr fix_sig
 
 
@@ -378,10 +387,11 @@ eqHsSig (InlineSig n1 _ _)   (InlineSig n2 _ _)   = n1 == n2
 eqHsSig (NoInlineSig n1 _ _) (NoInlineSig n2 _ _) = n1 == n2
 
 eqHsSig (SpecInstSig ty1 _)  (SpecInstSig ty2 _)  = ty1 == ty2
-eqHsSig (SpecSig n1 ty1 _)   (SpecSig n2 ty2 _) 
-  = -- may have many specialisations for one value;
+eqHsSig (SpecSig n1 ty1 _)   (SpecSig n2 ty2 _)   =
+    -- may have many specialisations for one value;
     -- but not ones that are exactly the same...
     (n1 == n2) && (ty1 == ty2)
+eqHsSig (InlineInstSig _ _)  (InlineInstSig _ _)  = True
 
 eqHsSig other_1 other_2 = False
 \end{code}

diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index d5c3f27..93c663d 100644 (file)
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
 {-
 -----------------------------------------------------------------------------
-$Id: Parser.y,v 1.56 2001/04/05 11:54:37 simonpj Exp $
+$Id: Parser.y,v 1.57 2001/04/14 22:24:24 qrczak Exp $
 
 Haskell grammar.
 
@@ -386,8 +386,9 @@ decls       :: { [RdrBinding] }
 decl   :: { RdrBinding }
        : fixdecl                       { $1 }
        | valdef                        { $1 }
-       | '{-# INLINE'   srcloc opt_phase qvar '#-}'    { RdrSig (InlineSig $4 $3 $2) }
-       | '{-# NOINLINE' srcloc opt_phase qvar '#-}'    { RdrSig (NoInlineSig $4 $3 $2) }
+       | '{-# INLINE'   srcloc opt_phase qvar '#-}'     { RdrSig (InlineSig $4 $3 $2) }
+       | '{-# NOINLINE' srcloc opt_phase qvar '#-}'     { RdrSig (NoInlineSig $4 $3 $2) }
+       | '{-# INLINE' srcloc 'instance' opt_phase '#-}' { RdrSig (InlineInstSig $4 $2) }
        | '{-# SPECIALISE' srcloc qvar '::' sigtypes '#-}'
                { foldr1 RdrAndBindings 
                    (map (\t -> RdrSig (SpecSig $3 t $2)) $5) }

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index b658e93..1a38a13 100644 (file)
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -52,7 +52,7 @@ import FunDeps                ( checkInstFDs )
 import Generics                ( validGenericInstanceType )
 import Module          ( Module, foldModuleEnv )
 import Name            ( getSrcLoc )
-import NameSet         ( emptyNameSet, nameSetToList )
+import NameSet         ( emptyNameSet, mkNameSet, nameSetToList )
 import PrelInfo                ( eRROR_ID )
 import PprType         ( pprClassPred, pprPred )
 import TyCon           ( TyCon, isSynTyCon )
@@ -601,6 +601,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id,
         dict_constr   = classDataCon clas
        scs_and_meths = map instToId (sc_dicts ++ meth_insts)
        this_dict_id  = instToId this_dict
+       inlines       = mkNameSet [idName dfun_id | InlineInstSig _ _ <- uprags]
 
        dict_rhs
          | null scs_and_meths
@@ -633,7 +634,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id,
                 zonked_inst_tyvars
                 (map instToId dfun_arg_dicts)
                 [(inst_tyvars', dfun_id, this_dict_id)] 
-                emptyNameSet           -- No inlines (yet)
+                inlines
                 (lie_binds1    `AndMonoBinds` 
                  lie_binds2    `AndMonoBinds`
                  method_binds  `AndMonoBinds`