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

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

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}