[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.

diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 9d3028c..1b68063 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 d302588..05441f9 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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