[project @ 2003-04-17 15:22:38 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 5ee4780..0fcfdd5 100644 (file)
--- a/ghc/compiler/deSugar/DsCCall.lhs
+++ b/ghc/compiler/deSugar/DsCCall.lhs
@@ -18,8 +18,8 @@ import CoreSyn
 
 import DsMonad
 
-import CoreUtils       ( exprType, mkCoerce )
-import Id              ( Id, mkWildId, idType )
+import CoreUtils       ( exprType, mkCoerce2 )
+import Id              ( Id, mkWildId )
 import MkId            ( mkFCallId, realWorldPrimId, mkPrimOpId )
 import Maybes          ( maybeToBool )
 import ForeignCall     ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety, CCallConv(..) )
@@ -29,14 +29,13 @@ import ForeignCall  ( ForeignCall, CCallTarget(..) )
 import TcType          ( tcSplitTyConApp_maybe )
 import Type            ( Type, isUnLiftedType, mkFunTys, mkFunTy,
                          tyVarsOfType, mkForAllTys, mkTyConApp, 
-                         isPrimitiveType, eqType,
-                         splitTyConApp_maybe, splitNewType_maybe
+                         isPrimitiveType, splitTyConApp_maybe, 
+                         splitNewType_maybe, splitForAllTy_maybe,
                        )
 
 import PrimOp          ( PrimOp(..) )
-import TysPrim         ( realWorldStatePrimTy,
-                         byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
-                         intPrimTy, foreignObjPrimTy
+import TysPrim         ( realWorldStatePrimTy, intPrimTy,
+                         byteArrayPrimTyCon, mutableByteArrayPrimTyCon
                        )
 import TyCon           ( TyCon, tyConDataCons )
 import TysWiredIn      ( unitDataConId,
@@ -150,7 +149,7 @@ unboxArg arg
 
   -- Recursive newtypes
   | Just rep_ty <- splitNewType_maybe arg_ty
-  = unboxArg (mkCoerce rep_ty arg_ty arg)
+  = unboxArg (mkCoerce2 rep_ty arg_ty arg)
       
   -- Booleans
   | Just (tc,_) <- splitTyConApp_maybe arg_ty, 
@@ -220,11 +219,6 @@ boxResult :: [Id] -> Type -> DsM (Type, CoreExpr -> CoreExpr)
 -- the result type will be 
 --     State# RealWorld -> (# State# RealWorld #)
 
--- Here is where we arrange that ForeignPtrs which are passed to a 'safe'
--- foreign import don't get finalized until the call returns.  For each
--- argument of type ForeignObj# we arrange to touch# the argument after
--- the call.  The arg_ids passed in are the Ids passed to the actual ccall.
-
 boxResult arg_ids result_ty
   = case tcSplitTyConApp_maybe result_ty of
        -- This split absolutely has to be a tcSplit, because we must
@@ -267,13 +261,11 @@ boxResult arg_ids result_ty
   where
     mk_alt return_result (Nothing, wrap_result)
        =       -- The ccall returns ()
-         let
-               rhs_fun state_id = return_result (Var state_id) 
-                                       (wrap_result (panic "boxResult"))
-         in
          newSysLocalDs realWorldStatePrimTy    `thenDs` \ state_id ->
-         mkTouches arg_ids state_id rhs_fun    `thenDs` \ the_rhs ->
          let
+               the_rhs = return_result (Var state_id) 
+                                       (wrap_result (panic "boxResult"))
+
                ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy]
                the_alt      = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs)
          in
@@ -282,28 +274,16 @@ boxResult arg_ids result_ty
     mk_alt return_result (Just prim_res_ty, wrap_result)
        =       -- The ccall returns a non-() value
          newSysLocalDs prim_res_ty             `thenDs` \ result_id ->
-         let
-               rhs_fun state_id = return_result (Var state_id) 
-                                       (wrap_result (Var result_id))
-         in
          newSysLocalDs realWorldStatePrimTy    `thenDs` \ state_id ->
-         mkTouches arg_ids state_id rhs_fun    `thenDs` \ the_rhs ->
          let
+               the_rhs = return_result (Var state_id) 
+                                       (wrap_result (Var result_id))
+
                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)
 
-touchzh = mkPrimOpId TouchOp
-
-mkTouches []     s cont = returnDs (cont s)
-mkTouches (v:vs) s cont
-  | not (idType v `eqType` foreignObjPrimTy) = mkTouches vs s cont
-  | otherwise = newSysLocalDs realWorldStatePrimTy `thenDs` \s' -> 
-               mkTouches vs s' cont `thenDs` \ rest ->
-               returnDs (Case (mkApps (Var touchzh) [Type foreignObjPrimTy, 
-                                                     Var v, Var s]) s' 
-                               [(DEFAULT, [], rest)])
 
 resultWrapper :: Type
              -> (Maybe Type,           -- Type of the expected result, if any
@@ -328,7 +308,15 @@ resultWrapper result_ty
   = let
         (maybe_ty, wrapper) = resultWrapper rep_ty
     in
-    (maybe_ty, \e -> mkCoerce result_ty rep_ty (wrapper e))
+    (maybe_ty, \e -> mkCoerce2 result_ty rep_ty (wrapper e))
+
+  -- The type might contain foralls (eg. for dummy type arguments,
+  -- referring to 'Ptr a' is legal).
+  | Just (tyvar, rest) <- splitForAllTy_maybe result_ty
+  = let
+        (maybe_ty, wrapper) = resultWrapper rest
+    in
+    (maybe_ty, \e -> Lam tyvar (wrapper e))
 
   -- Data types with a single constructor, which has a single arg
   | Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty,