[project @ 2004-12-23 09:07:30 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 4ae835f..576c721 100644 (file)
--- a/ghc/compiler/deSugar/DsCCall.lhs
+++ b/ghc/compiler/deSugar/DsCCall.lhs
@@ -19,11 +19,12 @@ 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(..) )
+import ForeignCall     ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety, 
+                         CCallConv(..), CLabelString )
 import DataCon         ( splitProductType_maybe, dataConSourceArity, dataConWrapId )
 import ForeignCall     ( ForeignCall, CCallTarget(..) )
 
@@ -46,12 +47,11 @@ import TysWiredIn   ( unitDataConId,
                          unboxedSingletonTyCon, unboxedPairTyCon,
                          trueDataCon, falseDataCon, 
                          trueDataConId, falseDataConId,
-                         listTyCon, charTyCon, 
+                         listTyCon, charTyCon, boolTy, 
                          tupleTyCon, tupleCon
                        )
 import BasicTypes       ( Boxity(..) )
 import Literal         ( mkMachInt )
-import CStrings                ( CLabelString )
 import PrelNames       ( Unique, hasKey, ioTyConKey, boolTyConKey, unitTyConKey,
                          int8TyConKey, int16TyConKey, int32TyConKey,
                          word8TyConKey, word16TyConKey, word32TyConKey
@@ -169,10 +169,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 +185,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 +201,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,
@@ -238,7 +241,7 @@ unboxArg arg
                       ])
 
   | otherwise
-  = getSrcLocDs `thenDs` \ l ->
+  = getSrcSpanDs `thenDs` \ l ->
     pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
   where
     arg_ty                                     = exprType arg
@@ -303,6 +306,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 +323,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 +392,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)])