From: Ian Lynagh <igloo@earth.li>
Date: Mon, 18 Oct 2010 15:39:57 +0000 (+0000)
Subject: Fix -auto-all: Add SCCs to IDs which have a monotype too
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=6f37cf1b943abbf8a9f51bf80514cae86a2e6765

Fix -auto-all: Add SCCs to IDs which have a monotype too
---

diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 7e922fd..00e8652 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -100,21 +100,23 @@ dsHsBind _ (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardle
 
 	; return (unitOL (var', core_expr')) }
 
-dsHsBind _ (FunBind { fun_id = L _ fun, fun_matches = matches 
+dsHsBind auto_scc (FunBind { fun_id = L _ fun, fun_matches = matches
 		    , fun_co_fn = co_fn, fun_tick = tick 
                     , fun_infix = inf }) 
  = do	{ (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
 	; body'    <- mkOptTickBox tick body
 	; wrap_fn' <- dsHsWrapper co_fn 
-	; let rhs = wrap_fn' (mkLams args body')
+	; let rhs = addAutoScc auto_scc fun $ wrap_fn' (mkLams args body')
 	; return (unitOL (makeCorePair fun False 0 rhs)) }
 
-dsHsBind _ (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
+dsHsBind auto_scc (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
   = do	{ body_expr <- dsGuarded grhss ty
 	; sel_binds <- mkSelectorBinds pat body_expr
 	  -- We silently ignore inline pragmas; no makeCorePair
 	  -- Not so cool, but really doesn't matter
-	; return (toOL sel_binds) }
+    ; let sel_binds' = [ (v, addAutoScc auto_scc v expr)
+                       | (v, expr) <- sel_binds ]
+	; return (toOL sel_binds') }
 
 	-- A common case: one exported variable
 	-- Non-recursive bindings come through this way