X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;h=7cd0b960209698ceee35ca47b81e8c702dfaca93;hb=2a36f9046d5d1c39e1c3425f6601f7535785538d;hp=05ceb4d0929ca047a3e7f74da3b1f5f67e79dc29;hpb=c8e973ee6d7e3df1ae065cb3a8223a4777a9f4af;p=ghc-hetmet.git

diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index 05ceb4d..7cd0b96 100644
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -22,7 +22,7 @@ import SimplUtils	( findDefault )
 import CostCentre	( noCCS )
 import Id		( Id, mkSysLocal, idType, idStrictness, isExportedId, 
 			  mkVanillaId, idName, idDemandInfo, idArity, setIdType,
-			  idFlavour, idUnique
+			  idFlavour
 			)
 import IdInfo		( StrictnessInfo(..), IdFlavour(..) )
 import DataCon		( dataConWrapId )
@@ -228,7 +228,22 @@ coreBindToStg top_lev env (NonRec binder rhs)
 		-- But we don't want to discard exported things.  They can
 		-- occur; e.g. an exported user binding f = g
 
-	other -> newLocalId top_lev env binder		`thenUs` \ (new_env, new_binder) ->
+{-
+	([], StgLam _ bndrs (StgApp var args))
+		| bndrs `eqArgs` args && not (isExportedId binder)
+		     -> returnUs (NoBindF, extendVarEnv env binder var)
+		-- a binding of the form  z = \x1..xn -> f x1..xn we can
+	  	-- eta-reduce to z = f, which will be inlined as above
+		-- These bindings sometimes occur after things like type 
+		-- coercions have been removed.
+
+		where eqArgs [] [] = True
+		      eqArgs (x:xs) (StgVarArg y : ys) = x == y && eqArgs xs ys
+		      eqArgs _ _ = False
+-}
+
+	other -> newLocalId top_lev env binder 
+			`thenUs` \ (new_env, new_binder) ->
 		 returnUs (NonRecF new_binder stg_rhs dem floats, new_env)
   where
     dem = bdrDem binder
@@ -655,11 +670,10 @@ mkStgApp env fn args ty
 		-- Sigh...make a guaranteed unique name for a dynamic ccall
 		-- Done here, not earlier, because it's a code-gen thing
 	-> saturate fn_alias args ty	$ \ args' ty' ->
-           returnUs (StgPrimApp (CCallOp ccall') args' ty')
-	where
-	   ccall' = setCCallUnique ccall (idUnique fn)	
-			-- The particular unique doesn't matter
-
+	   getUniqueUs	 		`thenUs` \ uniq ->
+           let ccall' = setCCallUnique ccall uniq in
+	   returnUs (StgPrimApp (CCallOp ccall') args' ty')
+	   
       PrimOpId op 
 	-> saturate fn_alias args ty	$ \ args' ty' ->
 	   returnUs (StgPrimApp op args' ty')