From 5f6f90850d5c82dc56d13bbc035d635e1cb2106b Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Fri, 18 May 2001 14:18:34 +0000
Subject: [PATCH] [project @ 2001-05-18 14:18:34 by simonmar] Allow unboxing
 strict fields through newtypes.

---
 ghc/compiler/basicTypes/DataCon.lhs |   38 ++++++++++++++--------------
 ghc/compiler/basicTypes/MkId.lhs    |   47 +++++++++++++++++++++++++++--------
 2 files changed, 57 insertions(+), 28 deletions(-)

diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs
index c5dd0e1..e9563f4 100644
--- a/ghc/compiler/basicTypes/DataCon.lhs
+++ b/ghc/compiler/basicTypes/DataCon.lhs
@@ -28,7 +28,7 @@ import CmdLineOpts	( opt_DictsStrict )
 import Type		( Type, TauType, ThetaType,
 			  mkForAllTys, mkFunTys, mkTyConApp,
 			  mkTyVarTys, mkPredTys, getClassPredTys_maybe,
-			  splitTyConApp_maybe
+			  splitTyConApp_maybe, repType
 			)
 import TyCon		( TyCon, tyConDataCons, tyConDataConsIfAvailable, isDataTyCon, isProductTyCon,
 			  isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon )
@@ -427,32 +427,34 @@ chooseBoxingStrategy :: TyCon -> Type -> StrictnessMark -> StrictnessMark
 	-- Transforms any MarkedUserStricts into MarkUnboxed or MarkedStrict
 chooseBoxingStrategy tycon arg_ty strict
   = case strict of
-	MarkedUserStrict | unbox arg_ty -> MarkedUnboxed
-			 | otherwise    -> MarkedStrict
-	other			  	-> strict
+	MarkedUserStrict
+	  | opt_UnboxStrictFields
+		&& unbox arg_ty -> MarkedUnboxed
+	  | otherwise -> MarkedStrict
+	other -> strict
   where
-    unbox ty = opt_UnboxStrictFields &&
-	       case splitTyConApp_maybe ty of
-		  Just (arg_tycon, _) -> not (isRecursiveTyCon arg_tycon) && 
-					 isProductTyCon arg_tycon && 
-					 isDataTyCon arg_tycon
-		  Nothing	      -> False
-	-- Recursion: check whether the *argument* type constructor is
-	-- recursive.  Checking the *parent* tycon is over-conservative
-	--
-	-- We can't look through newtypes in arguments (yet); hence isDataTyCon
-
+	-- beware: repType will go into a loop if we try this on a recursive
+	-- type (for reasons unknown...), hence the check for recursion below.
+    unbox ty =  
+	case splitTyConApp_maybe ty of
+		Nothing	-> False
+		Just (arg_tycon, _)
+		  | isRecursiveTyCon arg_tycon -> False
+		  | otherwise ->
+			  case splitTyConApp_maybe (repType ty) of
+		     		Nothing -> False
+		     		Just (arg_tycon, _) -> isProductTyCon arg_tycon
 
 unbox_strict_arg_ty 
 	:: StrictnessMark	-- After strategy choice; can't be MkaredUserStrict
 	-> Type			-- Source argument type
 	-> [(Demand,Type)]	-- Representation argument types and demamds
-	
+
 unbox_strict_arg_ty NotMarkedStrict ty = [(wwLazy,   ty)]
 unbox_strict_arg_ty MarkedStrict    ty = [(wwStrict, ty)]
 unbox_strict_arg_ty MarkedUnboxed   ty 
   = zipEqual "unbox_strict_arg_ty" (dataConRepStrictness arg_data_con) arg_tys
   where
-    (_, _, arg_data_con, arg_tys) = splitProductType "unbox_strict_arg_ty" ty
-
+    (_, _, arg_data_con, arg_tys)
+	 = splitProductType "unbox_strict_arg_ty" (repType ty)
 \end{code}
diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index b639f21..23376f4 100644
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -39,7 +39,8 @@ import TysWiredIn	( charTy, mkListTy )
 import PrelNames	( pREL_ERR, pREL_GHC )
 import PrelRules	( primOpRule )
 import Rules		( addRule )
-import Type		( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp, mkTyVarTys,
+import Type		( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp,
+			  mkTyVarTys, repType, isNewType,
 			  mkFunTys, mkFunTy, mkSigmaTy, splitSigmaTy, 
 			  isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
 			  splitFunTys, splitForAllTys, mkPredTy
@@ -303,12 +304,25 @@ mkDataConWrapId data_con
 		   | otherwise ->
 			Case (Var arg) arg [(DEFAULT,[], body i (arg:rep_args))]
 
-		MarkedUnboxed ->
-		   Case (Var arg) arg [(DataAlt con, con_args,
+		MarkedUnboxed
+		   | isNewType arg_ty ->
+			Let (NonRec coerced_arg 
+				(Note (Coerce rep_ty arg_ty) (Var arg)))
+			      (do_unbox coerced_arg rep_ty i')
+		   | otherwise ->
+			do_unbox arg arg_ty i
+		  where
+		    ([coerced_arg],i') = mkLocals i [rep_ty]
+		    arg_ty = idType arg
+		    rep_ty = repType arg_ty
+
+		    do_unbox arg ty i = 
+			case splitProductType "do_unbox" ty of
+			   (tycon, tycon_args, con, tys) ->
+				   Case (Var arg) arg [(DataAlt con, con_args,
 					body i' (reverse con_args ++ rep_args))]
-		   where 
-			(con_args, i')   = mkLocals i tys
-			(_, _, con, tys) = splitProductType "mk_case" (idType arg)
+			      where 
+				(con_args, i')   = mkLocals i tys
 \end{code}
 
 
@@ -506,12 +520,25 @@ rebuildConArgs (arg:args) stricts us
 rebuildConArgs (arg:args) (str:stricts) us
   | isMarkedUnboxed str
   = let
-	(_, tycon_args, pack_con, con_arg_tys) = splitProductType "rebuildConArgs" (idType arg)
+	arg_ty  = idType arg
+	prod_ty | isNewType arg_ty = repType arg_ty
+		| otherwise        = arg_ty
+
+	(_, tycon_args, pack_con, con_arg_tys)
+	 	 = splitProductType "rebuildConArgs" prod_ty
+
 	unpacked_args  = zipWith (mkSysLocal SLIT("rb")) us con_arg_tys
-	(binds, args') = rebuildConArgs args stricts (drop (length con_arg_tys) us)
-	con_app	       = mkConApp pack_con (map Type tycon_args ++ map Var  unpacked_args)
+
+	(binds, args') = rebuildConArgs args stricts 
+				(drop (length con_arg_tys) us)
+
+	coerce | isNewType arg_ty = Note (Coerce arg_ty prod_ty) con_app
+	       | otherwise        = con_app
+
+	con_app	       = mkConApp pack_con (map Type tycon_args ++ 
+					    map Var  unpacked_args)
     in
-    (NonRec arg con_app : binds, unpacked_args ++ args')
+    (NonRec arg coerce : binds, unpacked_args ++ args')
 
   | otherwise
   = let (binds, args') = rebuildConArgs args stricts us
-- 
1.7.10.4