X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUtils.lhs;h=39d2fcf862d08f16a5c83819ad31dcd53bc2a3af;hb=8aa9bfb9957c5253fdb1f569f2451bfc14413059;hp=882d469ef33647a278e194846c4143688a109001;hpb=424d45ae7a17cb085d41e5b3d85c699b7c9951ed;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index 882d469..39d2fcf 100644
--- a/ghc/compiler/coreSyn/CoreUtils.lhs
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -6,16 +6,16 @@
 \begin{code}
 module CoreUtils (
 	-- Construction
-	mkNote, mkInlineMe, mkSCC, mkCoerce, mkCoerce2,
+	mkInlineMe, mkSCC, mkCoerce, mkCoerce2,
 	bindNonRec, needsCaseBinding,
 	mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
 
 	-- Taking expressions apart
-	findDefault, findAlt, hasDefault,
+	findDefault, findAlt,
 
 	-- Properties of expressions
-	exprType, coreAltsType, 
-	exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap, 
+	exprType,
+	exprIsDupable, exprIsTrivial, exprIsCheap, 
 	exprIsValue,exprOkForSpeculation, exprIsBig, 
 	exprIsConApp_maybe, 
 	rhsIsStatic,
@@ -45,9 +45,9 @@ import Var		( Var, isId, isTyVar )
 import VarEnv
 import Name		( hashName, isDllName )
 import Literal		( hashLiteral, literalType, litIsDupable, 
-			  litIsTrivial, isZeroLit, isLitLitLit )
+			  litIsTrivial, isZeroLit, Literal( MachLabel ) )
 import DataCon		( DataCon, dataConRepArity, dataConArgTys,
-			  isExistentialDataCon, dataConTyCon, dataConName )
+			  isExistentialDataCon, dataConTyCon )
 import PrimOp		( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
 import Id		( Id, idType, globalIdDetails, idNewStrictness, 
 			  mkWildId, idArity, idName, idUnfolding, idInfo,
@@ -59,7 +59,7 @@ import NewDemand	( appIsBottom )
 import Type		( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
 			  splitFunTy,
 			  applyTys, isUnLiftedType, seqType, mkTyVarTy,
-			  splitForAllTy_maybe, isForAllTy, splitNewType_maybe, 
+			  splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe, 
 			  splitTyConApp_maybe, eqType, funResultTy, applyTy,
 			  funResultTy, applyTy
 			)
@@ -154,11 +154,13 @@ applyTypeToArgs e op_ty (other_arg : args)
 mkNote removes redundant coercions, and SCCs where possible
 
 \begin{code}
+#ifdef UNUSED
 mkNote :: Note -> CoreExpr -> CoreExpr
 mkNote (Coerce to_ty from_ty) expr = mkCoerce2 to_ty from_ty expr
 mkNote (SCC cc)	expr		   = mkSCC cc expr
 mkNote InlineMe expr		   = mkInlineMe expr
 mkNote note     expr		   = Note note expr
+#endif
 
 -- Slide InlineCall in around the function
 --	No longer necessary I think (SLPJ Apr 99)
@@ -276,10 +278,6 @@ The default alternative must be first, if it exists at all.
 This makes it easy to find, though it makes matching marginally harder.
 
 \begin{code}
-hasDefault :: [CoreAlt] -> Bool
-hasDefault ((DEFAULT,_,_) : alts) = True
-hasDefault _			  = False
-
 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
 findDefault alts			= 		      (alts, Nothing)
@@ -795,6 +793,11 @@ arityType (App f a)  	   = case arityType f of
 							   
 	-- Case/Let; keep arity if either the expression is cheap
 	-- or it's a 1-shot lambda
+	-- The former is not really right for Haskell
+	--	f x = case x of { (a,b) -> \y. e }
+	--  ===>
+	--	f x y = case x of { (a,b) -> e }
+	-- The difference is observable using 'seq'
 arityType (Case scrut _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
 				  xs@(AFun one_shot _) | one_shot -> xs
 				  xs | exprIsCheap scrut	  -> xs
@@ -932,15 +935,17 @@ eta_expand n us expr ty
 	; Nothing ->
 
 		-- Given this:
-		-- 	newtype T = MkT (Int -> Int)
+		-- 	newtype T = MkT ([T] -> Int)
 		-- Consider eta-expanding this
 		--  	eta_expand 1 e T
 		-- We want to get
-		--	coerce T (\x::Int -> (coerce (Int->Int) e) x)
+		--	coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
+		-- Only try this for recursive newtypes; the non-recursive kind
+		-- are transparent anyway
 
-    	case splitNewType_maybe ty of {
+    	case splitRecNewType_maybe ty of {
  	  Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ;
- 	  Nothing  -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
+ 	  Nothing  -> pprTrace "Bad eta expand" (ppr n $$ ppr expr $$ ppr ty) expr
     	}}}
 \end{code}
 
@@ -1157,11 +1162,10 @@ hashId id = hashName (idName id)
 %*									*
 %************************************************************************
 
-Top-level constructor applications can usually be allocated 
-statically, but they can't if 
-   a) the constructor, or any of the arguments, come from another DLL
-   b) any of the arguments are LitLits
-(because we can't refer to static labels in other DLLs).
+Top-level constructor applications can usually be allocated
+statically, but they can't if the constructor, or any of the
+arguments, come from another DLL (because we can't refer to static
+labels in other DLLs).
 
 If this happens we simply make the RHS into an updatable thunk, 
 and 'exectute' it rather than allocating it statically.
@@ -1236,9 +1240,18 @@ is_static False (Lam b e) = isRuntimeVar b || is_static False e
 is_static in_arg (Note (SCC _) e) = False
 is_static in_arg (Note _ e)       = is_static in_arg e
 
-is_static in_arg (Lit lit)        = not (isLitLitLit lit)
-	-- lit-lit arguments cannot be used in static constructors either.  
-	-- (litlits are deprecated, so I'm not going to bother cleaning up this infelicity --SDM).
+is_static in_arg (Lit lit)
+  = case lit of
+	MachLabel _ _ -> False
+	other 	      -> True
+	-- A MachLabel (foreign import "&foo") in an argument
+	-- prevents a constructor application from being static.  The
+	-- reason is that it might give rise to unresolvable symbols
+	-- in the object file: under Linux, references to "weak"
+	-- symbols from the data segment give rise to "unresolvable
+	-- relocation" errors at link time This might be due to a bug
+	-- in the linker, but we'll work around it here anyway. 
+	-- SDM 24/2/2004
 
 is_static in_arg other_expr = go other_expr 0
   where