Commit d455d8a0 authored by qrczak's avatar qrczak
Browse files

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

Add {-# INLINE instance #-} pragma which ensures that the dictionary
function is inlined.
parent 8166bb6c
......@@ -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}
{-
-----------------------------------------------------------------------------
$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) }
......
......@@ -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`
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment