X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsBinds.lhs;h=cc9c36393fdda50d10a1f543d113bbf6b01cb5f6;hb=8bbf522b424fae8c0189a8dd301344ab4216cb17;hp=2131f60c273806ed2636cb508a448f41d1384471;hpb=acaa2124a9427aec9ccc96e0c8b6e067a85916e0;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index 2131f60..cc9c363 100644
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -17,29 +17,23 @@ import {-# SOURCE #-}	DsExpr( dsExpr )
 
 import HsSyn		-- lots of things
 import CoreSyn		-- lots of things
-import CoreUtils	( coreExprType )
+import CoreUtils	( exprType, mkInlineMe, mkSCC )
 import TcHsSyn		( TypecheckedMonoBinds )
 import DsMonad
 import DsGRHSs		( dsGuarded )
 import DsUtils
 import Match		( matchWrapper )
 
-import BasicTypes       ( RecFlag(..) )
-import CmdLineOpts	( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs, 
-			  opt_AutoSccsOnExportedToplevs, opt_AutoSccsOnDicts
-		        )
-import CostCentre	( CostCentre, mkAutoCC, IsCafCC(..) )
-import Id		( idType, idName, isUserExportedId, isSpecPragmaId, Id )
+import CmdLineOpts	( opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs )
+import CostCentre	( mkAutoCC, IsCafCC(..) )
+import Id		( idType, idName, isExportedId, isSpecPragmaId, Id )
 import NameSet
-import VarEnv
 import VarSet
-import Type		( mkTyVarTy, isDictTy )
+import Type		( mkTyVarTy )
 import Subst		( mkTyVarSubst, substTy )
 import TysWiredIn	( voidTy )
 import Outputable
-
-import Maybe
-import IOExts (trace)
+import Maybe		( isJust )
 \end{code}
 
 %************************************************************************
@@ -84,8 +78,8 @@ dsMonoBinds _ (VarMonoBind var expr) rest
 
 dsMonoBinds auto_scc (FunMonoBind fun _ matches locn) rest
   = putSrcLocDs locn	$
-    matchWrapper (FunMatch fun) matches error_string	`thenDs` \ (args, body) ->
-    addAutoScc auto_scc (fun, mkLams args body)		`thenDs` \ pair ->
+    matchWrapper (FunRhs (idName fun)) matches error_string	`thenDs` \ (args, body) ->
+    addAutoScc auto_scc (fun, mkLams args body)			`thenDs` \ pair ->
     returnDs (pair : rest)
   where
     error_string = "function " ++ showSDoc (ppr fun)
@@ -97,8 +91,16 @@ dsMonoBinds auto_scc (PatMonoBind pat grhss locn) rest
     mapDs (addAutoScc auto_scc) sel_binds	`thenDs` \ sel_binds ->
     returnDs (sel_binds ++ rest)
 
-	-- Common case: one exported variable
-	-- All non-recursive bindings come through this way
+	-- Common special case: no type or dictionary abstraction
+dsMonoBinds auto_scc (AbsBinds [] [] exports inlines binds) rest
+  = dsMonoBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
+    let 
+	exports' = [(global, Var local) | (_, global, local) <- exports]
+    in
+    returnDs (addLocalInlines exports inlines core_prs ++ exports' ++ rest)
+
+	-- Another common case: one exported variable
+	-- Non-recursive bindings come through this way
 dsMonoBinds auto_scc
      (AbsBinds all_tyvars dicts exps@[(tyvars, global, local)] inlines binds) rest
   = ASSERT( all (`elem` tyvars) all_tyvars )
@@ -113,27 +115,19 @@ dsMonoBinds auto_scc
     in
     returnDs (global' : rest)
 
-	-- Another common special case: no type or dictionary abstraction
-dsMonoBinds auto_scc (AbsBinds [] [] exports inlines binds) rest
-  = dsMonoBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
-    let 
-	exports' = [(global, Var local) | (_, global, local) <- exports]
-    in
-    returnDs (addLocalInlines exports inlines core_prs ++ exports' ++ rest)
-
 dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exports inlines binds) rest
   = dsMonoBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
     let 
 	core_binds = [Rec (addLocalInlines exports inlines core_prs)]
 
 	tup_expr      = mkTupleExpr locals
-	tup_ty	      = coreExprType tup_expr
+	tup_ty	      = exprType tup_expr
 	poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
 		        mkDsLets core_binds tup_expr
 	locals        = [local | (_, _, local) <- exports]
 	local_tys     = map idType locals
     in
-    newSysLocalDs (coreExprType poly_tup_expr)		`thenDs` \ poly_tup_id ->
+    newSysLocalDs (exprType poly_tup_expr)		`thenDs` \ poly_tup_id ->
     let
 	dict_args = map Var dicts
 
@@ -165,7 +159,7 @@ dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exports inlines binds) rest
 
 \begin{code}
 mkInline :: Bool -> CoreExpr -> CoreExpr
-mkInline True  body = Note InlineMe body
+mkInline True  body = mkInlineMe body
 mkInline False body = body
 
 addLocalInlines :: [(a, Id, Id)] -> NameSet -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
@@ -194,7 +188,7 @@ addSccs NoSccs   exports = NoSccs
 addSccs TopLevel exports 
   = TopLevelAddSccs (\id -> case [ exp | (_,exp,loc) <- exports, loc == id ] of
 				(exp:_)  | opt_AutoSccsOnAllToplevs || 
-					    (isUserExportedId exp && 
+					    (isExportedId exp && 
 					     opt_AutoSccsOnExportedToplevs)
 					-> Just exp
 				_ -> Nothing)
@@ -204,18 +198,15 @@ addAutoScc :: AutoScc		-- if needs be, decorate toplevs?
 	   -> DsM (Id, CoreExpr)
 
 addAutoScc (TopLevelAddSccs auto_scc_fn) pair@(bndr, core_expr) 
- | do_auto_scc && worthSCC core_expr
-     = getModuleAndGroupDs `thenDs` \ (mod,grp) ->
-       returnDs (bndr, Note (SCC (mkAutoCC top_bndr mod grp NotCafCC)) core_expr)
+ | do_auto_scc
+     = getModuleDs `thenDs` \ mod ->
+       returnDs (bndr, mkSCC (mkAutoCC top_bndr mod NotCafCC) core_expr)
  where do_auto_scc = isJust maybe_auto_scc
        maybe_auto_scc = auto_scc_fn bndr
        (Just top_bndr) = maybe_auto_scc
+
 addAutoScc _ pair
      = returnDs pair
-
-worthSCC (Note (SCC _) _) = False
-worthSCC (Con _ _)        = False
-worthSCC core_expr        = True
 \end{code}
 
 If profiling and dealing with a dict binding,