[project @ 2003-08-20 12:55:14 by simonmar]

[ghc-hetmet.git] / ghc / compiler / deSugar / DsForeign.lhs

diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs
index 9cefb05..4f34d4c 100644 (file)
--- a/ghc/compiler/deSugar/DsForeign.lhs
+++ b/ghc/compiler/deSugar/DsForeign.lhs
@@ -30,6 +30,7 @@ import TcType         ( Type, mkFunTys, mkForAllTys, mkTyConApp,
                          tcSplitForAllTys, tcSplitFunTys, tcTyConAppArgs,
                        )
 
+import BasicTypes       ( Boxity(..) )
 import HscTypes                ( ForeignStubs(..) )
 import ForeignCall     ( ForeignCall(..), CCallSpec(..), 
                          Safety(..), playSafe,
@@ -38,10 +39,11 @@ import ForeignCall  ( ForeignCall(..), CCallSpec(..),
                          ccallConvAttribute
                        )
 import CStrings                ( CLabelString )
-import TysWiredIn      ( unitTy, stablePtrTyCon )
+import TysWiredIn      ( unitTy, tupleTyCon )
 import TysPrim         ( addrPrimTy, mkStablePtrPrimTy, alphaTy )
 import PrimRep          ( getPrimRepSizeInBytes )
-import PrelNames       ( hasKey, ioTyConKey, newStablePtrName, bindIOName )
+import PrelNames       ( hasKey, ioTyConKey, stablePtrTyConName, newStablePtrName, bindIOName,
+                         checkDotnetResName )
 import BasicTypes      ( Activation( NeverActive ) )
 import Outputable
 import Maybe           ( fromJust )
@@ -150,11 +152,10 @@ dsCImport :: Id
          -> Bool       -- True <=> no headers in the f.i decl
          -> DsM ([Binding], SDoc, SDoc)
 dsCImport id (CLabel cid) _ _ no_hdrs
- = ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this
-   returnDs ([(setImpInline no_hdrs id, rhs)], empty, empty)
- where
-   (resTy, foRhs) = resultWrapper (idType id)
-   rhs           = foRhs (mkLit (MachLabel cid Nothing))
+ = resultWrapper (idType id) `thenDs` \ (resTy, foRhs) ->
+   ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this
+    let rhs = foRhs (mkLit (MachLabel cid Nothing)) in
+    returnDs ([(setImpInline no_hdrs id, rhs)], empty, empty)
 dsCImport id (CFunction target) cconv safety no_hdrs
   = dsFCall id (CCall (CCallSpec target cconv safety)) no_hdrs
 dsCImport id CWrapper cconv _ _
@@ -204,8 +205,34 @@ dsFCall fn_id fcall no_hdrs
        -- ForeignObj#s live across a 'safe' foreign import).
        maybe_arg_ids | unsafe_call fcall = work_arg_ids
                      | otherwise         = []
+
+       forDotnet = 
+        case fcall of
+          DNCall{} -> True
+          _        -> False
+
+       topConDs
+         | forDotnet = 
+            dsLookupGlobalId checkDotnetResName `thenDs` \ check_id -> 
+            return (Just check_id)
+          | otherwise = return Nothing
+            
+       augmentResultDs
+         | forDotnet = 
+               newSysLocalDs addrPrimTy `thenDs` \ err_res -> 
+               returnDs (\ (mb_res_ty, resWrap) ->
+                             case mb_res_ty of
+                               Nothing -> (Just (mkTyConApp (tupleTyCon Unboxed 1)
+                                                            [ addrPrimTy ]),
+                                                resWrap)
+                               Just x  -> (Just (mkTyConApp (tupleTyCon Unboxed 2)
+                                                            [ x, addrPrimTy ]),
+                                                resWrap))
+         | otherwise = returnDs id
     in
-    boxResult maybe_arg_ids io_res_ty                  `thenDs` \ (ccall_result_ty, res_wrapper) ->
+    augmentResultDs                                 `thenDs` \ augment -> 
+    topConDs                                        `thenDs` \ topCon -> 
+    boxResult maybe_arg_ids augment topCon io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
 
     getUniqueDs                                        `thenDs` \ ccall_uniq ->
     getUniqueDs                                        `thenDs` \ work_uniq ->
@@ -326,23 +353,24 @@ dsFExportDynamic id cconv
         -- hack: need to get at the name of the C stub we're about to generate.
        fe_nm      = mkFastString (moduleString mod_name ++ "_" ++ toCName fe_id)
      in
-     dsFExport id export_ty fe_nm cconv True   `thenDs` \ (h_code, c_code, stub_args) ->
      newSysLocalDs arg_ty                      `thenDs` \ cback ->
-     dsLookupGlobalId newStablePtrName `thenDs` \ newStablePtrId ->
+     dsLookupGlobalId newStablePtrName         `thenDs` \ newStablePtrId ->
+     dsLookupTyCon stablePtrTyConName          `thenDs` \ stable_ptr_tycon ->
      let
-       mk_stbl_ptr_app    = mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
+       mk_stbl_ptr_app = mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
+       stable_ptr_ty   = mkTyConApp stable_ptr_tycon [arg_ty]
+       export_ty       = mkFunTy stable_ptr_ty arg_ty
      in
-     dsLookupGlobalId bindIOName                       `thenDs` \ bindIOId ->
-     newSysLocalDs (mkTyConApp stablePtrTyCon [arg_ty]) `thenDs` \ stbl_value ->
+     dsLookupGlobalId bindIOName               `thenDs` \ bindIOId ->
+     newSysLocalDs stable_ptr_ty               `thenDs` \ stbl_value ->
+     dsFExport id export_ty fe_nm cconv True   `thenDs` \ (h_code, c_code, stub_args) ->
      let
-      stbl_app cont ret_ty 
-       = mkApps (Var bindIOId)
-                [ Type (mkTyConApp stablePtrTyCon [arg_ty])
-                , Type ret_ty
-                , mk_stbl_ptr_app
-                , cont
-                ]
-
+      stbl_app cont ret_ty = mkApps (Var bindIOId)
+                                   [ Type stable_ptr_ty
+                                   , Type ret_ty       
+                                   , mk_stbl_ptr_app
+                                   , cont
+                                   ]
        {-
         The arguments to the external function which will
        create a little bit of (template) code on the fly
@@ -356,12 +384,12 @@ dsFExportDynamic id cconv
                      ]
         -- name of external entry point providing these services.
        -- (probably in the RTS.) 
-      adjustor     = FSLIT("createAdjustor")
+      adjustor  = FSLIT("createAdjustor")
       
-      mb_sz_args =
-        case cconv of
-         StdCallConv -> Just (sum (map (getPrimRepSizeInBytes . typePrimRep) stub_args))
-         _ -> Nothing
+      sz_args   = sum (map (getPrimRepSizeInBytes . typePrimRep) stub_args)
+      mb_sz_args = case cconv of
+                     StdCallConv -> Just sz_args
+                     _           -> Nothing
      in
      dsCCall adjustor adj_args PlayRisky False io_res_ty       `thenDs` \ ccall_adj ->
        -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
@@ -384,7 +412,6 @@ dsFExportDynamic id cconv
   ([arg_ty], io_res_ty)        = tcSplitFunTys sans_foralls
   [res_ty]             = tcTyConAppArgs io_res_ty
        -- Must use tcSplit* to see the (IO t), which is a newtype
-  export_ty            = mkFunTy (mkTyConApp stablePtrTyCon [arg_ty]) arg_ty
 
 toCName :: Id -> String
 toCName i = showSDoc (pprCode CStyle (ppr (idName i)))