X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDesugar.lhs;h=8fcaf9b93ac874e45606697bdd010e95a0d60777;hb=49c98d143c382a1341e1046f5ca00819a25691ba;hp=c2ee0a5a11ca3ff8fbcf288b580b970ff6167fec;hpb=3932b76369acda843a6c998449bf953a7cb2f5fc;p=ghc-hetmet.git

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index c2ee0a5..8fcaf9b 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -1,48 +1,49 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-\section[Desugar]{@deSugar@: the main function}
+
+The Desugarer: turning HsSyn into Core.
 
 \begin{code}
 module Desugar ( deSugar, deSugarExpr ) where
 
 #include "HsVersions.h"
 
-import DynFlags		( DynFlag(..), DynFlags(..), dopt, GhcMode(..) )
-import StaticFlags	( opt_SccProfilingOn )
-import DriverPhases	( isHsBoot )
-import HscTypes		( ModGuts(..), HscEnv(..), 
-			  Dependencies(..), ForeignStubs(..), TypeEnv, IsBootInterface )
-import HsSyn		( RuleDecl(..), RuleBndr(..), LHsExpr, LRuleDecl )
-import TcRnTypes	( TcGblEnv(..), ImportAvails(..) )
-import MkIface		( mkUsageInfo )
-import Id		( Id, setIdExported, idName )
-import Name		( Name, isExternalName, nameIsLocalOrFrom, nameOccName )
+import DynFlags
+import StaticFlags
+import HscTypes
+import HsSyn
+import TcRnTypes
+import MkIface
+import Id
+import Name
 import CoreSyn
-import PprCore		( pprRules, pprCoreExpr )
+import PprCore
 import DsMonad
-import DsExpr		( dsLExpr )
-import DsBinds		( dsTopLHsBinds, decomposeRuleLhs, AutoScc(..) )
-import DsForeign	( dsForeigns )
+import DsExpr
+import DsBinds
+import DsForeign
 import DsExpr		()	-- Forces DsExpr to be compiled; DsBinds only
 				-- depends on DsExpr.hi-boot.
 import Module
-import UniqFM		( eltsUFM, delFromUFM )
-import PackageConfig	( thPackageId )
-import RdrName	 	( GlobalRdrEnv )
+import UniqFM
+import PackageConfig
+import RdrName
 import NameSet
 import VarSet
-import Rules		( roughTopNames )
-import CoreLint		( showPass, endPass )
-import CoreFVs		( ruleRhsFreeVars, exprsFreeNames )
-import ErrUtils		( doIfSet, dumpIfSet_dyn )
-import ListSetOps	( insertList )
+import Rules
+import CoreLint
+import CoreFVs
+import ErrUtils
+import ListSetOps
 import Outputable
-import SrcLoc		( Located(..) )
-import DATA_IOREF	( readIORef )
-import Maybes		( catMaybes )
+import SrcLoc
+import Maybes
 import FastString
-import Util		( sortLe )
+import Util
+
+import Data.IORef
 \end{code}
 
 %************************************************************************
@@ -71,10 +72,14 @@ deSugar hsc_env
 			    tcg_binds     = binds,
 			    tcg_fords     = fords,
 			    tcg_rules     = rules,
-		    	    tcg_insts     = insts })
+		    	    tcg_insts     = insts,
+		    	    tcg_fam_insts = fam_insts })
   = do	{ showPass dflags "Desugar"
 
 	-- Desugar the program
+        ; let export_set = availsToNameSet exports
+	; let auto_scc = mkAutoScc mod export_set
+
 	; mb_res <- case ghcMode dflags of
 	             JustTypecheck -> return (Just ([], [], NoStubs))
 	             _             -> initDs hsc_env mod rdr_env type_env $ do
@@ -91,8 +96,8 @@ deSugar hsc_env
 
 	{ 	-- Add export flags to bindings
 	  keep_alive <- readIORef keep_var
-	; let final_prs = addExportFlags ghci_mode exports keep_alive 
-				   	 all_prs ds_rules
+	; let final_prs = addExportFlags ghci_mode export_set
+                                 keep_alive all_prs ds_rules
 	      ds_binds  = [Rec final_prs]
 	-- Notice that we put the whole lot in a big Rec, even the foreign binds
 	-- When compiling PrelFloat, which defines data Float = F# Float#
@@ -140,20 +145,21 @@ deSugar hsc_env
 		-- sort to get into canonical order
 
 	     mod_guts = ModGuts {	
-		mg_module   = mod,
-		mg_boot	    = isHsBoot hsc_src,
-		mg_exports  = exports,
-		mg_deps	    = deps,
-		mg_usages   = usages,
-		mg_dir_imps = [m | (m,_,_) <- moduleEnvElts dir_imp_mods],
-	        mg_rdr_env  = rdr_env,
-		mg_fix_env  = fix_env,
-		mg_deprecs  = deprecs,
-		mg_types    = type_env,
-		mg_insts    = insts,
-	        mg_rules    = ds_rules,
-		mg_binds    = ds_binds,
-		mg_foreign  = ds_fords }
+		mg_module    = mod,
+		mg_boot	     = isHsBoot hsc_src,
+		mg_exports   = exports,
+		mg_deps	     = deps,
+		mg_usages    = usages,
+		mg_dir_imps  = [m | (m,_,_) <- moduleEnvElts dir_imp_mods],
+	        mg_rdr_env   = rdr_env,
+		mg_fix_env   = fix_env,
+		mg_deprecs   = deprecs,
+		mg_types     = type_env,
+		mg_insts     = insts,
+		mg_fam_insts = fam_insts,
+	        mg_rules     = ds_rules,
+		mg_binds     = ds_binds,
+		mg_foreign   = ds_fords }
 	
         ; return (Just mod_guts)
 	}}}
@@ -161,8 +167,18 @@ deSugar hsc_env
   where
     dflags    = hsc_dflags hsc_env
     ghci_mode = ghcMode (hsc_dflags hsc_env)
-    auto_scc | opt_SccProfilingOn = TopLevel
-	     | otherwise          = NoSccs
+
+mkAutoScc :: Module -> NameSet -> AutoScc
+mkAutoScc mod exports
+  | not opt_SccProfilingOn 	-- No profiling
+  = NoSccs		
+  | opt_AutoSccsOnAllToplevs 	-- Add auto-scc on all top-level things
+  = AddSccs mod (\id -> True)
+  | opt_AutoSccsOnExportedToplevs	-- Only on exported things
+  = AddSccs mod (\id -> idName id `elemNameSet` exports)
+  | otherwise
+  = NoSccs
+
 
 deSugarExpr :: HscEnv
 	    -> Module -> GlobalRdrEnv -> TypeEnv