X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsCCall.lhs;h=57bace20008452697a943c95baab6d7a2932c580;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=f2fdc288f597efc7e1cfa859817207b4ece4caf0;hpb=f5fbd41ca7f30e0f8db3f7b280a044d5af138428;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs
index f2fdc28..57bace2 100644
--- a/ghc/compiler/deSugar/DsCCall.lhs
+++ b/ghc/compiler/deSugar/DsCCall.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The AQUA Project, Glasgow University, 1994-1998
 %
-\section[DsCCall]{Desugaring \tr{_ccall_}s and \tr{_casm_}s}
+\section[DsCCall]{Desugaring C calls}
 
 \begin{code}
 module DsCCall 
@@ -14,6 +14,7 @@ module DsCCall
 
 #include "HsVersions.h"
 
+
 import CoreSyn
 
 import DsMonad
@@ -22,7 +23,8 @@ import CoreUtils	( exprType, 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(..) )
 
@@ -30,7 +32,7 @@ import TcType		( tcSplitTyConApp_maybe )
 import Type		( Type, isUnLiftedType, mkFunTys, mkFunTy,
 			  tyVarsOfType, mkForAllTys, mkTyConApp, 
 			  isPrimitiveType, splitTyConApp_maybe, 
-			  splitNewType_maybe, splitForAllTy_maybe,
+			  splitRecNewType_maybe, splitForAllTy_maybe,
 			  isUnboxedTupleType
 			)
 
@@ -50,7 +52,6 @@ import TysWiredIn	( unitDataConId,
 			)
 import BasicTypes       ( Boxity(..) )
 import Literal		( mkMachInt )
-import CStrings		( CLabelString )
 import PrelNames	( Unique, hasKey, ioTyConKey, boolTyConKey, unitTyConKey,
 			  int8TyConKey, int16TyConKey, int32TyConKey,
 			  word8TyConKey, word16TyConKey, word32TyConKey
@@ -62,6 +63,11 @@ import PrelNames	( Unique, hasKey, ioTyConKey, boolTyConKey, unitTyConKey,
 import VarSet		( varSetElems )
 import Constants	( wORD_SIZE)
 import Outputable
+
+#ifdef DEBUG
+import TypeRep
+#endif
+
 \end{code}
 
 Desugaring of @ccall@s consists of adding some state manipulation,
@@ -103,17 +109,15 @@ follows:
 dsCCall :: CLabelString	-- C routine to invoke
 	-> [CoreExpr]	-- Arguments (desugared)
 	-> Safety	-- Safety of the call
-	-> Bool		-- True <=> really a "_casm_"
 	-> Type		-- Type of the result: IO t
 	-> DsM CoreExpr
 
-dsCCall lbl args may_gc is_asm result_ty
+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) ->
-    getUniqueDs			       `thenDs` \ uniq ->
+    newUnique			       `thenDs` \ uniq ->
     let
-	target | is_asm    = CasmTarget lbl
-	       | otherwise = StaticTarget lbl
+	target = StaticTarget lbl
 	the_fcall    = CCall (CCallSpec target CCallConv may_gc)
  	the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
     in
@@ -157,7 +161,7 @@ unboxArg arg
   = returnDs (arg, \body -> body)
 
   -- Recursive newtypes
-  | Just rep_ty <- splitNewType_maybe arg_ty
+  | Just rep_ty <- splitRecNewType_maybe arg_ty
   = unboxArg (mkCoerce2 rep_ty arg_ty arg)
       
   -- Booleans
@@ -174,7 +178,8 @@ unboxArg arg
   -- Data types with a single constructor, which has a single, primitive-typed arg
   -- This deals with Int, Float etc; also Ptr, ForeignPtr
   | is_product_type && data_con_arity == 1 
-  = ASSERT(isUnLiftedType data_con_arg_ty1 )	-- Typechecker ensures this
+  = ASSERT2(isUnLiftedType data_con_arg_ty1, pprType arg_ty)
+			-- Typechecker ensures this
     newSysLocalDs arg_ty		`thenDs` \ case_bndr ->
     newSysLocalDs data_con_arg_ty1	`thenDs` \ prim_arg ->
     returnDs (Var prim_arg,
@@ -233,7 +238,7 @@ unboxArg arg
 		       ])
 
   | otherwise
-  = getSrcLocDs `thenDs` \ l ->
+  = getSrcSpanDs `thenDs` \ l ->
     pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
   where
     arg_ty					= exprType arg
@@ -337,10 +342,10 @@ boxResult arg_ids augment mbTopCon result_ty
     		-- The ccall returns a non-() value
         | isUnboxedTupleType prim_res_ty
         = let
-		(Just (_, ls@(prim_res_ty1:extras))) = splitTyConApp_maybe prim_res_ty
+		Just (_, ls) = splitTyConApp_maybe prim_res_ty
 		arity = 1 + length ls
 	  in
-	  mapDs newSysLocalDs ls 		`thenDs` \ args_ids@(result_id:as) ->
+	  mappM newSysLocalDs ls 		`thenDs` \ args_ids@(result_id:as) ->
 	  newSysLocalDs realWorldStatePrimTy	`thenDs` \ state_id ->
 	  let
 		the_rhs = return_result (Var state_id) 
@@ -354,8 +359,7 @@ boxResult arg_ids augment mbTopCon result_ty
 	  in
 	  returnDs (ccall_res_ty, the_alt)
 	| otherwise
-	=	
-	  newSysLocalDs prim_res_ty 		`thenDs` \ result_id ->
+	= newSysLocalDs prim_res_ty 		`thenDs` \ result_id ->
 	  newSysLocalDs realWorldStatePrimTy	`thenDs` \ state_id ->
 	  let
 		the_rhs = return_result (Var state_id) 
@@ -387,7 +391,7 @@ resultWrapper result_ty
 				    (LitAlt (mkMachInt 0),[],Var falseDataConId)])
 
   -- Recursive newtypes
-  | Just rep_ty <- splitNewType_maybe result_ty
+  | Just rep_ty <- splitRecNewType_maybe result_ty
   = resultWrapper rep_ty `thenDs` \ (maybe_ty, wrapper) ->
     returnDs (maybe_ty, \e -> mkCoerce2 result_ty rep_ty (wrapper e))