[project @ 2005-08-10 07:49:36 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 57bace2..e630f04 100644 (file)
--- a/ghc/compiler/deSugar/DsCCall.lhs
+++ b/ghc/compiler/deSugar/DsCCall.lhs
@@ -19,14 +19,13 @@ import CoreSyn
 
 import DsMonad
 
-import CoreUtils       ( exprType, mkCoerce2 )
+import CoreUtils       ( exprType, coreAltType, mkCoerce2 )
 import Id              ( Id, mkWildId )
 import MkId            ( mkFCallId, realWorldPrimId, mkPrimOpId )
 import Maybes          ( maybeToBool )
 import ForeignCall     ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety, 
                          CCallConv(..), CLabelString )
 import DataCon         ( splitProductType_maybe, dataConSourceArity, dataConWrapId )
-import ForeignCall     ( ForeignCall, CCallTarget(..) )
 
 import TcType          ( tcSplitTyConApp_maybe )
 import Type            ( Type, isUnLiftedType, mkFunTys, mkFunTy,
@@ -47,7 +46,7 @@ import TysWiredIn     ( unitDataConId,
                          unboxedSingletonTyCon, unboxedPairTyCon,
                          trueDataCon, falseDataCon, 
                          trueDataConId, falseDataConId,
-                         listTyCon, charTyCon, 
+                         listTyCon, charTyCon, boolTy, 
                          tupleTyCon, tupleCon
                        )
 import BasicTypes       ( Boxity(..) )
@@ -114,7 +113,7 @@ dsCCall :: CLabelString     -- C routine to invoke
 
 dsCCall lbl args may_gc result_ty
   = mapAndUnzipDs unboxArg args               `thenDs` \ (unboxed_args, arg_wrappers) ->
-    boxResult [] id Nothing result_ty  `thenDs` \ (ccall_result_ty, res_wrapper) ->
+    boxResult id Nothing result_ty  `thenDs` \ (ccall_result_ty, res_wrapper) ->
     newUnique                         `thenDs` \ uniq ->
     let
        target = StaticTarget lbl
@@ -169,10 +168,12 @@ unboxArg arg
     tc `hasKey` boolTyConKey
   = newSysLocalDs intPrimTy            `thenDs` \ prim_arg ->
     returnDs (Var prim_arg,
-             \ body -> Case (Case arg (mkWildId arg_ty)
+             \ body -> Case (Case arg (mkWildId arg_ty) intPrimTy
                                       [(DataAlt falseDataCon,[],mkIntLit 0),
                                        (DataAlt trueDataCon, [],mkIntLit 1)])
-                             prim_arg 
+                                       -- In increasing tag order!
+                             prim_arg
+                             (exprType body) 
                             [(DEFAULT,[],body)])
 
   -- Data types with a single constructor, which has a single, primitive-typed arg
@@ -183,7 +184,7 @@ unboxArg arg
     newSysLocalDs arg_ty               `thenDs` \ case_bndr ->
     newSysLocalDs data_con_arg_ty1     `thenDs` \ prim_arg ->
     returnDs (Var prim_arg,
-             \ body -> Case arg case_bndr [(DataAlt data_con,[prim_arg],body)]
+             \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]
     )
 
   -- Byte-arrays, both mutable and otherwise; hack warning
@@ -199,7 +200,8 @@ unboxArg arg
   = newSysLocalDs arg_ty               `thenDs` \ case_bndr ->
     newSysLocalsDs data_con_arg_tys    `thenDs` \ vars@[l_var, r_var, arr_cts_var] ->
     returnDs (Var arr_cts_var,
-             \ body -> Case arg case_bndr [(DataAlt data_con,vars,body)]
+             \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]
+
     )
 
   | Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
@@ -255,8 +257,7 @@ unboxArg arg
 
 
 \begin{code}
-boxResult :: [Id]
-         -> ((Maybe Type, CoreExpr -> CoreExpr) -> (Maybe Type, CoreExpr -> CoreExpr))
+boxResult :: ((Maybe Type, CoreExpr -> CoreExpr) -> (Maybe Type, CoreExpr -> CoreExpr))
          -> Maybe Id
          -> Type
          -> DsM (Type, CoreExpr -> CoreExpr)
@@ -272,7 +273,7 @@ boxResult :: [Id]
 -- the result type will be 
 --     State# RealWorld -> (# State# RealWorld #)
 
-boxResult arg_ids augment mbTopCon result_ty
+boxResult augment mbTopCon result_ty
   = case tcSplitTyConApp_maybe result_ty of
        -- This split absolutely has to be a tcSplit, because we must
        -- see the IO type; and it's a newtype which is transparent to splitTyConApp.
@@ -303,6 +304,7 @@ boxResult arg_ids augment mbTopCon result_ty
                                             Lam state_id $
                                              Case (App the_call (Var state_id))
                                                   (mkWildId ccall_res_ty)
+                                                   (coreAltType the_alt) 
                                                   [the_alt]
                                           ]
                   in
@@ -319,6 +321,7 @@ boxResult arg_ids augment mbTopCon result_ty
                 let
                    wrap = \ the_call -> Case (App the_call (Var realWorldPrimId)) 
                                              (mkWildId ccall_res_ty)
+                                              (coreAltType the_alt)
                                              [the_alt]
                 in
                 returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
@@ -387,6 +390,7 @@ resultWrapper result_ty
   | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey
   = returnDs
      (Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
+                                   boolTy
                                   [(DEFAULT             ,[],Var trueDataConId ),
                                    (LitAlt (mkMachInt 0),[],Var falseDataConId)])