X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fspecialise%2FSpecialise.lhs;h=095b7e2b4381fa932f4dd3b834dec1b5066b6909;hb=f23ba2b294429ccbdeb80f0344ec08f6abf61bb7;hp=d73e2c3f412c8dc657135a6b5b6b2c8d169d665d;hpb=ff755dd9a0a0ad2f106c323852553ea247f16141;p=ghc-hetmet.git

diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index d73e2c3..095b7e2 100644
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -8,44 +8,42 @@ module Specialise ( specProgram ) where
 
 #include "HsVersions.h"
 
-import CmdLineOpts	( opt_D_verbose_core2core, opt_D_dump_spec, opt_D_dump_rules )
-import Id		( Id, idName, idType, mkTemplateLocals, mkUserLocal,
-			  idSpecialisation, setIdNoDiscard, isExportedId,
-			  modifyIdInfo, idUnfolding
+import CmdLineOpts	( DynFlags, DynFlag(..), dopt )
+import Id		( Id, idName, idType, mkUserLocal,
+			  idSpecialisation, modifyIdInfo
 			)
 import IdInfo		( zapSpecPragInfo )
 import VarSet
 import VarEnv
 
-import Type		( Type, mkTyVarTy, splitSigmaTy, splitFunTysN,
-			  tyVarsOfType, tyVarsOfTypes, tyVarsOfTheta, applyTys,
-			  mkForAllTys, boxedTypeKind
+import Type		( Type, mkTyVarTy, splitSigmaTy, 
+			  tyVarsOfTypes, tyVarsOfTheta, 
+			  mkForAllTys 
 			)
-import Subst		( Subst, mkSubst, substTy, mkSubst, substBndrs, extendSubstList,
+import Subst		( Subst, mkSubst, substTy, mkSubst, substBndrs, extendSubstList, mkInScopeSet,
 			  substId, substAndCloneId, substAndCloneIds, lookupIdSubst, substInScope
 			) 
-import Var		( TyVar, mkSysTyVar, setVarUnique )
 import VarSet
 import VarEnv
 import CoreSyn
 import CoreUtils	( applyTypeToArgs )
 import CoreUnfold	( certainlyWillInline )
 import CoreFVs		( exprFreeVars, exprsFreeVars )
-import CoreLint		( beginPass, endPass )
+import CoreLint		( showPass, endPass )
 import PprCore		( pprCoreRules )
 import Rules		( addIdSpecialisations, lookupRule )
 
 import UniqSupply	( UniqSupply,
 			  UniqSM, initUs_, thenUs, thenUs_, returnUs, getUniqueUs, 
-			  getUs, setUs, uniqFromSupply, splitUniqSupply, mapUs
+			  getUs, setUs, mapUs
 			)
 import Name		( nameOccName, mkSpecOcc, getSrcLoc )
 import FiniteMap
-import Maybes		( MaybeErr(..), catMaybes, maybeToBool )
-import ErrUtils		( dumpIfSet )
+import Maybes		( catMaybes, maybeToBool )
+import ErrUtils		( dumpIfSet_dyn )
 import Bag
 import List		( partition )
-import Util		( zipEqual, zipWithEqual, mapAccumL )
+import Util		( zipEqual, zipWithEqual )
 import Outputable
 
 
@@ -579,17 +577,19 @@ Hence, the invariant is this:
 %************************************************************************
 
 \begin{code}
-specProgram :: UniqSupply -> [CoreBind] -> IO [CoreBind]
-specProgram us binds
+specProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
+specProgram dflags us binds
   = do
-	beginPass "Specialise"
+	showPass dflags "Specialise"
 
 	let binds' = initSM us (go binds 	`thenSM` \ (binds', uds') ->
 			        returnSM (dumpAllDictBinds uds' binds'))
 
-	endPass "Specialise" (opt_D_dump_spec || opt_D_verbose_core2core) binds'
+	endPass dflags "Specialise" 
+                       (dopt Opt_D_dump_spec dflags 
+                          || dopt Opt_D_verbose_core2core dflags) binds'
 
-	dumpIfSet opt_D_dump_rules "Top-level specialisations"
+	dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
 		  (vcat (map dump_specs (concat (map bindersOf binds'))))
 
 	return binds'
@@ -599,7 +599,7 @@ specProgram us binds
 	-- accidentally re-use a unique that's already in use
 	-- Easiest thing is to do it all at once, as if all the top-level
 	-- decls were mutually recursive
-    top_subst	    = mkSubst (mkVarSet (bindersOfBinds binds)) emptySubstEnv
+    top_subst	    = mkSubst (mkInScopeSet (mkVarSet (bindersOfBinds binds))) emptySubstEnv
 
     go []	    = returnSM ([], emptyUDs)
     go (bind:binds) = go binds 				`thenSM` \ (binds', uds) ->
@@ -820,10 +820,10 @@ specDefn subst calls (fn, rhs)
 	-- It's role as a holder for a call instance is o'er
 	-- But it might be alive for some other reason by now.
 
-    fn_type		 = idType fn
-    (tyvars, theta, tau) = splitSigmaTy fn_type
-    n_tyvars		 = length tyvars
-    n_dicts		 = length theta
+    fn_type	       = idType fn
+    (tyvars, theta, _) = splitSigmaTy fn_type
+    n_tyvars	       = length tyvars
+    n_dicts	       = length theta
 
     (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs
     rhs_dicts = take n_dicts rhs_ids
@@ -985,10 +985,10 @@ mkCallUDs subst f args
 	  calls      = singleCall f spec_tys dicts
     }
   where
-    (tyvars, theta, tau) = splitSigmaTy (idType f)
-    constrained_tyvars   = tyVarsOfTheta theta 
-    n_tyvars		 = length tyvars
-    n_dicts		 = length theta
+    (tyvars, theta, _) = splitSigmaTy (idType f)
+    constrained_tyvars = tyVarsOfTheta theta 
+    n_tyvars	       = length tyvars
+    n_dicts	       = length theta
 
     spec_tys = [mk_spec_ty tv ty | (tv, Type ty) <- tyvars `zip` args]
     dicts    = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)]
@@ -1095,11 +1095,8 @@ lookupId env id = case lookupVarEnv env id of
 type SpecM a = UniqSM a
 
 thenSM    = thenUs
-thenSM_    = thenUs_
 returnSM  = returnUs
 getUniqSM = getUniqueUs
-getUniqSupplySM = getUs
-setUniqSupplySM = setUs
 mapSM     = mapUs
 initSM	  = initUs_
 
@@ -1140,19 +1137,12 @@ newIdSM old_id new_ty
   = getUniqSM		`thenSM` \ uniq ->
     let 
 	-- Give the new Id a similar occurrence name to the old one
+	-- We used to add setIdNoDiscard if the old id was exported, to
+	-- avoid it being dropped as dead code, but that's not necessary any more.
 	name   = idName old_id
 	new_id = mkUserLocal (mkSpecOcc (nameOccName name)) uniq new_ty (getSrcLoc name)
-
-	-- If the old Id was exported, make the new one non-discardable,
-	-- else we will discard it since it doesn't seem to be called.
-	new_id' | isExportedId old_id = setIdNoDiscard new_id
-		| otherwise	      = new_id
     in
-    returnSM new_id'
-
-newTyVarSM
-  = getUniqSM		`thenSM` \ uniq ->
-    returnSM (mkSysTyVar uniq boxedTypeKind)
+    returnSM new_id
 \end{code}