X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FsimplCore%2FSimplMonad.lhs;h=70112edfea930e64288c4f959c02f9ff705ef958;hb=f5c94708c39c7b64c0d52057408332ed837834e6;hp=fac41a788bf8ef0c06e4e958c94566a5363192ce;hpb=68991fc012af8fdc258281453758de76f9a63fe4;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs
index fac41a7..70112ed 100644
--- a/ghc/compiler/simplCore/SimplMonad.lhs
+++ b/ghc/compiler/simplCore/SimplMonad.lhs
@@ -7,18 +7,19 @@
 module SimplMonad (
 	InId, InBind, InExpr, InAlt, InArg, InType, InBinder,
 	OutId, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder,
-	OutExprStuff, OutStuff,
+	OutExprStuff, OutStuff, returnOutStuff,
 
 	-- The monad
 	SimplM,
 	initSmpl, returnSmpl, thenSmpl, thenSmpl_,
 	mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,
+	getDOptsSmpl,
 
 	-- The inlining black-list
 	setBlackList, getBlackList, noInlineBlackList,
 
         -- Unique supply
-        getUniqueSmpl, getUniquesSmpl,
+        getUniqueSmpl, getUniquesSmpl, getUniqSupplySmpl,
 	newId, newIds,
 
 	-- Counting
@@ -39,31 +40,39 @@ module SimplMonad (
 	getSubstEnv, extendSubst, extendSubstList,
 	getInScope, setInScope, modifyInScope, addNewInScopeIds,
 	setSubstEnv, zapSubstEnv,
-	getSimplBinderStuff, setSimplBinderStuff
+	getSimplBinderStuff, setSimplBinderStuff,
+
+	-- Adding bindings
+	addLetBind, addLetBinds, addAuxiliaryBind, addAuxiliaryBinds,
+	addCaseBind, needsCaseBinding, addNonRecBind, wrapFloats, addFloats
     ) where
 
 #include "HsVersions.h"
 
-import Id		( Id, mkSysLocal, idUnfolding, isDataConWrapId )
+import Id		( Id, mkSysLocal, idType, idUnfolding, isDataConWrapId,
+			  isGlobalId )
 import CoreSyn
 import CoreUnfold	( isCompulsoryUnfolding )
+import CoreUtils	( exprOkForSpeculation )
 import PprCore		()	-- Instances
 import CostCentre	( CostCentreStack, subsumedCCS )
-import Name		( isLocallyDefined )
 import OccName		( UserFS )
 import VarEnv
 import VarSet
+import OrdList
 import qualified Subst
 import Subst		( Subst, mkSubst, substEnv, 
-			  InScopeSet, mkInScopeSet, substInScope, isInScope
+			  InScopeSet, mkInScopeSet, substInScope,
+			  isInScope 
 			)
-import Type             ( Type )
+import Type             ( Type, isUnLiftedType )
 import UniqSupply	( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
 			  UniqSupply
 			)
 import FiniteMap
 import CmdLineOpts	( SimplifierSwitch(..), SwitchResult(..),
-			  opt_PprStyle_Debug, opt_HistorySize, opt_D_dump_simpl_stats,
+			  DynFlags, DynFlag(..), dopt,
+			  opt_PprStyle_Debug, opt_HistorySize,
 			  intSwitchSet
 			)
 import Unique		( Unique )
@@ -99,13 +108,63 @@ type OutArg	= CoreArg
 
 type SwitchChecker = SimplifierSwitch -> SwitchResult
 
-type OutExprStuff = OutStuff (InScopeSet, OutExpr)
-type OutStuff a   = ([OutBind], a)
+type OutExprStuff = OutStuff OutExpr
+type OutStuff a   = (OrdList OutBind, (InScopeSet, a))
 	-- We return something equivalent to (let b in e), but
 	-- in pieces to avoid the quadratic blowup when floating 
 	-- incrementally.  Comments just before simplExprB in Simplify.lhs
 \end{code}
 
+\begin{code}
+wrapFloats :: OrdList CoreBind -> CoreExpr -> CoreExpr
+wrapFloats binds body = foldOL Let body binds
+
+returnOutStuff :: a -> SimplM (OutStuff a)
+returnOutStuff x = getInScope 	`thenSmpl` \ in_scope ->
+		   returnSmpl (nilOL, (in_scope, x))
+
+addFloats :: OrdList CoreBind -> InScopeSet -> SimplM (OutStuff a) -> SimplM (OutStuff a)
+addFloats floats in_scope thing_inside
+  = setInScope in_scope thing_inside	`thenSmpl` \ (binds, res) ->
+    returnSmpl (floats `appOL` binds, res)
+ 
+addLetBind :: CoreBind -> SimplM (OutStuff a) -> SimplM (OutStuff a)
+addLetBind bind thing_inside
+  = thing_inside	`thenSmpl` \ (binds, res) ->
+    returnSmpl (bind `consOL` binds, res)
+
+addLetBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
+addLetBinds binds1 thing_inside
+  = thing_inside	`thenSmpl` \ (binds2, res) ->
+    returnSmpl (toOL binds1 `appOL` binds2, res)
+
+addAuxiliaryBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
+	-- Extends the in-scope environment as well as wrapping the bindings
+addAuxiliaryBinds binds1 thing_inside
+  = addNewInScopeIds (bindersOfBinds binds1)	$
+    addLetBinds binds1 thing_inside
+
+addAuxiliaryBind :: CoreBind -> SimplM (OutStuff a) -> SimplM (OutStuff a)
+	-- Extends the in-scope environment as well as wrapping the bindings
+addAuxiliaryBind bind thing_inside
+  = addNewInScopeIds (bindersOf bind)	$
+    addLetBind bind thing_inside
+
+needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
+	-- Make a case expression instead of a let
+	-- These can arise either from the desugarer,
+	-- or from beta reductions: (\x.e) (x +# y)
+
+addCaseBind bndr rhs thing_inside
+  = thing_inside		`thenSmpl` \ (floats, (_, body)) ->
+    returnOutStuff (Case rhs bndr [(DEFAULT, [], wrapFloats floats body)])
+
+addNonRecBind bndr rhs thing_inside
+	-- Checks for needing a case binding
+  | needsCaseBinding (idType bndr) rhs = addCaseBind bndr rhs thing_inside
+  | otherwise		     	       = addLetBind  (NonRec bndr rhs) thing_inside
+\end{code}
+
 
 %************************************************************************
 %*									*
@@ -117,9 +176,10 @@ For the simplifier monad, we want to {\em thread} a unique supply and a counter.
 (Command-line switches move around through the explicitly-passed SimplEnv.)
 
 \begin{code}
-type SimplM result		-- We thread the unique supply because
-  =  SimplEnv			-- constantly splitting it is rather expensive
-  -> UniqSupply
+type SimplM result
+  =  DynFlags
+  -> SimplEnv		-- We thread the unique supply because
+  -> UniqSupply		-- constantly splitting it is rather expensive
   -> SimplCount 
   -> (result, UniqSupply, SimplCount)
 
@@ -151,15 +211,17 @@ data SimplEnv
 \end{code}
 
 \begin{code}
-initSmpl :: SwitchChecker
+initSmpl :: DynFlags
+	 -> SwitchChecker
 	 -> UniqSupply		-- No init count; set to 0
 	 -> VarSet		-- In scope (usually empty, but useful for nested calls)
 	 -> BlackList		-- Black-list function
 	 -> SimplM a
 	 -> (a, SimplCount)
 
-initSmpl chkr us in_scope black_list m
-  = case m (emptySimplEnv chkr in_scope black_list) us zeroSimplCount of 
+initSmpl dflags chkr us in_scope black_list m
+  = case m dflags (emptySimplEnv chkr in_scope black_list) us 
+	   (zeroSimplCount dflags) of 
 	(result, _, count) -> (result, count)
 
 
@@ -168,18 +230,18 @@ initSmpl chkr us in_scope black_list m
 {-# INLINE returnSmpl #-}
 
 returnSmpl :: a -> SimplM a
-returnSmpl e env us sc = (e, us, sc)
+returnSmpl e dflags env us sc = (e, us, sc)
 
 thenSmpl  :: SimplM a -> (a -> SimplM b) -> SimplM b
 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
 
-thenSmpl m k env us0 sc0
-  = case (m env us0 sc0) of 
-	(m_result, us1, sc1) -> k m_result env us1 sc1
+thenSmpl m k dflags env us0 sc0
+  = case (m dflags env us0 sc0) of 
+	(m_result, us1, sc1) -> k m_result dflags env us1 sc1
 
-thenSmpl_ m k env us0 sc0
-  = case (m env us0 sc0) of 
-	(_, us1, sc1) -> k env us1 sc1
+thenSmpl_ m k dflags env us0 sc0
+  = case (m dflags env us0 sc0) of 
+	(_, us1, sc1) -> k dflags env us1 sc1
 \end{code}
 
 
@@ -213,13 +275,24 @@ mapAccumLSmpl f acc (x:xs) = f acc x	`thenSmpl` \ (acc', x') ->
 %************************************************************************
 
 \begin{code}
-getUniqueSmpl :: SimplM Unique
-getUniqueSmpl env us sc = case splitUniqSupply us of
-				(us1, us2) -> (uniqFromSupply us1, us2, sc)
+getUniqSupplySmpl :: SimplM UniqSupply
+getUniqSupplySmpl dflags env us sc 
+   = case splitUniqSupply us of
+        (us1, us2) -> (us1, us2, sc)
 
-getUniquesSmpl :: Int -> SimplM [Unique]
-getUniquesSmpl n env us sc = case splitUniqSupply us of
-				(us1, us2) -> (uniqsFromSupply n us1, us2, sc)
+getUniqueSmpl :: SimplM Unique
+getUniqueSmpl dflags env us sc 
+   = case splitUniqSupply us of
+        (us1, us2) -> (uniqFromSupply us1, us2, sc)
+
+getUniquesSmpl :: SimplM [Unique]
+getUniquesSmpl dflags env us sc 
+   = case splitUniqSupply us of
+        (us1, us2) -> (uniqsFromSupply us1, us2, sc)
+
+getDOptsSmpl :: SimplM DynFlags
+getDOptsSmpl dflags env us sc 
+   = (dflags, us, sc)
 \end{code}
 
 
@@ -231,25 +304,27 @@ getUniquesSmpl n env us sc = case splitUniqSupply us of
 
 \begin{code}
 getSimplCount :: SimplM SimplCount
-getSimplCount env us sc = (sc, us, sc)
+getSimplCount dflags env us sc = (sc, us, sc)
 
 tick :: Tick -> SimplM ()
-tick t env us sc = sc' `seq` ((), us, sc')
-		 where
-		   sc' = doTick t sc
+tick t dflags env us sc 
+   = sc' `seq` ((), us, sc')
+     where
+        sc' = doTick t sc
 
 freeTick :: Tick -> SimplM ()
 -- Record a tick, but don't add to the total tick count, which is
 -- used to decide when nothing further has happened
-freeTick t env us sc = sc' `seq` ((), us, sc')
-		 where
-		   sc' = doFreeTick t sc
+freeTick t dflags env us sc 
+   = sc' `seq` ((), us, sc')
+        where
+           sc' = doFreeTick t sc
 \end{code}
 
 \begin{code}
 verboseSimplStats = opt_PprStyle_Debug		-- For now, anyway
 
-zeroSimplCount	   :: SimplCount
+zeroSimplCount	   :: DynFlags -> SimplCount
 isZeroSimplCount   :: SimplCount -> Bool
 pprSimplCount	   :: SimplCount -> SDoc
 doTick, doFreeTick :: Tick -> SimplCount -> SimplCount
@@ -271,11 +346,14 @@ data SimplCount = VerySimplZero		-- These two are used when
 
 type TickCounts = FiniteMap Tick Int
 
-zeroSimplCount	-- This is where we decide whether to do
+zeroSimplCount dflags
+		-- This is where we decide whether to do
 		-- the VerySimpl version or the full-stats version
-  | opt_D_dump_simpl_stats = SimplCount {ticks = 0, details = emptyFM,
-			   		 n_log = 0, log1 = [], log2 = []}
-  | otherwise		   = VerySimplZero
+  | dopt Opt_D_dump_simpl_stats dflags
+  = SimplCount {ticks = 0, details = emptyFM,
+                n_log = 0, log1 = [], log2 = []}
+  | otherwise
+  = VerySimplZero
 
 isZeroSimplCount VerySimplZero    	    = True
 isZeroSimplCount (SimplCount { ticks = 0 }) = True
@@ -370,7 +448,7 @@ data Tick
   | UnfoldingDone    		Id
   | RuleFired			FAST_STRING	-- Rule name
 
-  | LetFloatFromLet		Id	-- Thing floated out
+  | LetFloatFromLet
   | EtaExpansion		Id	-- LHS binder
   | EtaReduction		Id	-- Binder on outer lambda
   | BetaReduction		Id	-- Lambda binder
@@ -403,7 +481,7 @@ tickToTag (PreInlineUnconditionally _)	= 0
 tickToTag (PostInlineUnconditionally _)	= 1
 tickToTag (UnfoldingDone _)		= 2
 tickToTag (RuleFired _)			= 3
-tickToTag (LetFloatFromLet _)		= 4
+tickToTag LetFloatFromLet		= 4
 tickToTag (EtaExpansion _)		= 5
 tickToTag (EtaReduction _)		= 6
 tickToTag (BetaReduction _)		= 7
@@ -421,7 +499,7 @@ tickString (PreInlineUnconditionally _)	= "PreInlineUnconditionally"
 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
 tickString (UnfoldingDone _)		= "UnfoldingDone"
 tickString (RuleFired _)		= "RuleFired"
-tickString (LetFloatFromLet _)		= "LetFloatFromLet"
+tickString LetFloatFromLet		= "LetFloatFromLet"
 tickString (EtaExpansion _)		= "EtaExpansion"
 tickString (EtaReduction _)		= "EtaReduction"
 tickString (BetaReduction _)		= "BetaReduction"
@@ -439,7 +517,7 @@ pprTickCts (PreInlineUnconditionally v)	= ppr v
 pprTickCts (PostInlineUnconditionally v)= ppr v
 pprTickCts (UnfoldingDone v)		= ppr v
 pprTickCts (RuleFired v)		= ppr v
-pprTickCts (LetFloatFromLet v)		= ppr v
+pprTickCts LetFloatFromLet		= empty
 pprTickCts (EtaExpansion v)		= ppr v
 pprTickCts (EtaReduction v)		= ppr v
 pprTickCts (BetaReduction v)		= ppr v
@@ -465,7 +543,6 @@ cmpEqTick (PreInlineUnconditionally a)	(PreInlineUnconditionally b)	= a `compare
 cmpEqTick (PostInlineUnconditionally a)	(PostInlineUnconditionally b)	= a `compare` b
 cmpEqTick (UnfoldingDone a)		(UnfoldingDone b)		= a `compare` b
 cmpEqTick (RuleFired a)			(RuleFired b)			= a `compare` b
-cmpEqTick (LetFloatFromLet a)		(LetFloatFromLet b)		= a `compare` b
 cmpEqTick (EtaExpansion a)		(EtaExpansion b)		= a `compare` b
 cmpEqTick (EtaReduction a)		(EtaReduction b)		= a `compare` b
 cmpEqTick (BetaReduction a)		(BetaReduction b)		= a `compare` b
@@ -487,7 +564,7 @@ cmpEqTick other1			other2				= EQ
 
 \begin{code}
 getSwitchChecker :: SimplM SwitchChecker
-getSwitchChecker env us sc = (seChkr env, us, sc)
+getSwitchChecker dflags env us sc = (seChkr env, us, sc)
 
 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
 getSimplIntSwitch chkr switch
@@ -548,23 +625,27 @@ knowing when something is evaluated.
 
 \begin{code}
 setBlackList :: BlackList -> SimplM a -> SimplM a
-setBlackList black_list m env us sc = m (env { seBlackList = black_list }) us sc
+setBlackList black_list m dflags env us sc 
+   = m dflags (env { seBlackList = black_list }) us sc
 
 getBlackList :: SimplM BlackList
-getBlackList env us sc = (seBlackList env, us, sc)
+getBlackList dflags env us sc = (seBlackList env, us, sc)
 
-noInlineBlackList :: BlackList
+noInlineBlackList :: SimplM BlackList
 	-- Inside inlinings, black list anything that is in scope or imported.
 	-- except for things that must be unfolded (Compulsory)
 	-- and data con wrappers.  The latter is a hack, like the one in
 	-- SimplCore.simplRules, to make wrappers inline in rule LHSs.
 	-- We may as well do the same here.
-noInlineBlackList v = not (isCompulsoryUnfolding (idUnfolding v)) &&
-		      not (isDataConWrapId v)
-	-- NB: this implementation means that even inlinings *completely within*
-	-- an INLINE won't happen, which is perhaps overkill. 
-	-- An earlier verion had: (v `isInScope` subst) || not (isLocallyDefined v)
-	-- but it's more expensive, and it probably doesn't matter.
+noInlineBlackList dflags env us sc = (blacklisted,us,sc)
+	where blacklisted v =
+	   	  not (isCompulsoryUnfolding (idUnfolding v)) &&
+		  not (isDataConWrapId v) &&
+		  (v `isInScope` (seSubst env) || isGlobalId v)
+	-- NB: An earlier version omitted the last clause; this meant 
+	-- that even inlinings *completely within* an INLINE didn't happen. 
+	-- This was cheaper, and probably adequate, but produced awful code
+        -- for some dictionary constructions.
 \end{code}
 
 
@@ -576,10 +657,10 @@ noInlineBlackList v = not (isCompulsoryUnfolding (idUnfolding v)) &&
 
 \begin{code}
 getEnclosingCC :: SimplM CostCentreStack
-getEnclosingCC env us sc = (seCC env, us, sc)
+getEnclosingCC dflags env us sc = (seCC env, us, sc)
 
 setEnclosingCC :: CostCentreStack -> SimplM a -> SimplM a
-setEnclosingCC cc m env us sc = m (env { seCC = cc }) us sc
+setEnclosingCC cc m dflags env us sc = m dflags (env { seCC = cc }) us sc
 \end{code}
 
 
@@ -600,78 +681,80 @@ emptySimplEnv sw_chkr in_scope black_list
 	-- The top level "enclosing CC" is "SUBSUMED".
 
 getEnv :: SimplM SimplEnv
-getEnv env us sc = (env, us, sc)
+getEnv dflags env us sc = (env, us, sc)
 
 setAllExceptInScope :: SimplEnv -> SimplM a -> SimplM a
-setAllExceptInScope new_env@(SimplEnv {seSubst = new_subst}) m 
+setAllExceptInScope new_env@(SimplEnv {seSubst = new_subst}) m dflags
 		    	    (SimplEnv {seSubst = old_subst}) us sc 
-  = m (new_env {seSubst = Subst.setInScope new_subst (substInScope old_subst)}) us sc
+  = m dflags (new_env {seSubst = Subst.setInScope new_subst (substInScope old_subst)}) 
+             us sc
 
 getSubst :: SimplM Subst
-getSubst env us sc = (seSubst env, us, sc)
+getSubst dflags env us sc = (seSubst env, us, sc)
 
 setSubst :: Subst -> SimplM a -> SimplM a
-setSubst subst m env us sc = m (env {seSubst = subst}) us sc
+setSubst subst m dflags env us sc = m dflags (env {seSubst = subst}) us sc
 
 getSubstEnv :: SimplM SubstEnv
-getSubstEnv env us sc = (substEnv (seSubst env), us, sc)
+getSubstEnv dflags env us sc = (substEnv (seSubst env), us, sc)
 
 addNewInScopeIds :: [CoreBndr] -> SimplM a -> SimplM a
 	-- The new Ids are guaranteed to be freshly allocated
-addNewInScopeIds  vs m env@(SimplEnv {seSubst = subst}) us sc
-  = m (env {seSubst = Subst.extendNewInScopeList subst vs}) us sc
+addNewInScopeIds vs m dflags env@(SimplEnv {seSubst = subst}) us sc
+  = m dflags (env {seSubst = Subst.extendNewInScopeList subst vs}) us sc
 
 getInScope :: SimplM InScopeSet
-getInScope env us sc = (substInScope (seSubst env), us, sc)
+getInScope dflags env us sc = (substInScope (seSubst env), us, sc)
 
 setInScope :: InScopeSet -> SimplM a -> SimplM a
-setInScope in_scope m env@(SimplEnv {seSubst = subst}) us sc
-  = m (env {seSubst = Subst.setInScope subst in_scope}) us sc
+setInScope in_scope m dflags env@(SimplEnv {seSubst = subst}) us sc
+  = m dflags (env {seSubst = Subst.setInScope subst in_scope}) us sc
 
 modifyInScope :: CoreBndr -> CoreBndr -> SimplM a -> SimplM a
-modifyInScope v v' m env@(SimplEnv {seSubst = subst}) us sc 
-  = m (env {seSubst = Subst.modifyInScope subst v v'}) us sc
+modifyInScope v v' m dflags env@(SimplEnv {seSubst = subst}) us sc 
+  = m dflags (env {seSubst = Subst.modifyInScope subst v v'}) us sc
 
 extendSubst :: CoreBndr -> SubstResult -> SimplM a -> SimplM a
-extendSubst var res m env@(SimplEnv {seSubst = subst}) us sc
-  = m (env { seSubst = Subst.extendSubst subst var res  }) us sc
+extendSubst var res m dflags env@(SimplEnv {seSubst = subst}) us sc
+  = m dflags (env { seSubst = Subst.extendSubst subst var res  }) us sc
 
 extendSubstList :: [CoreBndr] -> [SubstResult] -> SimplM a -> SimplM a
-extendSubstList vars ress m env@(SimplEnv {seSubst = subst}) us sc
-  = m (env { seSubst = Subst.extendSubstList subst vars ress  }) us sc
+extendSubstList vars ress m dflags env@(SimplEnv {seSubst = subst}) us sc
+  = m dflags (env { seSubst = Subst.extendSubstList subst vars ress  }) us sc
 
 setSubstEnv :: SubstEnv -> SimplM a -> SimplM a
-setSubstEnv senv m env@(SimplEnv {seSubst = subst}) us sc
-  = m (env {seSubst = Subst.setSubstEnv subst senv}) us sc
+setSubstEnv senv m dflags env@(SimplEnv {seSubst = subst}) us sc
+  = m dflags (env {seSubst = Subst.setSubstEnv subst senv}) us sc
 
 zapSubstEnv :: SimplM a -> SimplM a
-zapSubstEnv m env@(SimplEnv {seSubst = subst}) us sc
-  = m (env {seSubst = Subst.zapSubstEnv subst}) us sc
+zapSubstEnv m dflags env@(SimplEnv {seSubst = subst}) us sc
+  = m dflags (env {seSubst = Subst.zapSubstEnv subst}) us sc
 
 getSimplBinderStuff :: SimplM (Subst, UniqSupply)
-getSimplBinderStuff (SimplEnv {seSubst = subst}) us sc
+getSimplBinderStuff dflags (SimplEnv {seSubst = subst}) us sc
   = ((subst, us), us, sc)
 
 setSimplBinderStuff :: (Subst, UniqSupply) -> SimplM a -> SimplM a
-setSimplBinderStuff (subst, us) m env _ sc
-  = m (env {seSubst = subst}) us sc
+setSimplBinderStuff (subst, us) m dflags env _ sc
+  = m dflags (env {seSubst = subst}) us sc
 \end{code}
 
 
 \begin{code}
 newId :: UserFS -> Type -> (Id -> SimplM a) -> SimplM a
 	-- Extends the in-scope-env too
-newId fs ty m env@(SimplEnv {seSubst = subst}) us sc
+newId fs ty m dflags env@(SimplEnv {seSubst = subst}) us sc
   =  case splitUniqSupply us of
-	(us1, us2) -> m v (env {seSubst = Subst.extendNewInScope subst v}) us2 sc
+	(us1, us2) -> m v dflags (env {seSubst = Subst.extendNewInScope subst v}) 
+			us2 sc
 		   where
 		      v = mkSysLocal fs (uniqFromSupply us1) ty
 
 newIds :: UserFS -> [Type] -> ([Id] -> SimplM a) -> SimplM a
-newIds fs tys m env@(SimplEnv {seSubst = subst}) us sc
+newIds fs tys m dflags env@(SimplEnv {seSubst = subst}) us sc
   =  case splitUniqSupply us of
-	(us1, us2) -> m vs (env {seSubst = Subst.extendNewInScopeList subst vs}) us2 sc
+	(us1, us2) -> m vs dflags (env {seSubst = Subst.extendNewInScopeList subst vs}) 
+			us2 sc
 		   where
-		      vs = zipWithEqual "newIds" (mkSysLocal fs) 
-					(uniqsFromSupply (length tys) us1) tys
+		      vs = zipWith (mkSysLocal fs) (uniqsFromSupply us1) tys
 \end{code}