[project @ 1997-06-05 21:07:37 by sof]

dsBinds is now responsible for auto-annotation of scc's;removed export of dsMonoBinds

diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index 901274d..abffcb1 100644 (file)
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -10,10 +10,14 @@ lower levels it is preserved with @let@/@letrec@s).
 \begin{code}
 #include "HsVersions.h"
 
-module DsBinds ( dsBinds, dsMonoBinds ) where
+module DsBinds ( dsBinds ) where
 
 IMP_Ubiq()
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
 IMPORT_DELOOPER(DsLoop)                -- break dsExpr-ish loop
+#else
+import {-# SOURCE #-} DsExpr
+#endif
 
 import HsSyn           -- lots of things
 import CoreSyn         -- lots of things
@@ -27,6 +31,7 @@ import DsGRHSs                ( dsGuarded )
 import DsUtils
 import Match           ( matchWrapper )
 
+import BasicTypes       ( SYN_IE(Module) )
 import CmdLineOpts     ( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs, 
                          opt_AutoSccsOnExportedToplevs, opt_CompilingGhcInternals )
 import CostCentre      ( mkAutoCC, IsCafCC(..), mkAllDictsCC, preludeDictsCostCentre )
@@ -53,13 +58,16 @@ that some of the binders are of unboxed type.  This is sorted out when
 the caller wraps the bindings round an expression.
 
 \begin{code}
-dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding]
+type Group = FAST_STRING
 
-dsBinds EmptyBinds                  = returnDs []
-dsBinds (ThenBinds  binds_1 binds_2) = andDs (++) (dsBinds binds_1) (dsBinds binds_2)
+dsBinds :: Maybe (Module, Group) -> TypecheckedHsBinds -> DsM [CoreBinding]
 
-dsBinds (MonoBind binds sigs is_rec)
-  = dsMonoBinds is_rec binds           `thenDs` \ prs ->
+dsBinds _ EmptyBinds                = returnDs []
+dsBinds mb_mod_grp (ThenBinds binds_1 binds_2) 
+  = andDs (++) (dsBinds mb_mod_grp binds_1) (dsBinds mb_mod_grp binds_2)
+
+dsBinds mb_mod_grp (MonoBind binds sigs is_rec)
+  = dsMonoBinds mb_mod_grp is_rec binds  `thenDs` \ prs ->
     returnDs (if is_rec then
                [Rec prs]
              else
@@ -75,17 +83,20 @@ dsBinds (MonoBind binds sigs is_rec)
 %************************************************************************
 
 \begin{code}
-dsMonoBinds :: RecFlag -> TypecheckedMonoBinds -> DsM [(Id,CoreExpr)]
+dsMonoBinds :: Maybe (Module, Group)   -- Nothing => don't (auto-)annotate scc on toplevs.
+           -> RecFlag 
+           -> TypecheckedMonoBinds 
+           -> DsM [(Id,CoreExpr)]
 
-dsMonoBinds is_rec EmptyMonoBinds = returnDs []
+dsMonoBinds _ is_rec EmptyMonoBinds = returnDs []
 
-dsMonoBinds is_rec (AndMonoBinds  binds_1 binds_2)
-  = andDs (++) (dsMonoBinds is_rec binds_1) (dsMonoBinds is_rec binds_2)
+dsMonoBinds mb_mod_grp is_rec (AndMonoBinds  binds_1 binds_2)
+  = andDs (++) (dsMonoBinds mb_mod_grp is_rec binds_1) (dsMonoBinds mb_mod_grp is_rec binds_2)
 
-dsMonoBinds is_rec (CoreMonoBind var core_expr)
+dsMonoBinds _ is_rec (CoreMonoBind var core_expr)
   = returnDs [(var, core_expr)]
 
-dsMonoBinds is_rec (VarMonoBind var expr)
+dsMonoBinds _ is_rec (VarMonoBind var expr)
   = dsExpr expr                        `thenDs` \ core_expr ->
 
        -- Dictionary bindings are always VarMonoBinds, so
@@ -94,36 +105,37 @@ dsMonoBinds is_rec (VarMonoBind var expr)
 
     returnDs [(var, core_expr')]
 
-dsMonoBinds is_rec (FunMonoBind fun _ matches locn)
+dsMonoBinds mb_mod_grp is_rec (FunMonoBind fun _ matches locn)
   = putSrcLocDs locn   $
     matchWrapper (FunMatch fun) matches error_string   `thenDs` \ (args, body) ->
-    returnDs [(fun, mkValLam args body)]
+    returnDs [addAutoScc mb_mod_grp (fun, mkValLam args body)]
   where
     error_string = "function " ++ showForErr fun
 
-dsMonoBinds is_rec (PatMonoBind pat grhss_and_binds locn)
+dsMonoBinds mb_mod_grp is_rec (PatMonoBind pat grhss_and_binds locn)
   = putSrcLocDs locn $
-    dsGuarded grhss_and_binds                  `thenDs` \ body_expr ->
+    dsGuarded grhss_and_binds          `thenDs` \ body_expr ->
     mkSelectorBinds pat body_expr
 
        -- Common special case: no type or dictionary abstraction
-dsMonoBinds is_rec (AbsBinds [] [] exports binds)
-  = dsMonoBinds is_rec binds                   `thenDs` \ prs ->
-    returnDs (prs ++ [(global, Var local) | (_, global, local) <- exports])
+dsMonoBinds mb_mod_grp is_rec (AbsBinds [] [] exports binds)
+  = dsMonoBinds Nothing is_rec binds                   `thenDs` \ prs ->
+    returnDs (prs ++ [ addAutoScc mb_mod_grp (global, Var local) | (_, global, local) <- exports])
 
        -- Another common case: one exported variable
        -- All non-recursive bindings come through this way
-dsMonoBinds is_rec (AbsBinds all_tyvars dicts [(tyvars, global, local)] binds)
+dsMonoBinds mb_mod_grp is_rec (AbsBinds all_tyvars dicts [(tyvars, global, local)] binds)
   = ASSERT( all (`elem` tyvars) all_tyvars )
-    dsMonoBinds is_rec binds                           `thenDs` \ core_prs ->
+    dsMonoBinds Nothing is_rec binds                   `thenDs` \ core_prs ->
     let 
        core_binds | is_rec    = [Rec core_prs]
                   | otherwise = [NonRec b e | (b,e) <- core_prs]
     in
-    returnDs [(global, mkLam tyvars dicts $ mkCoLetsAny core_binds (Var local))]
+    returnDs [addAutoScc mb_mod_grp (global, mkLam tyvars dicts $ 
+                                            mkCoLetsAny core_binds (Var local))]
 
-dsMonoBinds is_rec (AbsBinds all_tyvars dicts exports binds)
-  = dsMonoBinds is_rec binds                           `thenDs` \ core_prs ->
+dsMonoBinds mb_mod_grp is_rec (AbsBinds all_tyvars dicts exports binds)
+  = dsMonoBinds Nothing is_rec binds                   `thenDs` \ core_prs ->
     let 
        core_binds | is_rec    = [Rec core_prs]
                   | otherwise = [NonRec b e | (b,e) <- core_prs]
@@ -142,9 +154,10 @@ dsMonoBinds is_rec (AbsBinds all_tyvars dicts exports binds)
          =     -- Need to make fresh locals to bind in the selector, because
                -- some of the tyvars will be bound to voidTy
            newSysLocalsDs (map (instantiateTy env) local_tys)  `thenDs` \ locals' ->
-           returnDs (global, mkLam tyvars dicts $
-                             mkTupleSelector locals' (locals' !! n) $
-                             mkValApp (mkTyApp (Var tup_id) ty_args) dict_args)
+           returnDs (addAutoScc mb_mod_grp $
+                       (global, mkLam tyvars dicts $
+                                mkTupleSelector locals' (locals' !! n) $
+                                mkValApp (mkTyApp (Var tup_id) ty_args) dict_args))
          where
            mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
                                | otherwise               = voidTy
@@ -152,9 +165,36 @@ dsMonoBinds is_rec (AbsBinds all_tyvars dicts exports binds)
            env     = all_tyvars `zip` ty_args
     in
     zipWithDs mk_bind exports [0..]            `thenDs` \ export_binds ->
+     -- don't scc (auto-)annotate the tuple itself.
     returnDs ((tup_id, tup_expr) : export_binds)
 \end{code}
 
+
+%************************************************************************
+%*                                                                     *
+\subsection[addAutoScc]{Adding automatic sccs}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+addAutoScc :: Maybe (Module, Group)    -- Module and group
+          -> (Id, CoreExpr)
+          -> (Id, CoreExpr)
+
+addAutoScc mb_mod_grp pair@(bndr, core_expr) 
+  = case mb_mod_grp of
+      Just (mod,grp) 
+       | worthSCC core_expr &&
+         (opt_AutoSccsOnAllToplevs ||
+          (isExported bndr && opt_AutoSccsOnExportedToplevs))
+        -> (bndr, SCC (mkAutoCC bndr mod grp IsNotCafCC) core_expr)
+      _ -> pair -- no auto-annotation.
+
+worthSCC (SCC _ _) = False
+worthSCC (Con _ _) = False
+worthSCC core_expr = True
+\end{code}
+
 If profiling and dealing with a dict binding, wrap the dict in "_scc_ DICT <dict>":
 
 \begin{code}