Module header tidyup, phase 1

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

diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index 46fc074..ba19124 100644 (file)
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -1,9 +1,9 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The AQUA Project, Glasgow University, 1998
 %
-\section[DsCCall]{Desugaring \tr{foreign} declarations}
 
-Expanding out @foreign import@ and @foreign export@ declarations.
+Desugaring foreign declarations (see also DsCCall).
 
 \begin{code}
 module DsForeign ( dsForeigns ) where
@@ -13,47 +13,33 @@ import TcRnMonad    -- temp
 
 import CoreSyn
 
-import DsCCall         ( dsCCall, mkFCall, boxResult, unboxArg, resultWrapper )
+import DsCCall
 import DsMonad
 
-import HsSyn           ( ForeignDecl(..), ForeignExport(..), LForeignDecl,
-                         ForeignImport(..), CImportSpec(..) )
-import DataCon         ( splitProductType_maybe )
-#ifdef DEBUG
-import DataCon         ( dataConSourceArity )
-import Type            ( isUnLiftedType )
-#endif
-import MachOp          ( machRepByteWidth, MachRep(..) )
-import SMRep           ( argMachRep, typeCgRep )
-import CoreUtils       ( exprType, mkInlineMe )
-import Id              ( Id, idType, idName, mkSysLocal, setInlinePragma )
-import Literal         ( Literal(..), mkStringLit )
-import Module          ( moduleNameFS, moduleName )
-import Name            ( getOccString, NamedThing(..) )
-import Type            ( repType, coreEqType )
-import TcType          ( Type, mkFunTys, mkForAllTys, mkTyConApp,
-                         mkFunTy, tcSplitTyConApp_maybe, tcSplitIOType_maybe,
-                         tcSplitForAllTys, tcSplitFunTys, tcTyConAppArgs,
-                         isBoolTy
-                       )
-
-import BasicTypes       ( Boxity(..) )
-import HscTypes                ( ForeignStubs(..) )
-import ForeignCall     ( ForeignCall(..), CCallSpec(..), 
-                         Safety(..), 
-                         CExportSpec(..), CLabelString,
-                         CCallConv(..), ccallConvToInt,
-                         ccallConvAttribute
-                       )
-import TysWiredIn      ( unitTy, tupleTyCon )
-import TysPrim         ( addrPrimTy, mkStablePtrPrimTy, alphaTy, intPrimTy )
-import PrelNames       ( stablePtrTyConName, newStablePtrName, bindIOName,
-                         checkDotnetResName )
-import BasicTypes      ( Activation( NeverActive ) )
-import SrcLoc          ( Located(..), unLoc )
+import HsSyn
+import DataCon
+import MachOp
+import SMRep
+import CoreUtils
+import Id
+import Literal
+import Module
+import Name
+import Type
+import Coercion
+import TcType
+
+import HscTypes
+import ForeignCall
+import TysWiredIn
+import TysPrim
+import PrelNames
+import BasicTypes
+import SrcLoc
 import Outputable
-import Maybe           ( fromJust, isNothing )
 import FastString
+
+import Data.Maybe
 \end{code}
 
 Desugaring of @foreign@ declarations is naturally split up into
@@ -83,10 +69,9 @@ dsForeigns fos
   combine stubs (L loc decl) = putSrcSpanDs loc (combine1 stubs decl)
 
   combine1 (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) 
-          (ForeignImport id _ spec depr)
+          (ForeignImport id _ spec)
     = traceIf (text "fi start" <+> ppr id)     `thenDs` \ _ ->
       dsFImport (unLoc id) spec                        `thenDs` \ (bs, h, c, mbhd) -> 
-      warnDepr depr                            `thenDs` \ _                ->
       traceIf (text "fi end" <+> ppr id)       `thenDs` \ _ ->
       returnDs (ForeignStubs (h $$ acc_h)
                             (c $$ acc_c)
@@ -95,10 +80,9 @@ dsForeigns fos
                bs ++ acc_f)
 
   combine1 (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) 
-          (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv)) depr)
+          (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv)))
     = dsFExport id (idType id) 
                ext_nm cconv False                 `thenDs` \(h, c, _, _) ->
-      warnDepr depr                               `thenDs` \_              ->
       returnDs (ForeignStubs (h $$ acc_h) (c $$ acc_c) acc_hdrs (id:acc_feb), 
                acc_f)
 
@@ -106,11 +90,6 @@ dsForeigns fos
   addH (Just e) ls
    | e `elem` ls = ls
    | otherwise   = e:ls
-
-  warnDepr False = returnDs ()
-  warnDepr True  = dsWarn msg
-     where
-       msg = ptext SLIT("foreign declaration uses deprecated non-standard syntax")
 \end{code}
 
 
@@ -331,7 +310,7 @@ f :: Fun -> IO (FunPtr Fun)
 f cback =
    bindIO (newStablePtr cback)
           (\StablePtr sp# -> IO (\s1# ->
-              case _ccall_ createAdjustor cconv sp# ``f_helper'' s1# of
+              case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of
                  (# s2#, a# #) -> (# s2#, A# a# #)))
 
 foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)
@@ -409,8 +388,9 @@ dsFExportDynamic id cconv
        -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
      let ccall_adj_ty = exprType ccall_adj
          ccall_io_adj = mkLams [stbl_value]                 $
-                       Note (Coerce io_res_ty ccall_adj_ty)
-                            ccall_adj
+                       (pprTrace "DsForeign: why is there an unsafeCoerce here?" (text "") $
+                       (Cast ccall_adj (mkUnsafeCoercion ccall_adj_ty io_res_ty )))
+
          io_app = mkLams tvs    $
                  mkLams [cback] $
                  stbl_app ccall_io_adj res_ty