summaryrefslogtreecommitdiff
path: root/ghc
diff options
context:
space:
mode:
authorsimonm <unknown>1998-05-22 15:23:51 +0000
committersimonm <unknown>1998-05-22 15:23:51 +0000
commitf36fb2ce821caf594c1db5669dd10ca082f66361 (patch)
tree4964ea970f1dbd28fb400df68b559740586e0e2b /ghc
parentab29b7806ead26dbebc9e04b54fec078e97ea104 (diff)
downloadhaskell-f36fb2ce821caf594c1db5669dd10ca082f66361.tar.gz
[project @ 1998-05-22 15:23:11 by simonm]
Add NOINLINE pragma. - add new type of inline info: IDontWantToBeINLINEd - hopefully get the interactions between IMustNotBeINLINEd (which is used by the simplifier to ensure termination when simplifying recursive binding groups) and IDontWantToBeINLINEd. - no need to pass NOINLINE across modules, we just make sure that any function marked as NOLINE doesn't get an unfolding in the interface.
Diffstat (limited to 'ghc')
-rw-r--r--ghc/compiler/basicTypes/Id.lhs13
-rw-r--r--ghc/compiler/basicTypes/IdInfo.lhs4
-rw-r--r--ghc/compiler/codeGen/ClosureInfo.lhs2
-rw-r--r--ghc/compiler/coreSyn/CoreUnfold.lhs75
-rw-r--r--ghc/compiler/hsSyn/HsBinds.lhs17
-rw-r--r--ghc/compiler/main/MkIface.lhs9
-rw-r--r--ghc/compiler/parser/binding.ugn3
-rw-r--r--ghc/compiler/parser/hslexer.flex4
-rw-r--r--ghc/compiler/parser/hsparser.y14
-rw-r--r--ghc/compiler/reader/ReadPrefix.lhs5
-rw-r--r--ghc/compiler/rename/RnBinds.lhs8
-rw-r--r--ghc/compiler/typecheck/TcBinds.lhs3
-rw-r--r--ghc/compiler/typecheck/TcClassDcl.lhs2
13 files changed, 122 insertions, 37 deletions
diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 9d3028c6a9..1b680634c4 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -522,8 +522,9 @@ idWantsToBeINLINEd id = case getInlinePragma id of
other -> False
idMustNotBeINLINEd id = case getInlinePragma id of
- IMustNotBeINLINEd -> True
- other -> False
+ IDontWantToBeINLINEd -> True
+ IMustNotBeINLINEd -> True
+ other -> False
idMustBeINLINEd id = case getInlinePragma id of
IMustBeINLINEd -> True
@@ -539,9 +540,15 @@ nukeNoInlinePragma id@(Id {idInfo = info})
IMustNotBeINLINEd -> id {idInfo = setInlinePragInfo NoPragmaInfo info}
other -> id
+-- If the user has already marked this binding as NOINLINE, then don't
+-- add the IMustNotBeINLINEd tag, since it will get nuked later whereas
+-- IDontWantToBeINLINEd is permanent.
+
addNoInlinePragma :: Id -> Id
addNoInlinePragma id@(Id {idInfo = info})
- = id {idInfo = IMustNotBeINLINEd `setInlinePragInfo` info}
+ = case inlinePragInfo info of
+ IDontWantToBeINLINEd -> id
+ other -> id {idInfo = IMustNotBeINLINEd `setInlinePragInfo` info}
mustInlineInfo = IMustBeINLINEd `setInlinePragInfo` noIdInfo
wantToInlineInfo = IWantToBeINLINEd `setInlinePragInfo` noIdInfo
diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs
index 10720f0588..7e1c8d56be 100644
--- a/ghc/compiler/basicTypes/IdInfo.lhs
+++ b/ghc/compiler/basicTypes/IdInfo.lhs
@@ -180,7 +180,9 @@ ppArityInfo (ArityAtLeast arity) = hsep [ptext SLIT("_A>_"), int arity]
data InlinePragInfo
= NoPragmaInfo
- | IWantToBeINLINEd
+ | IWantToBeINLINEd -- user requests that we inline this
+
+ | IDontWantToBeINLINEd -- user requests that we don't inline this
| IMustNotBeINLINEd -- Used by the simplifier to prevent looping
-- on recursive definitions
diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs
index db6a9da4f6..2b7a7a1a85 100644
--- a/ghc/compiler/codeGen/ClosureInfo.lhs
+++ b/ghc/compiler/codeGen/ClosureInfo.lhs
@@ -102,6 +102,7 @@ import Type ( isUnpointedType, splitForAllTys, splitFunTys, mkFunTys,
)
import Util ( isIn, mapAccumL )
import Outputable
+import GlaExts --tmp
\end{code}
The ``wrapper'' data type for closure information:
@@ -1133,6 +1134,7 @@ fun_result_ty arity ty
-> fun_result_ty (arity - n_arg_tys) rep_ty
where
([rep_ty], _) = splitFunTys (applyTys (idType con) tycon_arg_tys)
+ Just (_,_,cons) -> trace (showSDoc (ppr ty) ++ showSDoc(ppr cons)) $ panic "fun_result_ty"
where
(_, rho_ty) = splitForAllTys ty
(arg_tys, res_ty) = splitFunTys rho_ty
diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index d06fd93cb3..5d1f2b2b69 100644
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -59,7 +59,11 @@ import TyCon ( tyConFamilySize )
import Type ( splitAlgTyConApp_maybe )
import Unique ( Unique )
import Util ( isIn, panic, assertPanic )
+import UniqFM
import Outputable
+
+import List ( maximumBy )
+import GlaExts --tmp
\end{code}
%************************************************************************
@@ -245,7 +249,9 @@ calcUnfoldingGuidance bOMB_OUT_SIZE expr
TooBig -> UnfoldNever
SizeIs size cased_args scrut_discount
- -> UnfoldIfGoodArgs
+ -> {- trace ("calcUnfoldingGuidance: \n" ++ showSDoc (ppr expr) ++ "\n"
+ ++ show (I# size) ++ "\n" ++ show (map discount_for val_binders)) $ -}
+ UnfoldIfGoodArgs
(length ty_binders)
(length val_binders)
(map discount_for val_binders)
@@ -253,15 +259,16 @@ calcUnfoldingGuidance bOMB_OUT_SIZE expr
(I# scrut_discount)
where
discount_for b
- | is_data && b `is_elem` cased_args = tyConFamilySize tycon
+ | is_data = case lookupUFM cased_args b of
+ Nothing -> 0
+ Just d -> d
| otherwise = 0
where
(is_data, tycon)
= case (splitAlgTyConApp_maybe (idType b)) of
Nothing -> (False, panic "discount")
Just (tc,_,_) -> (True, tc)
-
- is_elem = isIn "calcUnfoldingGuidance" }
+ }
\end{code}
\begin{code}
@@ -319,9 +326,7 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr
size_up (Case scrut alts)
= nukeScrutDiscount (size_up scrut)
`addSize`
- arg_discount scrut
- `addSize`
- size_up_alts (coreExprType scrut) alts
+ size_up_alts scrut (coreExprType scrut) alts
-- We charge for the "case" itself in "size_up_alts"
------------
@@ -333,11 +338,23 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr
size_up_arg other = sizeOne
------------
- size_up_alts scrut_ty (AlgAlts alts deflt)
- = (foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts)
+ size_up_alts scrut scrut_ty (AlgAlts alts deflt)
+ = total_size
+ `addSize`
+ scrut_discount scrut
`addSizeN`
alt_cost
where
+ alts_sizes = size_up_deflt deflt : map size_alg_alt alts
+ total_size = foldr addSize sizeZero alts_sizes
+
+ biggest_alt = maximumBy (\a b -> if ltSize a b then b else a) alts_sizes
+
+ scrut_discount (Var v) | v `is_elem` args =
+ scrutArg v (minusSize total_size biggest_alt + alt_cost)
+ scrut_discount _ = sizeZero
+
+
size_alg_alt (con,args,rhs) = size_up rhs
-- Don't charge for args, so that wrappers look cheap
@@ -355,7 +372,7 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr
Nothing -> 1
Just (tc,_,_) -> tyConFamilySize tc
- size_up_alts _ (PrimAlts alts deflt)
+ size_up_alts _ _ (PrimAlts alts deflt)
= foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts
-- *no charge* for a primitive "case"!
where
@@ -366,10 +383,6 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr
size_up_deflt (BindDefault binder rhs) = size_up rhs
------------
- -- We want to record if we're case'ing an argument
- arg_discount (Var v) | v `is_elem` args = scrutArg v
- arg_discount other = sizeZero
-
is_elem :: Id -> [Id] -> Bool
is_elem = isIn "size_up_scrut"
@@ -384,6 +397,14 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr
where
n_tot = n +# m
+ -- trying to find a reasonable discount for eliminating this case.
+ -- if the case is eliminated, in the worse case we end up with the
+ -- largest alternative, so subtract the size of the largest alternative
+ -- from the total size of the case to end up with the discount
+ minusSize TooBig _ = 0
+ minusSize _ TooBig = panic "CoreUnfold: minusSize" -- shouldn't happen
+ minusSize (SizeIs n1 xs d1) (SizeIs n2 ys d2) = I# (n1 -# n2)
+
addSize TooBig _ = TooBig
addSize _ TooBig = TooBig
addSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)
@@ -392,8 +413,9 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr
where
n_tot = n1 +# n2
d_tot = d1 +# d2
- xys = xs ++ ys
+ xys = combineArgDiscounts xs ys
+
\end{code}
@@ -403,18 +425,25 @@ Code for manipulating sizes
data ExprSize = TooBig
| SizeIs Int# -- Size found
- [Id] -- Arguments cased herein
+ (UniqFM Int) -- discount for each argument
Int# -- Size to subtract if result is scrutinised
-- by a case expression
-sizeZero = SizeIs 0# [] 0#
-sizeOne = SizeIs 1# [] 0#
-sizeN (I# n) = SizeIs n [] 0#
-conSizeN (I# n) = SizeIs n [] n
-scrutArg v = SizeIs 0# [v] 0#
+ltSize a TooBig = True
+ltSize TooBig a = False
+ltSize (SizeIs s1# _ _) (SizeIs s2# _ _) = s1# <=# s2#
+
+sizeZero = SizeIs 0# emptyUFM 0#
+sizeOne = SizeIs 1# emptyUFM 0#
+sizeN (I# n) = SizeIs n emptyUFM 0#
+conSizeN (I# n) = SizeIs n emptyUFM n
+scrutArg v d = SizeIs 0# (unitUFM v d) 0#
nukeScrutDiscount (SizeIs n vs d) = SizeIs n vs 0#
nukeScrutDiscount TooBig = TooBig
+
+combineArgDiscounts :: UniqFM Int -> UniqFM Int -> UniqFM Int
+combineArgDiscounts = plusUFM_C (+)
\end{code}
%************************************************************************
@@ -484,8 +513,8 @@ smallEnoughToInline id arg_is_evald_s result_is_scruted
result_discount | result_is_scruted = scrut_discount
| otherwise = 0
- arg_discount no_of_constrs is_evald
- | is_evald = no_of_constrs * opt_UnfoldingConDiscount
+ arg_discount discount is_evald
+ | is_evald = discount
| otherwise = 0
\end{code}
diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs
index d6246f15e5..f75117cecb 100644
--- a/ghc/compiler/hsSyn/HsBinds.lhs
+++ b/ghc/compiler/hsSyn/HsBinds.lhs
@@ -222,6 +222,9 @@ data Sig name
| InlineSig name -- INLINE f
SrcLoc
+ | NoInlineSig name -- NOINLINE f
+ SrcLoc
+
| SpecInstSig (HsType name) -- (Class tys); should be a specialisation of the
-- current instance decl
SrcLoc
@@ -232,11 +235,12 @@ sigsForMe :: (name -> Bool) -> [Sig name] -> [Sig name]
sigsForMe f sigs
= filter sig_for_me sigs
where
- sig_for_me (Sig n _ _) = f n
- sig_for_me (ClassOpSig n _ _ _) = f n
- sig_for_me (SpecSig n _ _ _) = f n
- sig_for_me (InlineSig n _) = f n
- sig_for_me (SpecInstSig _ _) = False
+ sig_for_me (Sig n _ _) = f n
+ sig_for_me (ClassOpSig n _ _ _) = f n
+ sig_for_me (SpecSig n _ _ _) = f n
+ sig_for_me (InlineSig n _) = f n
+ sig_for_me (NoInlineSig n _) = f n
+ sig_for_me (SpecInstSig _ _) = False
\end{code}
\begin{code}
@@ -263,6 +267,9 @@ ppr_sig (SpecSig var ty using _)
ppr_sig (InlineSig var _)
= hsep [text "{-# INLINE", ppr var, text "#-}"]
+ppr_sig (NoInlineSig var _)
+ = hsep [text "{-# NOINLINE", ppr var, text "#-}"]
+
ppr_sig (SpecInstSig ty _)
= hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
\end{code}
diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index fd6d8c89bc..cd818c1a77 100644
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -304,10 +304,11 @@ ifaceId get_idinfo needed_ids is_rec id rhs
unfolding_is_ok
= case inline_pragma of
- IMustBeINLINEd -> True
- IWantToBeINLINEd -> True
- IMustNotBeINLINEd -> False
- NoPragmaInfo -> case guidance of
+ IMustBeINLINEd -> True
+ IWantToBeINLINEd -> True
+ IDontWantToBeINLINEd -> False
+ IMustNotBeINLINEd -> False
+ NoPragmaInfo -> case guidance of
UnfoldNever -> False -- Too big
other -> True
diff --git a/ghc/compiler/parser/binding.ugn b/ghc/compiler/parser/binding.ugn
index 76b067ced5..74c8a925fa 100644
--- a/ghc/compiler/parser/binding.ugn
+++ b/ghc/compiler/parser/binding.ugn
@@ -72,6 +72,9 @@ type binding;
inline_uprag: < ginline_id : qid;
ginline_line : long; >;
+ noinline_uprag: < gnoinline_id : qid;
+ gnoinline_line : long; >;
+
magicuf_uprag:< gmagicuf_id : qid;
gmagicuf_str : stringId;
gmagicuf_line : long; >;
diff --git a/ghc/compiler/parser/hslexer.flex b/ghc/compiler/parser/hslexer.flex
index 432625aa16..a3abd5a589 100644
--- a/ghc/compiler/parser/hslexer.flex
+++ b/ghc/compiler/parser/hslexer.flex
@@ -325,6 +325,10 @@ NL [\n\r]
PUSH_STATE(UserPragma);
RETURN(INLINE_UPRAGMA);
}
+<Code,GlaExt>"{-#"{WS}*"NOINLINE" {
+ PUSH_STATE(UserPragma);
+ RETURN(NOINLINE_UPRAGMA);
+ }
<Code,GlaExt>"{-#"{WS}*"MAGIC_UNFOLDING" {
PUSH_STATE(UserPragma);
RETURN(MAGIC_UNFOLDING_UPRAGMA);
diff --git a/ghc/compiler/parser/hsparser.y b/ghc/compiler/parser/hsparser.y
index d3025889de..05441f9552 100644
--- a/ghc/compiler/parser/hsparser.y
+++ b/ghc/compiler/parser/hsparser.y
@@ -183,7 +183,7 @@ long source_version = 0;
**********************************************************************/
%token INTERFACE_UPRAGMA SPECIALISE_UPRAGMA
-%token INLINE_UPRAGMA MAGIC_UNFOLDING_UPRAGMA
+%token INLINE_UPRAGMA NOINLINE_UPRAGMA MAGIC_UNFOLDING_UPRAGMA
%token END_UPRAGMA
%token SOURCE_UPRAGMA
@@ -590,6 +590,12 @@ decl : qvarsk DCOLON sigtype
PREVPATT = NULL; FN = NULL; SAMEFN = 0;
}
+ | NOINLINE_UPRAGMA qvark END_UPRAGMA
+ {
+ $$ = mknoinline_uprag($2, startlineno);
+ PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+ }
+
| MAGIC_UNFOLDING_UPRAGMA qvark vark END_UPRAGMA
{
$$ = mkmagicuf_uprag($2, $3, startlineno);
@@ -845,6 +851,12 @@ instdef :
PREVPATT = NULL; FN = NULL; SAMEFN = 0;
}
+ | NOINLINE_UPRAGMA qvark END_UPRAGMA
+ {
+ $$ = mknoinline_uprag($2, startlineno);
+ PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+ }
+
| MAGIC_UNFOLDING_UPRAGMA qvark vark END_UPRAGMA
{
$$ = mkmagicuf_uprag($2, $3, startlineno);
diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs
index ce285de070..1dc750ef78 100644
--- a/ghc/compiler/reader/ReadPrefix.lhs
+++ b/ghc/compiler/reader/ReadPrefix.lhs
@@ -648,6 +648,11 @@ wlk_sig_thing (U_inline_uprag ivar srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
wlkVarId ivar `thenUgn` \ var ->
returnUgn (RdrSig (InlineSig var src_loc))
+
+wlk_sig_thing (U_noinline_uprag ivar srcline)
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ wlkVarId ivar `thenUgn` \ var ->
+ returnUgn (RdrSig (NoInlineSig var src_loc))
\end{code}
%************************************************************************
diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs
index 4f302044b8..eef7a3fbe3 100644
--- a/ghc/compiler/rename/RnBinds.lhs
+++ b/ghc/compiler/rename/RnBinds.lhs
@@ -503,6 +503,11 @@ renameSig (InlineSig v src_loc)
= pushSrcLocRn src_loc $
lookupBndrRn v `thenRn` \ new_v ->
returnRn (InlineSig new_v src_loc)
+
+renameSig (NoInlineSig v src_loc)
+ = pushSrcLocRn src_loc $
+ lookupBndrRn v `thenRn` \ new_v ->
+ returnRn (NoInlineSig new_v src_loc)
\end{code}
Checking for distinct signatures; oh, so boring
@@ -511,6 +516,7 @@ Checking for distinct signatures; oh, so boring
cmp_sig :: RenamedSig -> RenamedSig -> Ordering
cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2
cmp_sig (InlineSig n1 _) (InlineSig n2 _) = n1 `compare` n2
+cmp_sig (NoInlineSig n1 _) (NoInlineSig n2 _) = n1 `compare` n2
cmp_sig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = cmpHsType compare ty1 ty2
cmp_sig (SpecSig n1 ty1 _ _) (SpecSig n2 ty2 _ _)
= -- may have many specialisations for one value;
@@ -524,6 +530,7 @@ cmp_sig other_1 other_2 -- Tags *must* be different
sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT)
sig_tag (SpecSig n1 _ _ _) = ILIT(2)
sig_tag (InlineSig n1 _) = ILIT(3)
+sig_tag (NoInlineSig n1 _) = ILIT(4)
sig_tag (SpecInstSig _ _) = ILIT(5)
sig_tag _ = panic# "tag(RnBinds)"
\end{code}
@@ -555,6 +562,7 @@ sig_doc (Sig _ _ loc) = (SLIT("type signature"),loc)
sig_doc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc)
sig_doc (SpecSig _ _ _ loc) = (SLIT("SPECIALISE pragma"),loc)
sig_doc (InlineSig _ loc) = (SLIT("INLINE pragma"),loc)
+sig_doc (NoInlineSig _ loc) = (SLIT("NOINLINE pragma"),loc)
sig_doc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc)
missingSigErr var
diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index f711ef7207..b5765eff7a 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -859,6 +859,9 @@ tcPragmaSig (SpecInstSig _ _) = returnTc (Nothing, EmptyMonoBinds, emptyLIE)
tcPragmaSig (InlineSig name loc)
= returnTc (Just (name, setInlinePragInfo IWantToBeINLINEd), EmptyMonoBinds, emptyLIE)
+tcPragmaSig (NoInlineSig name loc)
+ = returnTc (Just (name, setInlinePragInfo IDontWantToBeINLINEd), EmptyMonoBinds, emptyLIE)
+
tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
= -- SPECIALISE f :: forall b. theta => tau = g
tcAddSrcLoc src_loc $
diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index 82c9212321..e4dec94c52 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -549,6 +549,8 @@ tcMethodBind clas origin inst_tys inst_tyvars
| name == sel_name = SpecSig meth_name ty spec loc : find_prags meth_name prags
find_prags meth_name (InlineSig name loc : prags)
| name == sel_name = InlineSig meth_name loc : find_prags meth_name prags
+ find_prags meth_name (NoInlineSig name loc : prags)
+ | name == sel_name = NoInlineSig meth_name loc : find_prags meth_name prags
find_prags meth_name (prag:prags) = find_prags meth_name prags
mk_default_bind local_meth_name loc
View Lorry Controller Status