X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsCCall.lhs;h=2034e3733e4572ea44af6c46d3787b6369e69cfa;hb=5e5a08eb37f5513cecb47101a97fdaf09c4be040;hp=0ceb44379b128dbf7026e4e6e04b653441c43da0;hpb=b601e528ba870ee5ec68b3aba894a77ae008390a;p=ghc-hetmet.git

diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs
index 0ceb443..2034e37 100644
--- a/compiler/deSugar/DsCCall.lhs
+++ b/compiler/deSugar/DsCCall.lhs
@@ -6,13 +6,6 @@
 Desugaring foreign calls
 
 \begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
 module DsCCall 
 	( dsCCall
 	, mkFCall
@@ -29,6 +22,8 @@ import CoreSyn
 import DsMonad
 
 import CoreUtils
+import MkCore
+import Var
 import Id
 import MkId
 import Maybes
@@ -48,11 +43,6 @@ import PrelNames
 import VarSet
 import Constants
 import Outputable
-
-#ifdef DEBUG
-import TypeRep
-#endif
-
 \end{code}
 
 Desugaring of @ccall@s consists of adding some state manipulation,
@@ -145,7 +135,7 @@ unboxArg arg
   = return (arg, \body -> body)
 
   -- Recursive newtypes
-  | Just(rep_ty, co) <- splitNewTypeRepCo_maybe arg_ty
+  | Just(_rep_ty, co) <- splitNewTypeRepCo_maybe arg_ty
   = unboxArg (mkCoerce co arg)
       
   -- Booleans
@@ -153,7 +143,7 @@ unboxArg arg
     tc `hasKey` boolTyConKey
   = do prim_arg <- newSysLocalDs intPrimTy
        return (Var prim_arg,
-              \ body -> Case (Case arg (mkWildId arg_ty) intPrimTy
+              \ body -> Case (mkWildCase arg arg_ty intPrimTy
                                        [(DataAlt falseDataCon,[],mkIntLit 0),
                                         (DataAlt trueDataCon, [],mkIntLit 1)])
                                         -- In increasing tag order!
@@ -182,7 +172,7 @@ unboxArg arg
     (arg3_tycon ==  byteArrayPrimTyCon ||
      arg3_tycon ==  mutableByteArrayPrimTyCon)
   = do case_bndr <- newSysLocalDs arg_ty
-       vars@[l_var, r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys
+       vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys
        return (Var arr_cts_var,
                \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]
               )
@@ -206,7 +196,7 @@ unboxArg arg
                         , arg
                         , Lam prim_string body
                         ])
-  | Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
+  | Just (tc, [_]) <- splitTyConApp_maybe arg_ty,
     tyConName tc == objectTyConName
     -- Object; dotnet only
   = do unpack_id <- dsLookupGlobalId marshalObjectName
@@ -295,30 +285,33 @@ boxResult augment mbTopCon result_ty
 			      mkApps (Var toIOCon)
 			    	     [ Type io_res_ty, 
 			    	       Lam state_id $
-			    	       Case (App the_call (Var state_id))
-			    	     	     (mkWildId ccall_res_ty)
+			    	       mkWildCase (App the_call (Var state_id))
+			    	     	     ccall_res_ty
 			                     (coreAltType the_alt) 
 			    	     	     [the_alt]
 			    	     ]
 
 	; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) }
 
-boxResult augment mbTopCon result_ty
+boxResult augment _mbTopCon result_ty
   = do -- It isn't IO, so do unsafePerformIO
        -- It's not conveniently available, so we inline it
        res <- resultWrapper result_ty
        (ccall_res_ty, the_alt) <- mk_alt return_result (augment res)
        let
-           wrap = \ the_call -> Case (App the_call (Var realWorldPrimId)) 
-                                     (mkWildId ccall_res_ty)
-                                     (coreAltType the_alt)
-                                     [the_alt]
+           wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId)) 
+                                     	   ccall_res_ty
+                                     	   (coreAltType the_alt)
+                                     	   [the_alt]
        return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
   where
-    return_result state [ans] = ans
-    return_result _ _ = panic "return_result: expected single result"
+    return_result _ [ans] = ans
+    return_result _ _     = panic "return_result: expected single result"
 
 
+mk_alt :: (Expr Var -> [Expr Var] -> Expr Var)
+       -> (Maybe Type, Expr Var -> Expr Var)
+       -> DsM (Type, (AltCon, [Id], Expr Var))
 mk_alt return_result (Nothing, wrap_result)
   = do -- The ccall returns ()
        state_id <- newSysLocalDs realWorldStatePrimTy
@@ -374,12 +367,12 @@ resultWrapper result_ty
 
   -- Base case 2: the unit type ()
   | Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey
-  = return (Nothing, \e -> Var unitDataConId)
+  = return (Nothing, \_ -> Var unitDataConId)
 
   -- Base case 3: the boolean type
   | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey
   = return
-     (Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
+     (Just intPrimTy, \e -> mkWildCase e intPrimTy
                                    boolTy
                                    [(DEFAULT             ,[],Var trueDataConId ),
                                     (LitAlt (mkMachInt 0),[],Var falseDataConId)])
@@ -415,7 +408,7 @@ resultWrapper result_ty
                  \ e -> App (Var pack_id) e)
 
     -- Objects; 'dotnet' only.
-  | Just (tc, [arg_ty]) <- maybe_tc_app, 
+  | Just (tc, [_]) <- maybe_tc_app, 
     tyConName tc == objectTyConName
   = do pack_id <- dsLookupGlobalId unmarshalObjectName
        return (Just addrPrimTy,