[project @ 2005-01-10 18:44:38 by wolfgang]
[ghc-hetmet.git] / ghc / compiler / deSugar / DsForeign.lhs
index 77aa412..808016d 100644 (file)
@@ -16,16 +16,22 @@ import CoreSyn
 import DsCCall         ( dsCCall, mkFCall, boxResult, unboxArg, resultWrapper )
 import DsMonad
 
-import HsSyn           ( ForeignDecl(..), ForeignExport(..),
+import HsSyn           ( ForeignDecl(..), ForeignExport(..), LForeignDecl,
                          ForeignImport(..), CImportSpec(..) )
-import TcHsSyn         ( TypecheckedForeignDecl )
+import DataCon         ( splitProductType_maybe )
+#ifdef DEBUG
+import DataCon         ( dataConSourceArity )
+import Type            ( isUnLiftedType )
+#endif
+import MachOp          ( machRepByteWidth, MachRep(..) )
+import SMRep           ( argMachRep, primRepToCgRep )
 import CoreUtils       ( exprType, mkInlineMe )
 import Id              ( Id, idType, idName, mkSysLocal, setInlinePragma )
-import Literal         ( Literal(..) )
+import Literal         ( Literal(..), mkStringLit )
 import Module          ( moduleString )
 import Name            ( getOccString, NamedThing(..) )
 import OccName         ( encodeFS )
-import Type            ( repType, eqType, typePrimRep )
+import Type            ( repType, coreEqType, typePrimRep )
 import TcType          ( Type, mkFunTys, mkForAllTys, mkTyConApp,
                          mkFunTy, tcSplitTyConApp_maybe, 
                          tcSplitForAllTys, tcSplitFunTys, tcTyConAppArgs,
@@ -35,17 +41,16 @@ import BasicTypes       ( Boxity(..) )
 import HscTypes                ( ForeignStubs(..) )
 import ForeignCall     ( ForeignCall(..), CCallSpec(..), 
                          Safety(..), playSafe,
-                         CExportSpec(..),
+                         CExportSpec(..), CLabelString,
                          CCallConv(..), ccallConvToInt,
                          ccallConvAttribute
                        )
-import CStrings                ( CLabelString )
 import TysWiredIn      ( unitTy, tupleTyCon )
 import TysPrim         ( addrPrimTy, mkStablePtrPrimTy, alphaTy )
-import PrimRep          ( getPrimRepSizeInBytes )
 import PrelNames       ( hasKey, ioTyConKey, stablePtrTyConName, newStablePtrName, bindIOName,
                          checkDotnetResName )
 import BasicTypes      ( Activation( NeverActive ) )
+import SrcLoc          ( Located(..), unLoc )
 import Outputable
 import Maybe           ( fromJust )
 import FastString
@@ -68,7 +73,7 @@ so we reuse the desugaring code in @DsCCall@ to deal with these.
 type Binding = (Id, CoreExpr)  -- No rec/nonrec structure;
                                -- the occurrence analyser will sort it all out
 
-dsForeigns :: [TypecheckedForeignDecl] 
+dsForeigns :: [LForeignDecl Id] 
           -> DsM (ForeignStubs, [Binding])
 dsForeigns [] 
   = returnDs (NoStubs, [])
@@ -76,10 +81,10 @@ dsForeigns fos
   = foldlDs combine (ForeignStubs empty empty [] [], []) fos
  where
   combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) 
-         (ForeignImport id _ spec depr loc)
+         (L loc (ForeignImport id _ spec depr))
     = traceIf (text "fi start" <+> ppr id)     `thenDs` \ _ ->
-      dsFImport id spec                   `thenDs` \ (bs, h, c, mbhd) -> 
-      warnDepr depr loc                   `thenDs` \ _                ->
+      dsFImport (unLoc id) spec                        `thenDs` \ (bs, h, c, mbhd) -> 
+      warnDepr depr loc                                `thenDs` \ _                ->
       traceIf (text "fi end" <+> ppr id)       `thenDs` \ _ ->
       returnDs (ForeignStubs (h $$ acc_h)
                             (c $$ acc_c)
@@ -88,7 +93,7 @@ dsForeigns fos
                bs ++ acc_f)
 
   combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) 
-         (ForeignExport id _ (CExport (CExportStatic ext_nm cconv)) depr loc)
+         (L loc (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv)) depr))
     = dsFExport id (idType id) 
                ext_nm cconv False                 `thenDs` \(h, c, _) ->
       warnDepr depr loc                                   `thenDs` \_              ->
@@ -156,7 +161,7 @@ dsCImport :: Id
          -> DsM ([Binding], SDoc, SDoc)
 dsCImport id (CLabel cid) _ _ no_hdrs
  = resultWrapper (idType id) `thenDs` \ (resTy, foRhs) ->
-   ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this
+   ASSERT(fromJust resTy `coreEqType` 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
@@ -287,7 +292,7 @@ dsFExport :: Id                     -- Either the exported Id,
                                --         the first argument's stable pointer
          -> DsM ( SDoc         -- contents of Module_stub.h
                 , SDoc         -- contents of Module_stub.c
-                , [Type]       -- arguments expected by stub function.
+                , [Type]       -- primitive arguments expected by stub function.
                 )
 
 dsFExport fn_id ty ext_name cconv isDyn
@@ -384,15 +389,35 @@ dsFExportDynamic id cconv
       adj_args      = [ mkIntLitInt (ccallConvToInt cconv)
                      , Var stbl_value
                      , mkLit (MachLabel fe_nm mb_sz_args)
+                      , mkLit (mkStringLit arg_type_info)
                      ]
         -- name of external entry point providing these services.
        -- (probably in the RTS.) 
       adjustor  = FSLIT("createAdjustor")
       
-      sz_args   = sum (map (getPrimRepSizeInBytes . typePrimRep) stub_args)
+      arg_type_info = drop 2 $ map (repCharCode.argMachRep
+                                   .primRepToCgRep.typePrimRep)
+                                   stub_args
+      repCharCode F32 = 'f'
+      repCharCode F64 = 'd'
+      repCharCode I64 = 'l'
+      repCharCode _   = 'i'
+
+       -- Determine the number of bytes of arguments to the stub function,
+       -- so that we can attach the '@N' suffix to its label if it is a
+       -- stdcall on Windows.
       mb_sz_args = case cconv of
-                     StdCallConv -> Just sz_args
+                     StdCallConv -> Just (sum (map ty_size stub_args))
                      _           -> Nothing
+
+       -- NB. the calculation here isn't strictly speaking correct.
+       -- We have a primitive Haskell type (eg. Int#, Double#), and
+       -- we want to know the size, when passed on the C stack, of
+       -- the associated C type (eg. HsInt, HsDouble).  We don't have
+       -- this information to hand, but we know what GHC's conventions
+       -- are for passing around the primitive Haskell types, so we
+       -- use that instead.  I hope the two coincide --SDM
+      ty_size = machRepByteWidth.argMachRep.primRepToCgRep.typePrimRep
      in
      dsCCall adjustor adj_args PlayRisky io_res_ty     `thenDs` \ ccall_adj ->
        -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
@@ -437,9 +462,12 @@ mkFExportCBits :: FastString
               -> Type 
                -> Bool         -- True <=> returns an IO type
               -> CCallConv 
-              -> (SDoc, SDoc, [Type])
+              -> (SDoc, 
+                  SDoc,
+                  [Type]       -- the *primitive* argument types
+                 )
 mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc 
- = (header_bits, c_bits, all_arg_tys)
+ = (header_bits, c_bits, all_prim_arg_tys)
  where
   -- Create up types and names for the real args
   arg_cnames, arg_ctys :: [SDoc]
@@ -461,11 +489,11 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
   all_cnames_and_ctys 
      = map fst extra_cnames_and_tys ++ zip arg_cnames arg_ctys
 
-  all_arg_tys
-     = map snd extra_cnames_and_tys ++ arg_htys
+  all_prim_arg_tys
+     = map snd extra_cnames_and_tys ++ map getPrimTyOf arg_htys
 
   -- stuff to do with the return type of the C function
-  res_hty_is_unit = res_hty `eqType` unitTy    -- Look through any newtypes
+  res_hty_is_unit = res_hty `coreEqType` unitTy        -- Look through any newtypes
 
   cResType | res_hty_is_unit = text "void"
           | otherwise       = showStgType res_hty
@@ -561,4 +589,18 @@ showFFIType t = getOccString (getName tc)
   tc = case tcSplitTyConApp_maybe (repType t) of
            Just (tc,_) -> tc
            Nothing     -> pprPanic "showFFIType" (ppr t)
+
+-- This function returns the primitive type associated with the boxed
+-- type argument to a foreign export (eg. Int ==> Int#).  It assumes
+-- that all the types we are interested in have a single constructor
+-- with a single primitive-typed argument, which is true for all of the legal
+-- foreign export argument types (see TcType.legalFEArgTyCon).
+getPrimTyOf :: Type -> Type
+getPrimTyOf ty =
+  case splitProductType_maybe (repType ty) of
+     Just (_, _, data_con, [prim_ty]) ->
+       ASSERT(dataConSourceArity data_con == 1)
+       ASSERT2(isUnLiftedType prim_ty, ppr prim_ty)
+       prim_ty
+     _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
 \end{code}