[project @ 2001-07-20 16:47:55 by simonpj]

------------------------
	More newtype squashing
	------------------------

Recursive newtypes were confusing the worker/wrapper generator.
This is because I originally got rid of opaque newtypes altogether,
then put them back for recursive ones only, and forgot to reinstate
the cunning stuff in the w/w stuff.

(Discovered by Sigbjorn; thanks!)

ghc/compiler/coreSyn/CoreUtils.lhs

@@ -60,7 +60,7 @@ import IdInfo		( LBVarInfo(..),
 import Demand		( appIsBottom )
 import Type		( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, 
 			  applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy,
-			  splitForAllTy_maybe, isForAllTy, eqType
+			  splitForAllTy_maybe, isForAllTy, splitNewType_maybe, eqType
 			)
 import TysWiredIn	( boolTy, trueDataCon, falseDataCon )
 import CostCentre	( CostCentre )
@@ -700,9 +700,8 @@ exprEtaExpandArity e
 
     go1 other = []
     
-    ok_note (Coerce _ _) = True
-    ok_note InlineCall   = True
-    ok_note other        = False
+    ok_note InlineMe = False
+    ok_note other    = True
 	    -- Notice that we do not look through __inline_me__
 	    -- This may seem surprising, but consider
 	    --	f = _inline_me (\x -> e)
@@ -727,13 +726,14 @@ etaExpand :: Int	  	-- Add this number of value args
 -- We should have
 --	ty = exprType e = exprType e'
 --
--- etaExpand deals with for-alls and coerces. For example:
+-- etaExpand deals with for-alls. For example:
 --		etaExpand 1 E
--- where  E :: forall a. T
---	  newtype T = MkT (A -> B)
---
+-- where  E :: forall a. a -> a
 -- would return
---	(/\b. coerce T (\y::A -> (coerce (A->B) (E b) y)
+--	(/\b. \y::a -> E b y)
+--
+-- It deals with coerces too, though they are now rare
+-- so perhaps the extra code isn't worth it
 
 etaExpand n us expr ty
   | n == 0 && 
@@ -761,8 +761,12 @@ etaExpand n us expr ty
  				   (us1, us2) = splitUniqSupply us
 				   uniq	      = uniqFromSupply us1 
 				   
-	; Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
-    	}}
+	; Nothing ->
+
+    	case splitNewType_maybe ty of {
+ 	  Just ty' -> mkCoerce ty ty' (etaExpand n us (mkCoerce ty' ty expr) ty') ;
+ 	  Nothing  -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
+    	}}}
 \end{code}
 
 
@@ -792,16 +796,17 @@ And in any case it seems more robust to have exprArity be a bit more intelligent
 exprArity :: CoreExpr -> Int
 exprArity e = go e
 	    where
+	      go (Var v) 	       	   = idArity v
 	      go (Lam x e) | isId x    	   = go e + 1
 			   | otherwise 	   = go e
-	      go (Note _ e)	       	   = go e
+	      go (Note n e) 		   = go e
 	      go (App e (Type t))      	   = go e
 	      go (App f a) | exprIsCheap a = (go f - 1) `max` 0
-		-- Important!  f (fac x) does not have arity 2, 
-		-- 	       even if f does!
+		-- NB: exprIsCheap a!  
+		--	f (fac x) does not have arity 2, 
+		-- 	even if f has arity 3!
 		-- NB: `max 0`!  (\x y -> f x) has arity 2, even if f is
 		--		 unknown, hence arity 0
-	      go (Var v) 	       	   = idArity v
 	      go _		       	   = 0
 \end{code}
 

ghc/compiler/stranal/WwLib.lhs

@@ -24,7 +24,7 @@ import PrelInfo		( realWorldPrimId, aBSENT_ERROR_ID )
 import TysPrim		( realWorldStatePrimTy )
 import TysWiredIn	( tupleCon )
 import Type		( Type, isUnLiftedType, mkFunTys,
-			  splitForAllTys, splitFunTys,  isAlgType
+			  splitForAllTys, splitFunTys, splitNewType_maybe, isAlgType
 			)
 import BasicTypes	( Arity, Boxity(..) )
 import Var              ( Var, isId )
@@ -311,6 +311,10 @@ mkWWargs fun_ty arity demands res_bot one_shots
     let
       val_args	= zipWith4 mk_wrap_arg wrap_uniqs arg_tys demands one_shots
       wrap_args = tyvars ++ val_args
+      n_args      | res_bot   = n_arg_tys 
+		  | otherwise = arity `min` n_arg_tys
+      new_fun_ty  | n_args == n_arg_tys = body_ty
+		  | otherwise  	        = mkFunTys (drop n_args arg_tys) body_ty
     in
     mkWWargs new_fun_ty
 	     (arity - n_args) 
@@ -322,17 +326,33 @@ mkWWargs fun_ty arity demands res_bot one_shots
 	      mkLams wrap_args . wrap_fn_args,
 	      work_fn_args . applyToVars wrap_args,
 	      res_ty)
+
+  | Just rep_ty <- splitNewType_maybe fun_ty,
+    arity >= 0
+   	-- The newtype case is for when the function has
+	-- a recursive newtype after the arrow (rare)
+	-- We check for arity >= 0 to avoid looping in the case
+	-- of a function whose type is, in effect, infinite
+	-- [Arity is driven by looking at the term, not just the type.]
+	--
+	-- It's also important when we have a function returning (say) a pair
+	-- wrapped in a recursive newtype, at least if CPR analysis can look 
+	-- through such newtypes, which it probably can since they are 
+	-- simply coerces.
+  = mkWWargs rep_ty arity demands res_bot one_shots	`thenUs` \ (wrap_args, wrap_fn_args, work_fn_args, res_ty) ->
+    returnUs (wrap_args,
+	      Note (Coerce fun_ty rep_ty) . wrap_fn_args,
+	      work_fn_args . Note (Coerce rep_ty fun_ty),
+	      res_ty)
+
+  | otherwise
+  = returnUs ([], id, id, fun_ty)
+
   where
     (tyvars, tau)      	= splitForAllTys fun_ty
     (arg_tys, body_ty) 	= splitFunTys tau
     n_arg_tys		= length arg_tys
-    n_args		| res_bot   = n_arg_tys 
-			| otherwise = arity `min` n_arg_tys
-    new_fun_ty		| n_args == n_arg_tys = body_ty
-			| otherwise  	      = mkFunTys (drop n_args arg_tys) body_ty
 
-mkWWargs fun_ty arity demands res_bot one_shots
-  = returnUs ([], id, id, fun_ty)
 
 applyToVars :: [Var] -> CoreExpr -> CoreExpr
 applyToVars vars fn = mkVarApps fn vars

ghc/compiler/typecheck/TcTyClsDecls.lhs

@@ -388,13 +388,8 @@ bogusVrcs = panic "Bogus tycon arg variances"
 mkNewTyConRep :: TyCon		-- The original type constructor
 	      -> Type		-- Chosen representation type
 -- Find the representation type for this newtype TyCon
--- For a recursive type constructor we give an error thunk,
--- because we never look at the rep in that case
--- (see notes on newypes in types/TypeRep
-
-mkNewTyConRep tc
-  | isRecursiveTyCon tc = pprPanic "Attempt to get the rep of newtype" (ppr tc)
-  | otherwise		= head (dataConOrigArgTys (head (tyConDataCons tc)))
+-- See notes on newypes in types/TypeRep about newtypes.
+mkNewTyConRep tc = head (dataConOrigArgTys (head (tyConDataCons tc)))
 \end{code}
 
 

ghc/compiler/types/Type.lhs

@@ -52,7 +52,7 @@ module Type (
 	SourceType(..), sourceTypeRep,
 
 	-- Newtypes
-	mkNewTyConApp,
+	splitNewType_maybe,
 
 	-- Lifting and boxity
 	isUnLiftedType, isUnboxedTupleType, isAlgType,
@@ -85,7 +85,7 @@ import TypeRep
 -- Other imports:
 
 import {-# SOURCE #-}	PprType( pprType )	-- Only called in debug messages
-import {-# SOURCE #-}   Subst  ( mkTyVarSubst, substTy )
+import {-# SOURCE #-}   Subst  ( substTyWith )
 
 -- friends:
 import Var	( Var, TyVar, tyVarKind, tyVarName, setTyVarName )
@@ -363,7 +363,7 @@ mkSynTy syn_tycon tys
   = ASSERT( isSynTyCon syn_tycon )
     ASSERT( length tyvars == length tys )
     NoteTy (SynNote (TyConApp syn_tycon tys))
-	   (substTy (mkTyVarSubst tyvars tys) body)
+	   (substTyWith tyvars tys body)
   where
     (tyvars, body) = getSynTyConDefn syn_tycon
 \end{code}
@@ -472,7 +472,7 @@ applyTy (NoteTy _ fun)                  arg = applyTy fun arg
 applyTy (ForAllTy tv ty)                arg = UASSERT2( not (isUTy arg),
                                                         ptext SLIT("applyTy")
                                                         <+> pprType ty <+> pprType arg )
-                                              substTy (mkTyVarSubst [tv] [arg]) ty
+                                              substTyWith [tv] [arg] ty
 applyTy (UsageTy u ty)                  arg = UsageTy u (applyTy ty arg)
 applyTy other		                arg = panic "applyTy"
 
@@ -482,7 +482,7 @@ applyTys fun_ty arg_tys
    (case mu of
       Just u  -> UsageTy u
       Nothing -> id) $
-   substTy (mkTyVarSubst tvs arg_tys) ty
+   substTyWith tvs arg_tys ty
  where
    (mu, tvs, ty) = split fun_ty arg_tys
    
@@ -598,18 +598,32 @@ sourceTypeRep :: SourceType -> Type
 sourceTypeRep (IParam n ty)     = ty
 sourceTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys
 	-- Note the mkTyConApp; the classTyCon might be a newtype!
-sourceTypeRep (NType  tc tys)   = case newTyConRep tc of
-				    (tvs, rep_ty) -> substTy (mkTyVarSubst tvs tys) rep_ty
+sourceTypeRep (NType  tc tys)   = newTypeRep tc tys
 	-- ToDo: Consider caching this substitution in a NType
 
-mkNewTyConApp :: TyCon -> [Type] -> SourceType
-mkNewTyConApp tc tys = NType tc tys	-- Here is where we might cache the substitution
-
 isSourceTy :: Type -> Bool
 isSourceTy (NoteTy _ ty)  = isSourceTy ty
 isSourceTy (UsageTy _ ty) = isSourceTy ty
 isSourceTy (SourceTy sty) = True
 isSourceTy _	          = False
+
+
+splitNewType_maybe :: Type -> Maybe Type
+-- Newtypes that are recursive are reprsented by TyConApp, just
+-- as they always were.  Occasionally we want to find their representation type.
+-- NB: remember that in this module, non-recursive newtypes are transparent
+
+splitNewType_maybe ty
+  = case splitTyConApp_maybe ty of
+	Just (tc,tys) | isNewTyCon tc -> ASSERT( length tys == tyConArity tc )
+						-- The assert should hold because repType should
+						-- only be applied to *types* (of kind *)
+					 Just (newTypeRep tc tys)
+	other -> Nothing
+			
+-- A local helper function (not exported)
+newTypeRep new_tycon tys = case newTyConRep new_tycon of
+			     (tvs, rep_ty) -> substTyWith tvs tys rep_ty
 \end{code}