From f36fb2ce821caf594c1db5669dd10ca082f66361 Mon Sep 17 00:00:00 2001 From: simonm Date: Fri, 22 May 1998 15:23:51 +0000 Subject: [PATCH 1/1] [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. --- ghc/compiler/basicTypes/Id.lhs | 13 ++++-- ghc/compiler/basicTypes/IdInfo.lhs | 4 +- ghc/compiler/codeGen/ClosureInfo.lhs | 2 + ghc/compiler/coreSyn/CoreUnfold.lhs | 75 +++++++++++++++++++++++---------- ghc/compiler/hsSyn/HsBinds.lhs | 17 +++++--- ghc/compiler/main/MkIface.lhs | 9 ++-- ghc/compiler/parser/binding.ugn | 3 ++ ghc/compiler/parser/hslexer.flex | 4 ++ ghc/compiler/parser/hsparser.y | 14 +++++- ghc/compiler/reader/ReadPrefix.lhs | 5 +++ ghc/compiler/rename/RnBinds.lhs | 8 ++++ ghc/compiler/typecheck/TcBinds.lhs | 3 ++ ghc/compiler/typecheck/TcClassDcl.lhs | 2 + 13 files changed, 122 insertions(+), 37 deletions(-) diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 9d3028c..1b68063 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 10720f0..7e1c8d5 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 db6a9da..2b7a7a1 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 d06fd93..5d1f2b2 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 d6246f1..f75117c 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 fd6d8c8..cd818c1 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 76b067c..74c8a92 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 432625a..a3abd5a 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); } +"{-#"{WS}*"NOINLINE" { + PUSH_STATE(UserPragma); + RETURN(NOINLINE_UPRAGMA); + } "{-#"{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 d302588..05441f9 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 ce285de..1dc750e 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 4f30204..eef7a3f 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 f711ef7..b5765ef 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 82c9212..e4dec94 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 -- 1.7.10.4