X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsCCall.lhs;h=51a22bae19dfc0af377e008354b4e488a02eafcc;hb=1c3601593186639f1086bc402582ff56fd3fe9f8;hp=11ca5a093a9d71390a45f8c9afcaff1522eb3d34;hpb=f5262d4457cabda7112af850d4659366a7ce34a1;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs
index 11ca5a0..51a22ba 100644
--- a/ghc/compiler/deSugar/DsCCall.lhs
+++ b/ghc/compiler/deSugar/DsCCall.lhs
@@ -17,33 +17,31 @@ module DsCCall
 import CoreSyn
 
 import DsMonad
-import DsUtils
 
 import CoreUtils	( exprType, mkCoerce )
-import Id		( Id, mkWildId )
+import Id		( mkWildId )
 import MkId		( mkCCallOpId, realWorldPrimId )
 import Maybes		( maybeToBool )
-import PrimOp		( PrimOp(..), CCall(..), CCallTarget(..) )
-import DataCon		( DataCon, splitProductType_maybe, dataConSourceArity, dataConWrapId )
+import PrimOp		( CCall(..), CCallTarget(..) )
+import DataCon		( splitProductType_maybe, dataConSourceArity, dataConWrapId )
 import CallConv
 import Type		( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys,
 			  splitTyConApp_maybe, tyVarsOfType, mkForAllTys, 
-			  isNewType, repType, isUnLiftedType, mkFunTy,
+			  isNewType, repType, isUnLiftedType, mkFunTy, mkTyConApp,
 			  Type
 			)
-import PprType		( {- instance Outputable Type -} )
-import TysPrim		( byteArrayPrimTy, realWorldStatePrimTy,
+import TysPrim		( realWorldStatePrimTy,
 			  byteArrayPrimTyCon, mutableByteArrayPrimTyCon, intPrimTy
 			)
-import TysWiredIn	( unitDataConId, stringTy,
-			  unboxedPairDataCon,
-			  mkUnboxedTupleTy, unboxedTupleCon,
-			  boolTy, trueDataCon, falseDataCon, trueDataConId, falseDataConId,
-			  unitTy
+import TysWiredIn	( unitDataConId,
+			  unboxedSingletonDataCon, unboxedPairDataCon,
+			  unboxedSingletonTyCon, unboxedPairTyCon,
+			  boolTy, trueDataCon, falseDataCon, 
+			  trueDataConId, falseDataConId, unitTy
 			)
 import Literal		( mkMachInt )
 import CStrings		( CLabelString )
-import Unique		( Unique, Uniquable(..), ioTyConKey )
+import PrelNames	( Unique, hasKey, ioTyConKey )
 import VarSet		( varSetElems )
 import Outputable
 \end{code}
@@ -179,14 +177,12 @@ unboxArg arg
   = getSrcLocDs `thenDs` \ l ->
     pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
   where
-    arg_ty     = exprType arg
-    arg_rep_ty = repType arg_ty
-
-    maybe_product_type 			   	  = splitProductType_maybe arg_ty
-    is_product_type			   	  = maybeToBool maybe_product_type
-    Just (tycon, _, data_con, data_con_arg_tys)   = maybe_product_type
-    data_con_arity				  = dataConSourceArity data_con
-    (data_con_arg_ty1 : _)			  = data_con_arg_tys
+    arg_ty  					= exprType arg
+    maybe_product_type 			   	= splitProductType_maybe arg_ty
+    is_product_type			   	= maybeToBool maybe_product_type
+    Just (_, _, data_con, data_con_arg_tys)	= maybe_product_type
+    data_con_arity				= dataConSourceArity data_con
+    (data_con_arg_ty1 : _)			= data_con_arg_tys
 
     (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
     maybe_arg3_tycon    	   = splitTyConApp_maybe data_con_arg_ty3
@@ -212,7 +208,7 @@ boxResult result_ty
   = case splitAlgTyConApp_maybe result_ty of
 
 	-- The result is IO t, so wrap the result in an IO constructor
-	Just (io_tycon, [io_res_ty], [io_data_con]) | getUnique io_tycon == ioTyConKey
+	Just (io_tycon, [io_res_ty], [io_data_con]) | io_tycon `hasKey` ioTyConKey
 		-> mk_alt return_result 
 			  (resultWrapper io_res_ty)	`thenDs` \ (ccall_res_ty, the_alt) ->
 		   newSysLocalDs realWorldStatePrimTy	 `thenDs` \ state_id ->
@@ -247,8 +243,8 @@ boxResult result_ty
 	  newSysLocalDs realWorldStatePrimTy	`thenDs` \ state_id ->
 	  let
 		the_rhs      = return_result (Var state_id) (wrap_result (panic "boxResult"))
-		ccall_res_ty = mkUnboxedTupleTy 1 [realWorldStatePrimTy]
-		the_alt      = (DataAlt (unboxedTupleCon 1), [state_id], the_rhs)
+		ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy]
+		the_alt      = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs)
 	  in
 	  returnDs (ccall_res_ty, the_alt)
 
@@ -258,7 +254,7 @@ boxResult result_ty
 	  newSysLocalDs prim_res_ty 		`thenDs` \ result_id ->
 	  let
 		the_rhs      = return_result (Var state_id) (wrap_result (Var result_id))
-		ccall_res_ty = mkUnboxedTupleTy 2 [realWorldStatePrimTy, prim_res_ty]
+		ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty]
 		the_alt	     = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs)
 	  in
 	  returnDs (ccall_res_ty, the_alt)
@@ -301,8 +297,8 @@ resultWrapper result_ty
   | otherwise
   = pprPanic "resultWrapper" (ppr result_ty)
   where
-    maybe_product_type 					    = splitProductType_maybe result_ty
-    is_product_type					    = maybeToBool maybe_product_type
-    Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) = maybe_product_type
-    data_con_arity					    = dataConSourceArity data_con
+    maybe_product_type 					= splitProductType_maybe result_ty
+    is_product_type					= maybeToBool maybe_product_type
+    Just (_, tycon_arg_tys, data_con, data_con_arg_tys) = maybe_product_type
+    data_con_arity					= dataConSourceArity data_con
 \end{code}