[project @ 2000-10-24 17:09:44 by simonpj]

[ghc-hetmet.git] / ghc / compiler / deSugar / DsCCall.lhs

diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs
index ecab476..51a22ba 100644 (file)
--- 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 PrelInfo                ( packStringForCId )
-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 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}